(*  Title:      HOL/ex/LocaleTest2.thy
    Author:     Clemens Ballarin
    Copyright (c) 2007 by Clemens Ballarin

More regression tests for locales.
Definitions are less natural in FOL, since there is no selection operator.
Hence we do them here in HOL, not in the main test suite for locales,
which is FOL/ex/LocaleTest.thy
*)

section \<open>Test of Locale Interpretation\<close>

theory LocaleTest2
imports MainRLT
begin

section \<open>Interpretation of Defined Concepts\<close>

text \<open>Naming convention for global objects: prefixes D and d\<close>

subsection \<open>Lattices\<close>

text \<open>Much of the lattice proofs are from HOL/Lattice.\<close>

subsubsection \<open>Definitions\<close>

locale dpo =
  fixes le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>" 50)
  assumes refl [intro, simp]: "x \<sqsubseteq> x"
    and antisym [intro]: "[| x \<sqsubseteq> y; y \<sqsubseteq> x |] ==> x = y"
    and trans [trans]: "[| x \<sqsubseteq> y; y \<sqsubseteq> z |] ==> x \<sqsubseteq> z"

begin

theorem circular:
  "[| x \<sqsubseteq> y; y \<sqsubseteq> z; z \<sqsubseteq> x |] ==> x = y & y = z"
  by (blast intro: trans)

definition
  less :: "['a, 'a] => bool" (infixl "\<sqsubset>" 50)
  where "(x \<sqsubset> y) = (x \<sqsubseteq> y & x ~= y)"

theorem abs_test:
  "(\<sqsubset>) = (\<lambda>x y. x \<sqsubset> y)"
  by simp

definition
  is_inf :: "['a, 'a, 'a] => bool"
  where "is_inf x y i = (i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"

definition
  is_sup :: "['a, 'a, 'a] => bool"
  where "is_sup x y s = (x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z))"

end

locale dlat = dpo +
  assumes ex_inf: "\<exists>inf. dpo.is_inf le x y inf"
    and ex_sup: "\<exists>sup. dpo.is_sup le x y sup"

begin

definition
  meet :: "['a, 'a] => 'a" (infixl "\<sqinter>" 70)
  where "x \<sqinter> y = (THE inf. is_inf x y inf)"

definition
  join :: "['a, 'a] => 'a" (infixl "\<squnion>" 65)
  where "x \<squnion> y = (THE sup. is_sup x y sup)"

lemma is_infI [intro?]: "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow>
    (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> is_inf x y i"
  by (unfold is_inf_def) blast

lemma is_inf_lower [elim?]:
  "is_inf x y i \<Longrightarrow> (i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_inf_def) blast

lemma is_inf_greatest [elim?]:
    "is_inf x y i \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i"
  by (unfold is_inf_def) blast

theorem is_inf_uniq: "is_inf x y i \<Longrightarrow> is_inf x y i' \<Longrightarrow> i = i'"
proof -
  assume inf: "is_inf x y i"
  assume inf': "is_inf x y i'"
  show ?thesis
  proof (rule antisym)
    from inf' show "i \<sqsubseteq> i'"
    proof (rule is_inf_greatest)
      from inf show "i \<sqsubseteq> x" ..
      from inf show "i \<sqsubseteq> y" ..
    qed
    from inf show "i' \<sqsubseteq> i"
    proof (rule is_inf_greatest)
      from inf' show "i' \<sqsubseteq> x" ..
      from inf' show "i' \<sqsubseteq> y" ..
    qed
  qed
qed

theorem is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
  qed
qed

lemma meet_equality [elim?]: "is_inf x y i \<Longrightarrow> x \<sqinter> y = i"
proof (unfold meet_def)
  assume "is_inf x y i"
  then show "(THE i. is_inf x y i) = i"
    by (rule the_equality) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
qed

lemma meetI [intro?]:
    "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> x \<sqinter> y = i"
  by (rule meet_equality, rule is_infI) blast+

lemma is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
proof (unfold meet_def)
  from ex_inf obtain i where "is_inf x y i" ..
  then show "is_inf x y (THE i. is_inf x y i)"
    by (rule theI) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
qed

lemma meet_left [intro?]:
  "x \<sqinter> y \<sqsubseteq> x"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_right [intro?]:
  "x \<sqinter> y \<sqsubseteq> y"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_le [intro?]:
  "[| z \<sqsubseteq> x; z \<sqsubseteq> y |] ==> z \<sqsubseteq> x \<sqinter> y"
  by (rule is_inf_greatest) (rule is_inf_meet)

lemma is_supI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> is_sup x y s"
  by (unfold is_sup_def) blast

lemma is_sup_least [elim?]:
    "is_sup x y s \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z"
  by (unfold is_sup_def) blast

lemma is_sup_upper [elim?]:
    "is_sup x y s \<Longrightarrow> (x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_sup_def) blast

theorem is_sup_uniq: "is_sup x y s \<Longrightarrow> is_sup x y s' \<Longrightarrow> s = s'"
proof -
  assume sup: "is_sup x y s"
  assume sup': "is_sup x y s'"
  show ?thesis
  proof (rule antisym)
    from sup show "s \<sqsubseteq> s'"
    proof (rule is_sup_least)
      from sup' show "x \<sqsubseteq> s'" ..
      from sup' show "y \<sqsubseteq> s'" ..
    qed
    from sup' show "s' \<sqsubseteq> s"
    proof (rule is_sup_least)
      from sup show "x \<sqsubseteq> s" ..
      from sup show "y \<sqsubseteq> s" ..
    qed
  qed
qed

theorem is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> y" by fact
    show "y \<sqsubseteq> y" ..
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed
qed

lemma join_equality [elim?]: "is_sup x y s \<Longrightarrow> x \<squnion> y = s"
proof (unfold join_def)
  assume "is_sup x y s"
  then show "(THE s. is_sup x y s) = s"
    by (rule the_equality) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
qed

lemma joinI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = s"
  by (rule join_equality, rule is_supI) blast+

lemma is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
proof (unfold join_def)
  from ex_sup obtain s where "is_sup x y s" ..
  then show "is_sup x y (THE s. is_sup x y s)"
    by (rule theI) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
qed

lemma join_left [intro?]:
  "x \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_right [intro?]:
  "y \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_le [intro?]:
  "[| x \<sqsubseteq> z; y \<sqsubseteq> z |] ==> x \<squnion> y \<sqsubseteq> z"
  by (rule is_sup_least) (rule is_sup_join)

theorem meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
proof (rule meetI)
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
  proof
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> y" ..
      finally show ?thesis .
    qed
  qed
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
  proof -
    have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
    also have "\<dots> \<sqsubseteq> z" ..
    finally show ?thesis .
  qed
  fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
  show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
  proof
    show "w \<sqsubseteq> x"
    proof -
      have "w \<sqsubseteq> x \<sqinter> y" by fact
      also have "\<dots> \<sqsubseteq> x" ..
      finally show ?thesis .
    qed
    show "w \<sqsubseteq> y \<sqinter> z"
    proof
      show "w \<sqsubseteq> y"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> z" by fact
    qed
  qed
qed

theorem meet_commute: "x \<sqinter> y = y \<sqinter> x"
proof (rule meetI)
  show "y \<sqinter> x \<sqsubseteq> x" ..
  show "y \<sqinter> x \<sqsubseteq> y" ..
  fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
  then show "z \<sqsubseteq> y \<sqinter> x" ..
qed

theorem meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
proof (rule meetI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> x \<squnion> y" ..
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
proof (rule joinI)
  show "x \<squnion> y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof
    show "x \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    show "y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof -
      have "y \<sqsubseteq> y \<squnion> z" ..
      also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      finally show ?thesis .
    qed
  qed
  show "z \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof -
    have "z \<sqsubseteq> y \<squnion> z"  ..
    also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    finally show ?thesis .
  qed
  fix w assume "x \<squnion> y \<sqsubseteq> w" and "z \<sqsubseteq> w"
  show "x \<squnion> (y \<squnion> z) \<sqsubseteq> w"
  proof
    show "x \<sqsubseteq> w"
    proof -
      have "x \<sqsubseteq> x \<squnion> y" ..
      also have "\<dots> \<sqsubseteq> w" by fact
      finally show ?thesis .
    qed
    show "y \<squnion> z \<sqsubseteq> w"
    proof
      show "y \<sqsubseteq> w"
      proof -
        have "y \<sqsubseteq> x \<squnion> y" ..
        also have "... \<sqsubseteq> w" by fact
        finally show ?thesis .
      qed
      show "z \<sqsubseteq> w" by fact
    qed
  qed
qed

theorem join_commute: "x \<squnion> y = y \<squnion> x"
proof (rule joinI)
  show "x \<sqsubseteq> y \<squnion> x" ..
  show "y \<sqsubseteq> y \<squnion> x" ..
  fix z assume "y \<sqsubseteq> z" and "x \<sqsubseteq> z"
  then show "y \<squnion> x \<sqsubseteq> z" ..
qed

theorem join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
proof (rule joinI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqinter> y \<sqsubseteq> x" ..
  fix z assume "x \<sqsubseteq> z" and "x \<sqinter> y \<sqsubseteq> z"
  show "x \<sqsubseteq> z" by fact
qed

theorem meet_idem: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
  also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
  finally show ?thesis .
qed

theorem meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
proof (rule meetI)
  assume "x \<sqsubseteq> y"
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem meet_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<sqinter> y = y"
  by (drule meet_related) (simp add: meet_commute)

theorem join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
proof (rule joinI)
  assume "x \<sqsubseteq> y"
  show "y \<sqsubseteq> y" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
  show "y \<sqsubseteq> z" by fact
qed

theorem join_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
  by (drule join_related) (simp add: join_commute)

text \<open>Additional theorems\<close>

theorem meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_inf x y x" ..
  then show "x \<sqinter> y = x" ..
next
  have "x \<sqinter> y \<sqsubseteq> y" ..
  also assume "x \<sqinter> y = x"
  finally show "x \<sqsubseteq> y" .
qed

theorem meet_connection2: "(x \<sqsubseteq> y) = (y \<sqinter> x = x)"
  using meet_commute meet_connection by simp

theorem join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_sup x y y" ..
  then show "x \<squnion> y = y" ..
next
  have "x \<sqsubseteq> x \<squnion> y" ..
  also assume "x \<squnion> y = y"
  finally show "x \<sqsubseteq> y" .
qed

theorem join_connection2: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
  using join_commute join_connection by simp

text \<open>Naming according to Jacobson I, p.\ 459.\<close>

lemmas L1 = join_commute meet_commute
lemmas L2 = join_assoc meet_assoc
(*lemmas L3 = join_idem meet_idem*)
lemmas L4 = join_meet_absorb meet_join_absorb

end

locale ddlat = dlat +
  assumes meet_distr:
    "dlat.meet le x (dlat.join le y z) =
    dlat.join le (dlat.meet le x y) (dlat.meet le x z)"

begin

lemma join_distr:
  "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  txt \<open>Jacobson I, p.\ 462\<close>
proof -
  have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)" by (simp add: L4)
  also have "... = x \<squnion> ((x \<sqinter> z) \<squnion> (y \<sqinter> z))" by (simp add: L2)
  also have "... = x \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 meet_distr)
  also have "... = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 L4)
  also have "... = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by (simp add: meet_distr)
  finally show ?thesis .
qed

end

locale dlo = dpo +
  assumes total: "x \<sqsubseteq> y | y \<sqsubseteq> x"

begin

lemma less_total: "x \<sqsubset> y | x = y | y \<sqsubset> x"
  using total
  by (unfold less_def) blast

end

sublocale dlo < dlat
proof
  fix x y
  from total have "is_inf x y (if x \<sqsubseteq> y then x else y)" by (auto simp: is_inf_def)
  then show "\<exists>inf. is_inf x y inf" by blast
next
  fix x y
  from total have "is_sup x y (if x \<sqsubseteq> y then y else x)" by (auto simp: is_sup_def)
  then show "\<exists>sup. is_sup x y sup" by blast
qed

sublocale dlo < ddlat
proof
  fix x y z
  show "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z" (is "?l = ?r")
    txt \<open>Jacobson I, p.\ 462\<close>
  proof -
    { assume c: "y \<sqsubseteq> x" "z \<sqsubseteq> x"
      from c have "?l = y \<squnion> z"
        by (metis c (*join_commute*) join_connection2 join_related2 (*meet_commute*) meet_connection meet_related2 total)
      also from c have "... = ?r" by (metis (*c*) (*join_commute*) meet_related2)
      finally have "?l = ?r" . }
    moreover
    { assume c: "x \<sqsubseteq> y | x \<sqsubseteq> z"
      from c have "?l = x"
        by (metis (*antisym*) (*c*) (*circular*) (*join_assoc*)(* join_commute *) join_connection2 (*join_left*) join_related2 meet_connection(* meet_related2*) total trans)
      also from c have "... = ?r"
        by (metis join_commute join_related2 meet_connection meet_related2 total)
      finally have "?l = ?r" . }
    moreover note total
    ultimately show ?thesis by blast
  qed
qed

subsubsection \<open>Total order \<open><=\<close> on \<^typ>\<open>int\<close>\<close>

interpretation int: dpo "(<=) :: [int, int] => bool"
  rewrites "(dpo.less (<=) (x::int) y) = (x < y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo ((<=) :: [int, int] => bool)"
    proof qed auto
  then interpret int: dpo "(<=) :: [int, int] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "(dpo.less (<=) (x::int) y) = (x < y)"
    by (unfold int.less_def) auto
qed

thm int.circular
lemma "\<lbrakk> (x::int) \<le> y; y \<le> z; z \<le> x\<rbrakk> \<Longrightarrow> x = y \<and> y = z"
  apply (rule int.circular) apply assumption apply assumption apply assumption done
thm int.abs_test
lemma "((<) :: [int, int] => bool) = (<)"
  apply (rule int.abs_test) done

interpretation int: dlat "(<=) :: [int, int] => bool"
  rewrites meet_eq: "dlat.meet (<=) (x::int) y = min x y"
    and join_eq: "dlat.join (<=) (x::int) y = max x y"
proof -
  show "dlat ((<=) :: [int, int] => bool)"
    apply unfold_locales
    apply (unfold int.is_inf_def int.is_sup_def)
    apply arith+
    done
  then interpret int: dlat "(<=) :: [int, int] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (<=) (x::int) y = min x y"
    apply (unfold int.meet_def)
    apply (rule the_equality)
    apply (unfold int.is_inf_def)
    by auto
  show "dlat.join (<=) (x::int) y = max x y"
    apply (unfold int.join_def)
    apply (rule the_equality)
    apply (unfold int.is_sup_def)
    by auto
qed

interpretation int: dlo "(<=) :: [int, int] => bool"
  proof qed arith

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm int.less_def text \<open>from dpo\<close>
thm int.meet_left text \<open>from dlat\<close>
thm int.meet_distr text \<open>from ddlat\<close>
thm int.less_total text \<open>from dlo\<close>

subsubsection \<open>Total order \<open><=\<close> on \<^typ>\<open>nat\<close>\<close>

interpretation nat: dpo "(<=) :: [nat, nat] => bool"
  rewrites "dpo.less (<=) (x::nat) y = (x < y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo ((<=) :: [nat, nat] => bool)"
    proof qed auto
  then interpret nat: dpo "(<=) :: [nat, nat] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "dpo.less (<=) (x::nat) y = (x < y)"
    apply (unfold nat.less_def)
    apply auto
    done
qed

interpretation nat: dlat "(<=) :: [nat, nat] => bool"
  rewrites "dlat.meet (<=) (x::nat) y = min x y"
    and "dlat.join (<=) (x::nat) y = max x y"
proof -
  show "dlat ((<=) :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat.is_inf_def nat.is_sup_def)
    apply arith+
    done
  then interpret nat: dlat "(<=) :: [nat, nat] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (<=) (x::nat) y = min x y"
    apply (unfold nat.meet_def)
    apply (rule the_equality)
    apply (unfold nat.is_inf_def)
    by auto
  show "dlat.join (<=) (x::nat) y = max x y"
    apply (unfold nat.join_def)
    apply (rule the_equality)
    apply (unfold nat.is_sup_def)
    by auto
qed

interpretation nat: dlo "(<=) :: [nat, nat] => bool"
  proof qed arith

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm nat.less_def text \<open>from dpo\<close>
thm nat.meet_left text \<open>from dlat\<close>
thm nat.meet_distr text \<open>from ddlat\<close>
thm nat.less_total text \<open>from ldo\<close>

subsubsection \<open>Lattice \<open>dvd\<close> on \<^typ>\<open>nat\<close>\<close>

interpretation nat_dvd: dpo "(dvd) :: [nat, nat] => bool"
  rewrites "dpo.less (dvd) (x::nat) y = (x dvd y & x ~= y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo ((dvd) :: [nat, nat] => bool)"
    proof qed (auto simp: dvd_def)
  then interpret nat_dvd: dpo "(dvd) :: [nat, nat] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "dpo.less (dvd) (x::nat) y = (x dvd y & x ~= y)"
    apply (unfold nat_dvd.less_def)
    apply auto
    done
qed

interpretation nat_dvd: dlat "(dvd) :: [nat, nat] => bool"
  rewrites "dlat.meet (dvd) (x::nat) y = gcd x y"
    and "dlat.join (dvd) (x::nat) y = lcm x y"
proof -
  show "dlat ((dvd) :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat_dvd.is_inf_def nat_dvd.is_sup_def)
    apply (rule_tac x = "gcd x y" in exI)
    apply auto [1]
    apply (rule_tac x = "lcm x y" in exI)
    apply (auto intro: dvd_lcm1 dvd_lcm2 lcm_least)
    done
  then interpret nat_dvd: dlat "(dvd) :: [nat, nat] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (dvd) (x::nat) y = gcd x y"
    apply (unfold nat_dvd.meet_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_inf_def)
    by auto
  show "dlat.join (dvd) (x::nat) y = lcm x y"
    apply (unfold nat_dvd.join_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_sup_def)
    by (auto intro: dvd_lcm1 dvd_lcm2 lcm_least)
qed

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm nat_dvd.less_def text \<open>from dpo\<close>
lemma "((x::nat) dvd y & x ~= y) = (x dvd y & x ~= y)"
  apply (rule nat_dvd.less_def) done
thm nat_dvd.meet_left text \<open>from dlat\<close>
lemma "gcd x y dvd (x::nat)"
  apply (rule nat_dvd.meet_left) done

subsection \<open>Group example with defined operations \<open>inv\<close> and \<open>unit\<close>\<close>

subsubsection \<open>Locale declarations and lemmas\<close>

locale Dsemi =
  fixes prod (infixl "**" 65)
  assumes assoc: "(x ** y) ** z = x ** (y ** z)"

locale Dmonoid = Dsemi +
  fixes one
  assumes l_one [simp]: "one ** x = x"
    and r_one [simp]: "x ** one = x"

begin

definition
  inv where "inv x = (THE y. x ** y = one & y ** x = one)"
definition
  unit where "unit x = (\<exists>y. x ** y = one  & y ** x = one)"

lemma inv_unique:
  assumes eq: "y ** x = one" "x ** y' = one"
  shows "y = y'"
proof -
  from eq have "y = y ** (x ** y')" by (simp add: r_one)
  also have "... = (y ** x) ** y'" by (simp add: assoc)
  also from eq have "... = y'" by (simp add: l_one)
  finally show ?thesis .
qed

lemma unit_one [intro, simp]:
  "unit one"
  by (unfold unit_def) auto

lemma unit_l_inv_ex:
  "unit x ==> \<exists>y. y ** x = one"
  by (unfold unit_def) auto

lemma unit_r_inv_ex:
  "unit x ==> \<exists>y. x ** y = one"
  by (unfold unit_def) auto

lemma unit_l_inv:
  "unit x ==> inv x ** x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_r_inv:
  "unit x ==> x ** inv x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_inv_unit [intro, simp]:
  "unit x ==> unit (inv x)"
proof -
  assume x: "unit x"
  show "unit (inv x)"
    by (auto simp add: unit_def
      intro: unit_l_inv unit_r_inv x)
qed

lemma unit_l_cancel [simp]:
  "unit x ==> (x ** y = x ** z) = (y = z)"
proof
  assume eq: "x ** y = x ** z"
    and G: "unit x"
  then have "(inv x ** x) ** y = (inv x ** x) ** z"
    by (simp add: assoc)
  with G show "y = z" by (simp add: unit_l_inv)
next
  assume eq: "y = z"
    and G: "unit x"
  then show "x ** y = x ** z" by simp
qed

lemma unit_inv_inv [simp]:
  "unit x ==> inv (inv x) = x"
proof -
  assume x: "unit x"
  then have "inv x ** inv (inv x) = inv x ** x"
    by (simp add: unit_l_inv unit_r_inv)
  with x show ?thesis by simp
qed

lemma inv_inj_on_unit:
  "inj_on inv {x. unit x}"
proof (rule inj_onI, simp)
  fix x y
  assume G: "unit x"  "unit y" and eq: "inv x = inv y"
  then have "inv (inv x) = inv (inv y)" by simp
  with G show "x = y" by simp
qed

lemma unit_inv_comm:
  assumes inv: "x ** y = one"
    and G: "unit x"  "unit y"
  shows "y ** x = one"
proof -
  from G have "x ** y ** x = x ** one" by (auto simp add: inv)
  with G show ?thesis by (simp del: r_one add: assoc)
qed

end

locale Dgrp = Dmonoid +
  assumes unit [intro, simp]: "Dmonoid.unit ((**)) one x"

begin

lemma l_inv_ex [simp]:
  "\<exists>y. y ** x = one"
  using unit_l_inv_ex by simp

lemma r_inv_ex [simp]:
  "\<exists>y. x ** y = one"
  using unit_r_inv_ex by simp

lemma l_inv [simp]:
  "inv x ** x = one"
  using unit_l_inv by simp

lemma l_cancel [simp]:
  "(x ** y = x ** z) = (y = z)"
  using unit_l_inv by simp

lemma r_inv [simp]:
  "x ** inv x = one"
proof -
  have "inv x ** (x ** inv x) = inv x ** one"
    by (simp add: assoc [symmetric] l_inv)
  then show ?thesis by (simp del: r_one)
qed

lemma r_cancel [simp]:
  "(y ** x = z ** x) = (y = z)"
proof
  assume eq: "y ** x = z ** x"
  then have "y ** (x ** inv x) = z ** (x ** inv x)"
    by (simp add: assoc [symmetric] del: r_inv)
  then show "y = z" by simp
qed simp

lemma inv_one [simp]:
  "inv one = one"
proof -
  have "inv one = one ** (inv one)" by (simp del: r_inv)
  moreover have "... = one" by simp
  finally show ?thesis .
qed

lemma inv_inv [simp]:
  "inv (inv x) = x"
  using unit_inv_inv by simp

lemma inv_inj:
  "inj_on inv UNIV"
  using inv_inj_on_unit by simp

lemma inv_mult_group:
  "inv (x ** y) = inv y ** inv x"
proof -
  have "inv (x ** y) ** (x ** y) = (inv y ** inv x) ** (x ** y)"
    by (simp add: assoc l_inv) (simp add: assoc [symmetric])
  then show ?thesis by (simp del: l_inv)
qed

lemma inv_comm:
  "x ** y = one ==> y ** x = one"
  by (rule unit_inv_comm) auto

lemma inv_equality:
     "y ** x = one ==> inv x = y"
  apply (simp add: inv_def)
  apply (rule the_equality)
   apply (simp add: inv_comm [of y x])
  apply (rule r_cancel [THEN iffD1], auto)
  done

end

locale Dhom = prod: Dgrp prod one + sum: Dgrp sum zero
    for prod (infixl "**" 65) and one and sum (infixl "+++" 60) and zero +
  fixes hom
  assumes hom_mult [simp]: "hom (x ** y) = hom x +++ hom y"

begin

lemma hom_one [simp]:
  "hom one = zero"
proof -
  have "hom one +++ zero = hom one +++ hom one"
    by (simp add: hom_mult [symmetric] del: hom_mult)
  then show ?thesis by (simp del: sum.r_one)
qed

end

subsubsection \<open>Interpretation of Functions\<close>

interpretation Dfun: Dmonoid "(o)" "id :: 'a => 'a"
  rewrites "Dmonoid.unit (o) id f = bij (f::'a => 'a)"
(*    and "Dmonoid.inv (o) id" = "inv :: ('a => 'a) => ('a => 'a)" *)
proof -
  show "Dmonoid (o) (id :: 'a => 'a)" proof qed (simp_all add: o_assoc)
  note Dmonoid = this
(*
  from this interpret Dmonoid "(o)" "id :: 'a => 'a" .
*)
  show "Dmonoid.unit (o) (id :: 'a => 'a) f = bij f"
    apply (unfold Dmonoid.unit_def [OF Dmonoid])
    apply rule apply clarify
  proof -
    fix f g
    assume id1: "f o g = id" and id2: "g o f = id"
    show "bij f"
    proof (rule bijI)
      show "inj f"
      proof (rule inj_onI)
        fix x y
        assume "f x = f y"
        then have "(g o f) x = (g o f) y" by simp
        with id2 show "x = y" by simp
      qed
    next
      show "surj f"
      proof (rule surjI)
        fix x
        from id1 have "(f o g) x = x" by simp
        then show "f (g x) = x" by simp
      qed
    qed
  next
    fix f
    assume bij: "bij f"
    then
    have inv: "f o Hilbert_Choice.inv f = id & Hilbert_Choice.inv f o f = id"
      by (simp add: bij_def surj_iff inj_iff)
    show "\<exists>g. f \<circ> g = id \<and> g \<circ> f = id" by rule (rule inv)
  qed
qed

thm Dmonoid.unit_def Dfun.unit_def

thm Dmonoid.inv_inj_on_unit Dfun.inv_inj_on_unit

lemma unit_id:
  "(f :: unit => unit) = id"
  by rule simp

interpretation Dfun: Dgrp "(o)" "id :: unit => unit"
  rewrites "Dmonoid.inv (o) id f = inv (f :: unit => unit)"
proof -
  have "Dmonoid (o) (id :: 'a => 'a)" ..
  note Dmonoid = this

  show "Dgrp (o) (id :: unit => unit)"
apply unfold_locales
apply (unfold Dmonoid.unit_def [OF Dmonoid])
apply (insert unit_id)
apply simp
done
  show "Dmonoid.inv (o) id f = inv (f :: unit \<Rightarrow> unit)"
apply (unfold Dmonoid.inv_def [OF Dmonoid])
apply (insert unit_id)
apply simp
apply (rule the_equality)
apply rule
apply rule
apply simp
done
qed

thm Dfun.unit_l_inv Dfun.l_inv

thm Dfun.inv_equality
thm Dfun.inv_equality

end


theory Chap1_Proposition3
  imports Main Chap1_Properties
begin

declare[[smt_timeout=30]]
sledgehammer_params[isar_proof=false]
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3, atoms=a b c d] (*default Nitpick settings*)

section "commutative residuated PowerSet Lattice Definition"

subsection "declaration"

typedecl m
type_synonym p = "m \<Rightarrow> bool"
type_synonym p_op = "p \<Rightarrow> p \<Rightarrow> p"

consts p_meet :: p_op (infixr "\<^bold>\<inter>\<^sub>p" 55)
consts p_join :: p_op (infixr "\<^bold>\<union>\<^sub>p" 55)
consts p_mult :: p_op (infixr "\<^bold>\<star>\<^sub>p" 55)
consts p_impl :: p_op (infixr "\<^bold>\<Rrightarrow>\<^sub>p" 55)
consts p_zero :: "p" ("\<^bold>0\<^sub>p")
consts p_one :: "p" ("\<^bold>1\<^sub>p")
consts p_bot :: "p" ("\<^bold>\<bottom>\<^sub>p")
consts p_top :: "p" ("\<^bold>\<top>\<^sub>p")
consts p_ord :: "p \<Rightarrow> p \<Rightarrow> bool" (infixr"\<^bold>\<le>\<^sub>p"51)

subsection "axiomatisation"

axiomatization where

(* commutative monoid with the unit 1:
definition "commu Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "unitE Op One \<equiv> \<forall> a. Op a One = a"
definition "assoc Op \<equiv> \<forall> x y z. Op (Op x y) z = Op x (Op y z)"*)
p_commu_mult: "commu (\<^bold>\<star>\<^sub>p)" and
p_idemp_mult: "unitE (\<^bold>\<star>\<^sub>p) \<^bold>1\<^sub>p" and
p_assoc_mult: "assoc (\<^bold>\<star>\<^sub>p)" and

(* ordered monoid *)
p_ordered: "order (\<^bold>\<le>\<^sub>p) (\<^bold>\<star>\<^sub>p)" and

(*
p_refl_order: "reflex (\<^bold>\<le>\<^sub>p)" and
p_antisy_order: "antisy (\<^bold>\<le>\<^sub>p)" and
p_transi_order: "transi (\<^bold>\<le>\<^sub>p)" and
*)

(*  bounded lattice for Meet
definition "commu Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "assoc Op \<equiv> \<forall> x y z. Op (Op x y) z = Op x (Op y z)"
definition "idemp Op \<equiv> \<forall> a. Op a a = a"
definition "great Op Top \<equiv> extre Op Top" *)
p_commu_meet: "commu (\<^bold>\<inter>\<^sub>p)" and
p_assoc_meet: "assoc (\<^bold>\<inter>\<^sub>p)" and
p_idemp_meet: "idemp (\<^bold>\<inter>\<^sub>p)" and
p_great_meet: "great (\<^bold>\<inter>\<^sub>p) (\<^bold>\<top>\<^sub>p)" and

(*  bounded lattice for Join
definition "commu Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "assoc Op \<equiv> \<forall> x y z. Op (Op x y) z = Op x (Op y z)"
definition "idemp Op \<equiv> \<forall> a. Op a a = a"
definition "least Op Top \<equiv> extre Op Top"
*)
p_commu_join: "commu (\<^bold>\<union>\<^sub>p)" and
p_assoc_join: "assoc (\<^bold>\<union>\<^sub>p)" and
p_idemp_join: "idemp (\<^bold>\<union>\<^sub>p)" and
p_least_join: "least (\<^bold>\<union>\<^sub>p) (\<^bold>\<bottom>\<^sub>p)" and

(*  bounded lattice for Join and Meet
definition "absor Op1 Op2 \<equiv> \<forall> a b. Op1 a (Op2 a b) = a"*)
p_absorb_meetjoin: "absor (\<^bold>\<inter>\<^sub>p) (\<^bold>\<union>\<^sub>p)" and
p_absorb_joinmeet: "absor (\<^bold>\<union>\<^sub>p) (\<^bold>\<inter>\<^sub>p)" and

(*  residuated lattice
definition "resid Ord Mult Impl \<equiv>
\<forall> x y z. Ord (Mult x y) z = Ord x (Impl y z)"*)
p_resid_law: "resid (\<^bold>\<le>\<^sub>p) (\<^bold>\<star>\<^sub>p) (\<^bold>\<Rrightarrow>\<^sub>p)"

lemma "reflex (\<^bold>\<le>\<^sub>p)"
  unfolding reflex_def
  using p_ordered
  oops

lemma "antisy (\<^bold>\<le>\<^sub>p)"
  unfolding antisy_def
  using p_ordered
  oops

lemma "transi (\<^bold>\<le>\<^sub>p)"
  unfolding transi_def
  using p_ordered
  oops

(*
definition "reflex Rel \<equiv> \<forall> a. Rel a a"
definition "antisy Rel \<equiv> \<forall> a b. Rel a b \<and> Rel b a \<longrightarrow> a = b"
definition "transi Rel \<equiv> \<forall> a b c. Rel a b \<and> Rel b c \<longrightarrow> Rel a c"
*)

section "Closure Operator Axiomatisation"

type_synonym p_cl = "p \<Rightarrow> p"

consts ClOp :: p_cl

axiomatization where
cl_expan: "cl_expan ClOp (\<^bold>\<le>\<^sub>p)" and
cl_mono: "cl_mono ClOp (\<^bold>\<le>\<^sub>p)" and
cl_idem: "cl_idem ClOp (\<^bold>\<le>\<^sub>p)" and
cl_distr: "cl_distr ClOp (\<^bold>\<le>\<^sub>p) (\<^bold>\<star>\<^sub>p)"

section "residuated lattice as closure algebra"

subsection "Definitions"

type_synonym c_op = "p \<Rightarrow> p_cl \<Rightarrow> p \<Rightarrow> p"

definition c_meet :: c_op ("_ \<^bold>\<inter>[_] _" 55) where
"X \<^bold>\<inter>[Cl] Y \<equiv> Cl (\<lambda> m. (X \<^bold>\<inter>\<^sub>p Y) m)"
definition c_join :: c_op ("_ \<^bold>\<union>[_] _" 55) where
"X \<^bold>\<union>[Cl] Y \<equiv> Cl (\<lambda> m. (X \<^bold>\<union>\<^sub>p Y) m)"
definition c_mult :: c_op ("_ \<^bold>\<star>[_] _" 55)where
"X \<^bold>\<star>[Cl] Y \<equiv> Cl (\<lambda> m. (X \<^bold>\<star>\<^sub>p Y) m)"
definition c_impl :: c_op (" _ \<^bold>\<Rrightarrow>[_] _" 55) where
"X \<^bold>\<Rrightarrow>[Cl] Y \<equiv> Cl (\<lambda> m. (X \<^bold>\<Rrightarrow>\<^sub>p Y) m)"
(*consts c_zero :: "p" ("\<^bold>0\<^sub>c")*)
definition c_zero :: "p_cl \<Rightarrow> p" ("\<^bold>0[_]") where
"\<^bold>0[Cl] \<equiv> Cl (\<^bold>0\<^sub>p)"
definition c_one :: "p_cl \<Rightarrow> p" ("\<^bold>1[_]") where
"\<^bold>1[Cl] \<equiv> Cl (\<^bold>1\<^sub>p)"
definition c_bot :: "p_cl \<Rightarrow> p" ("\<^bold>\<bottom>[_]") where
"\<^bold>\<bottom>[Cl] \<equiv> Cl (\<^bold>\<bottom>\<^sub>p)"
definition c_top :: "p_cl \<Rightarrow> p" ("\<^bold>\<top>[_]") where
"\<^bold>\<top>[Cl] \<equiv> (\<^bold>\<top>\<^sub>p)"
definition c_ord :: "p \<Rightarrow> p \<Rightarrow> bool" (infixr "\<^bold>\<le>\<^sub>c" 50) where
"X \<^bold>\<le>\<^sub>c Y \<equiv> X \<^bold>\<le>\<^sub>p Y"

subsection "C-closedness of operations"

(* why not just putting it around*)
lemma c_closed_impl:
  assumes clA: "cClosed ClOp A"
  assumes clB: "cClosed ClOp B"
  shows "cClosed ClOp (A \<^bold>\<Rrightarrow>[ClOp] B)"
  apply (unfold c_impl_def cClosed_def) proof (rule)
  fix x
  show "ClOp (ClOp (A \<^bold>\<Rrightarrow>\<^sub>p B)) x = ClOp (A \<^bold>\<Rrightarrow>\<^sub>p B) x"
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
    by metis
qed

lemma c_closed_mult:
  assumes clA: "cClosed ClOp A"
  assumes clB: "cClosed ClOp B"
  shows "cClosed ClOp (A \<^bold>\<star>[ClOp] B)"
  apply (unfold c_mult_def cClosed_def) proof (rule)
  fix x
  show "ClOp (ClOp (A \<^bold>\<star>\<^sub>p B)) x = ClOp (A \<^bold>\<star>\<^sub>p B) x "
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
    by metis
qed

lemma c_closed_meet:
  assumes clA: "cClosed ClOp A"
  assumes clB: "cClosed ClOp B"
  shows "cClosed ClOp (A \<^bold>\<inter>[ClOp] B)"
  apply (unfold c_meet_def cClosed_def) proof (rule)
  fix x
  show "ClOp (ClOp (A \<^bold>\<inter>\<^sub>p B)) x = ClOp (A \<^bold>\<inter>\<^sub>p B) x"
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
    by metis
qed

lemma c_closed_join:
  assumes clA: "cClosed ClOp A"
  assumes clB: "cClosed ClOp B"
  shows "cClosed ClOp (A \<^bold>\<union>[ClOp] B)"
  apply (unfold c_join_def cClosed_def) proof (rule)
  fix x
  show "ClOp (ClOp (A \<^bold>\<union>\<^sub>p B)) x = ClOp (A \<^bold>\<union>\<^sub>p B) x"
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
    by metis
qed

lemma c_closed_zero:
  shows "cClosed ClOp (\<^bold>0[ClOp])"
  apply (unfold c_zero_def cClosed_def) proof (rule)
  fix x
  show "ClOp (ClOp \<^bold>0\<^sub>p) x = ClOp \<^bold>0\<^sub>p x"
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
    by metis
qed

lemma c_closed_one:
  shows "cClosed ClOp (\<^bold>1[ClOp])"
  apply (unfold c_one_def cClosed_def) proof (rule)
  fix x
  show "ClOp (ClOp \<^bold>1\<^sub>p) x = ClOp \<^bold>1\<^sub>p x"
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
    by metis
qed

lemma c_closed_bot:
  shows "cClosed ClOp (\<^bold>\<bottom>[ClOp])"
  apply (unfold c_bot_def cClosed_def) proof (rule)
  fix x
  show "ClOp (ClOp \<^bold>\<bottom>\<^sub>p) x = ClOp \<^bold>\<bottom>\<^sub>p x"
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
    by metis
qed

lemma c_closed_top:
  shows "cClosed ClOp (\<^bold>\<top>[ClOp])"
  apply (unfold c_top_def cClosed_def) proof (rule)
  fix x
  show "ClOp \<^bold>\<top>\<^sub>p x = \<^bold>\<top>\<^sub>p x"
    using cl_expan cl_idem  cl_expan_def cl_idem_def
          commu_def order_def p_commu_mult p_ordered
          p_refl_order p_antisy_order p_transi_order
    (* partial order axioms are missing *)
    sorry
  oops

subsection "Proofs for residuated lattice proofs"

subsubsection "commutative monoid with the unit 1"
(*
definition "commu Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "unitE Op One \<equiv> \<forall> a. Op a One = a"
definition "assoc Op \<equiv> \<forall> x y z. Op (Op x y) z = Op x (Op y z)"
*)

lemma c_commu_mult:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  shows "(a \<^bold>\<star>[ClOp] b) = (b \<^bold>\<star>[ClOp] a)"
  by (metis c_mult_def commu_def p_commu_mult)
lemma c_unitE_mult:
  assumes "cClosed ClOp a"
  shows "(a \<^bold>\<star>[ClOp] (\<^bold>1[ClOp])) = a"
  apply (unfold c_mult_def c_one_def) proof (rule)
  fix x
  show "ClOp (a \<^bold>\<star>\<^sub>p ClOp \<^bold>1\<^sub>p) x = a x"
    using p_refl_order p_antisy_order p_transi_order
    by (metis assms cClosed_def cl_expan cl_expan_def commu_def order_def p_commu_mult p_idemp_mult p_ordered unitE_def)
qed

lemma c_assoc_mult:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  assumes "cClosed ClOp c"
  shows "((a \<^bold>\<star>[ClOp] b) \<^bold>\<star>[ClOp] c) = (a \<^bold>\<star>[ClOp] (b \<^bold>\<star>[ClOp] c))"
  unfolding  c_mult_def  p_assoc_mult assms
  using assoc_def
  sledgehammer(assms(1) assms(2) assms(3))
  by (smt (z3) assms(1) assms(2) assms(3) c_closed_one c_mult_def c_unitE_mult cl_expan cl_expan_def cl_mono cl_mono_def commu_def order_def p_assoc_mult p_commu_mult p_ordered)
  oops
(*  by (smt (z3) assoc_def cl_distr cl_distr_def cl_expan cl_expan_def cl_idem cl_idem_def cl_mono cl_mono_def commu_def order_def p_commu_mult p_ordered)*)

subsubsection "bounded lattice for Meet"

lemma c_commu_meet:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  shows "(a \<^bold>\<inter>[ClOp] b) = (b \<^bold>\<inter>[ClOp] a)"
  by (metis c_meet_def commu_def p_commu_meet)

lemma c_assoc_meet:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  assumes "cClosed ClOp c"
  shows "((a \<^bold>\<inter>[ClOp] b) \<^bold>\<inter>[ClOp] c) = (a \<^bold>\<inter>[ClOp] (b \<^bold>\<inter>[ClOp] c))"
  unfolding c_meet_def
  using p_commu_meet c_closed_meet antisy_def assms
        c_meet_def c_mult_def c_unitE_mult cl_expan
        cl_expan_def cl_idem cl_idem_def idemp_def
        p_antisy_order p_idemp_meet
  nitpick

lemma c_idem_meet:
  assumes "cClosed ClOp a"
  shows "(a \<^bold>\<inter>[ClOp] a) = a"
  by (smt (verit) antisy_def assms c_meet_def c_mult_def c_unitE_mult cl_expan cl_expan_def cl_idem cl_idem_def idemp_def p_antisy_order p_idemp_meet)

lemma c_great_meet:
  assumes "cClosed ClOp a"
  shows "(a \<^bold>\<inter>[ClOp] \<^bold>\<top>[ClOp]) = a"
  apply (unfold c_meet_def)
    using p_commu_meet c_closed_meet antisy_def assms
        c_meet_def c_mult_def c_unitE_mult cl_expan
        cl_expan_def cl_idem cl_idem_def idemp_def
        p_antisy_order p_idemp_meet
    by (smt (verit) c_top_def extre_def great_def p_great_meet)

subsubsection "bounded lattice for Join"

lemma c_commu_join:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  shows "(a \<^bold>\<union>[ClOp] b) = (b \<^bold>\<union>[ClOp] a)"
  by (metis c_join_def commu_def p_commu_join)

lemma c_assoc_meet:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  assumes "cClosed ClOp c"
  shows "((a \<^bold>\<union>[ClOp] b) \<^bold>\<union>[ClOp] c) = (a \<^bold>\<union>[ClOp] (b \<^bold>\<union>[ClOp] c))"
  apply (unfold c_join_def)
  using p_commu_join c_closed_join antisy_def assms
        c_join_def c_mult_def c_unitE_mult cl_expan
        cl_expan_def cl_idem cl_idem_def idemp_def
        p_antisy_order p_idemp_join
  oops

lemma c_idem_join:
  assumes "cClosed ClOp a"
  shows "(a \<^bold>\<union>[ClOp] a) = a"
  by (smt (verit) antisy_def assms c_join_def c_mult_def c_unitE_mult cl_expan cl_expan_def cl_idem cl_idem_def idemp_def p_antisy_order p_idemp_join)

lemma c_least_join:
  assumes "cClosed ClOp a"
  shows "(a \<^bold>\<union>[ClOp] \<^bold>\<bottom>[ClOp]) = a"
  apply (unfold c_join_def c_bot_def)
    using p_commu_join c_closed_join antisy_def assms
        c_join_def c_mult_def c_unitE_mult cl_expan
        cl_expan_def cl_idem cl_idem_def idemp_def
        p_antisy_order p_idemp_join assms
    oops

subsubsection "bounded lattice for Join and Meet"

lemma c_absorb_meetjoin:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  shows "(a \<^bold>\<inter>[ClOp] (a \<^bold>\<union>[ClOp] b)) = a"
  apply (unfold c_meet_def c_join_def)
  oops

lemma c_absorb_joinmeet:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  shows "(a \<^bold>\<union>[ClOp] (a \<^bold>\<inter>[ClOp] b)) = a"
  apply (unfold c_meet_def c_join_def)
  oops

  subsubsection "residuated lattice"

(* definition "resid Ord Mult Impl \<equiv>
\<forall> x y z. Ord (Mult x y) z = Ord x (Impl y z)" *)

lemma c_assoc_meet:
  assumes "cClosed ClOp a"
  assumes "cClosed ClOp b"
  assumes "cClosed ClOp c"
  shows "((x \<^bold>\<star>[ClOp] y) \<^bold>\<le>\<^sub>c z) = (x \<^bold>\<le>\<^sub>c (y \<^bold>\<Rrightarrow>[ClOp] z))"
  apply (unfold c_mult_def c_ord_def c_impl_def)
  oops

end


(*  Title:      HOL/Algebra/Sym_Groups.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Sym_Groups
  imports
    "HOL-Combinatorics.Cycles"
    Solvable_Groups
begin

section \<open>Symmetric Groups\<close>

subsection \<open>Definitions\<close>

abbreviation inv' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
  where "inv' f \<equiv> Hilbert_Choice.inv f"

definition sym_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
  where "sym_group n = \<lparr> carrier = { p. p permutes {1..n} }, mult = (\<circ>), one = id \<rparr>"

definition alt_group :: "nat \<Rightarrow> (nat \<Rightarrow> nat) monoid"
  where "alt_group n = (sym_group n) \<lparr> carrier := { p. p permutes {1..n} \<and> evenperm p } \<rparr>"

definition sign_img :: "int monoid"
  where "sign_img = \<lparr> carrier = { -1, 1 }, mult = (*), one = 1 \<rparr>"

subsection \<open>Basic Properties\<close>

lemma sym_group_carrier: "p \<in> carrier (sym_group n) \<longleftrightarrow> p permutes {1..n}"
  unfolding sym_group_def by simp

lemma sym_group_mult: "mult (sym_group n) = (\<circ>)"
  unfolding sym_group_def by simp

lemma sym_group_one: "one (sym_group n) = id"
  unfolding sym_group_def by simp

lemma sym_group_carrier': "p \<in> carrier (sym_group n) \<Longrightarrow> permutation p"
  unfolding sym_group_carrier permutation_permutes by auto

lemma alt_group_carrier: "p \<in> carrier (alt_group n) \<longleftrightarrow> p permutes {1..n} \<and> evenperm p"
  unfolding alt_group_def by auto

lemma alt_group_mult: "mult (alt_group n) = (\<circ>)"
  unfolding alt_group_def using sym_group_mult by simp

lemma alt_group_one: "one (alt_group n) = id"
  unfolding alt_group_def using sym_group_one by simp

lemma alt_group_carrier': "p \<in> carrier (alt_group n) \<Longrightarrow> permutation p"
  unfolding alt_group_carrier permutation_permutes by auto

lemma sym_group_is_group: "group (sym_group n)"
  using permutes_inv permutes_inv_o(2)
  by (auto intro!: groupI
         simp add: sym_group_def permutes_compose
                   permutes_id comp_assoc, blast)

lemma sign_img_is_group: "group sign_img"
  unfolding sign_img_def by (unfold_locales, auto simp add: Units_def)

lemma sym_group_inv_closed:
  assumes "p \<in> carrier (sym_group n)" shows "inv' p \<in> carrier (sym_group n)"
  using assms permutes_inv sym_group_def by auto

lemma alt_group_inv_closed:
  assumes "p \<in> carrier (alt_group n)" shows "inv' p \<in> carrier (alt_group n)"
  using evenperm_inv[OF alt_group_carrier'] permutes_inv assms alt_group_carrier by auto

lemma sym_group_inv_equality [simp]:
  assumes "p \<in> carrier (sym_group n)" shows "inv\<^bsub>(sym_group n)\<^esub> p = inv' p"
proof -
  have "inv' p \<circ> p = id"
    using assms permutes_inv_o(2) sym_group_def by auto
  hence "(inv' p) \<otimes>\<^bsub>(sym_group n)\<^esub> p = one (sym_group n)"
    by (simp add: sym_group_def)
  thus ?thesis  using group.inv_equality[OF sym_group_is_group]
    by (simp add: assms sym_group_inv_closed)
qed

lemma sign_is_hom: "sign \<in> hom (sym_group n) sign_img"
  unfolding hom_def sign_img_def sym_group_mult using sym_group_carrier'[of _ n]
  by (auto simp add: sign_compose, meson sign_def)

lemma sign_group_hom: "group_hom (sym_group n) sign_img sign"
  using group_hom.intro[OF sym_group_is_group sign_img_is_group] sign_is_hom
  by (simp add: group_hom_axioms_def)

lemma sign_is_surj:
  assumes "n \<ge> 2" shows "sign ` (carrier (sym_group n)) = carrier sign_img"
proof -
  have "swapidseq (Suc 0) (Fun.swap (1 :: nat) 2 id)"
    using comp_Suc[OF id, of "1 :: nat" "2"] by auto
  hence "sign (Fun.swap (1 :: nat) 2 id) = (-1 :: int)"
    by (simp add: sign_swap_id)
  moreover have "Fun.swap (1 :: nat) 2 id \<in> carrier (sym_group n)" and "id \<in> carrier (sym_group n)"
    using assms permutes_swap_id[of "1 :: nat" "{1..n}" 2] permutes_id
    unfolding sym_group_carrier by auto
  ultimately have "carrier sign_img \<subseteq> sign ` (carrier (sym_group n))"
    using sign_id mk_disjoint_insert unfolding sign_img_def by fastforce
  moreover have "sign ` (carrier (sym_group n)) \<subseteq> carrier sign_img"
    using sign_is_hom unfolding hom_def by auto
  ultimately show ?thesis
    by blast
qed

lemma alt_group_is_sign_kernel:
  "carrier (alt_group n) = kernel (sym_group n) sign_img sign"
  unfolding alt_group_def sym_group_def sign_img_def kernel_def sign_def by auto

lemma alt_group_is_subgroup: "subgroup (carrier (alt_group n)) (sym_group n)"
  using group_hom.subgroup_kernel[OF sign_group_hom]
  unfolding alt_group_is_sign_kernel by blast

lemma alt_group_is_group: "group (alt_group n)"
  using group.subgroup_imp_group[OF sym_group_is_group alt_group_is_subgroup]
  by (simp add: alt_group_def)

lemma sign_iso:
  assumes "n \<ge> 2" shows "(sym_group n) Mod (carrier (alt_group n)) \<cong> sign_img"
  using group_hom.FactGroup_iso[OF sign_group_hom sign_is_surj[OF assms]]
  unfolding alt_group_is_sign_kernel .

lemma alt_group_inv_equality:
  assumes "p \<in> carrier (alt_group n)" shows "inv\<^bsub>(alt_group n)\<^esub> p = inv' p"
proof -
  have "inv' p \<circ> p = id"
    using assms permutes_inv_o(2) alt_group_def by auto
  hence "(inv' p) \<otimes>\<^bsub>(alt_group n)\<^esub> p = one (alt_group n)"
    by (simp add: alt_group_def sym_group_def)
  thus ?thesis  using group.inv_equality[OF alt_group_is_group]
    by (simp add: assms alt_group_inv_closed)
qed

lemma sym_group_card_carrier: "card (carrier (sym_group n)) = fact n"
  using card_permutations[of "{1..n}" n] unfolding sym_group_def by simp

lemma alt_group_card_carrier:
  assumes "n \<ge> 2" shows "2 * card (carrier (alt_group n)) = fact n"
proof -
  have "card (rcosets\<^bsub>sym_group n\<^esub> (carrier (alt_group n))) = 2"
    using iso_same_card[OF sign_iso[OF assms]] unfolding FactGroup_def sign_img_def by auto
  thus ?thesis
    using group.lagrange[OF sym_group_is_group alt_group_is_subgroup, of n]
    unfolding order_def sym_group_card_carrier by simp
qed

subsection \<open>Transposition Sequences\<close>

text \<open>In order to prove that the Alternating Group can be generated by 3-cycles, we need
      a stronger decomposition of permutations as transposition sequences than the one
      proposed at Permutations.thy. \<close>

inductive swapidseq_ext :: "'a set \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where
    empty:  "swapidseq_ext {} 0 id"
  | single: "\<lbrakk> swapidseq_ext S n p; a \<notin> S \<rbrakk> \<Longrightarrow> swapidseq_ext (insert a S) n p"
  | comp:   "\<lbrakk> swapidseq_ext S n p; a \<noteq> b \<rbrakk> \<Longrightarrow>
               swapidseq_ext (insert a (insert b S)) (Suc n) ((transpose a b) \<circ> p)"

lemma swapidseq_ext_finite:
  assumes "swapidseq_ext S n p" shows "finite S"
  using assms by (induction) (auto)

lemma swapidseq_ext_zero:
  assumes "finite S" shows "swapidseq_ext S 0 id"
  using assms empty by (induct set: "finite", fastforce, simp add: single)

lemma swapidseq_ext_imp_swapidseq:
  \<open>swapidseq n p\<close> if \<open>swapidseq_ext S n p\<close>
using that proof induction
  case empty
  then show ?case
    by (simp add: fun_eq_iff)
next
  case (single S n p a)
  then show ?case by simp
next
  case (comp S n p a b)
  then have \<open>swapidseq (Suc n) (transpose a b \<circ> p)\<close>
    by (simp add: comp_Suc)
  then show ?case by (simp add: comp_def)
qed

lemma swapidseq_ext_zero_imp_id:
  assumes "swapidseq_ext S 0 p" shows "p = id"
proof -
  have "\<lbrakk> swapidseq_ext S n p; n = 0 \<rbrakk> \<Longrightarrow> p = id" for n
    by (induction rule: swapidseq_ext.induct, auto)
  thus ?thesis
    using assms by simp
qed

lemma swapidseq_ext_finite_expansion:
  assumes "finite B" and "swapidseq_ext A n p" shows "swapidseq_ext (A \<union> B) n p"
  using assms
proof (induct set: "finite", simp)
  case (insert b B) show ?case
    using insert single[OF insert(3), of b] by (metis Un_insert_right insert_absorb)
qed

lemma swapidseq_ext_backwards:
  assumes "swapidseq_ext A (Suc n) p"
  shows "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                     swapidseq_ext A' n p' \<and> p = (transpose a b) \<circ> p'"
proof -
  { fix A n k and p :: "'a \<Rightarrow> 'a"
    assume "swapidseq_ext A n p" "n = Suc k"
    hence "\<exists>a b A' p'. a \<noteq> b \<and> A = (insert a (insert b A')) \<and>
                       swapidseq_ext A' k p' \<and> p = (transpose a b) \<circ> p'"
    proof (induction, simp)
      case single thus ?case
        by (metis Un_insert_right insert_iff insert_is_Un swapidseq_ext.single)
    next
      case comp thus ?case
        by blast
    qed }
  thus ?thesis
    using assms by simp
qed

lemma swapidseq_ext_backwards':
  assumes "swapidseq_ext A (Suc n) p"
  shows "\<exists>a b A' p'. a \<in> A \<and> b \<in> A \<and> a \<noteq> b \<and> swapidseq_ext A n p' \<and> p = (transpose a b) \<circ> p'"
  using swapidseq_ext_backwards[OF assms] swapidseq_ext_finite_expansion
  by (metis Un_insert_left assms insertI1 sup.idem sup_commute swapidseq_ext_finite)

lemma swapidseq_ext_endswap:
  assumes "swapidseq_ext S n p" "a \<noteq> b"
  shows "swapidseq_ext (insert a (insert b S)) (Suc n) (p \<circ> (transpose a b))"
  using assms
proof (induction n arbitrary: S p a b)
  case 0 hence "p = id"
    using swapidseq_ext_zero_imp_id by blast
  thus ?case
    using 0 by (metis comp_id id_comp swapidseq_ext.comp)
next
  case (Suc n)
  then obtain c d S' and p' :: "'a \<Rightarrow> 'a"
    where cd: "c \<noteq> d" and S: "S = (insert c (insert d S'))" "swapidseq_ext S' n p'"
      and p: "p = transpose c d \<circ> p'"
    using swapidseq_ext_backwards[OF Suc(2)] by blast
  hence "swapidseq_ext (insert a (insert b S')) (Suc n) (p' \<circ> (transpose a b))"
    by (simp add: Suc.IH Suc.prems(2))
  hence "swapidseq_ext (insert c (insert d (insert a (insert b S')))) (Suc (Suc n))
                 (transpose c d \<circ> p' \<circ> (transpose a b))"
    by (metis cd fun.map_comp swapidseq_ext.comp)
  thus ?case
    by (metis S(1) p insert_commute)
qed

lemma swapidseq_ext_extension:
  assumes "swapidseq_ext A n p" and "swapidseq_ext B m q" and "A \<inter> B = {}"
  shows "swapidseq_ext (A \<union> B) (n + m) (p \<circ> q)"
  using assms(1,3)
proof (induction, simp add: assms(2))
  case single show ?case
    using swapidseq_ext.single[OF single(3)] single(2,4) by auto
next
  case comp show ?case
    using swapidseq_ext.comp[OF comp(3,2)] comp(4)
    by (metis Un_insert_left add_Suc insert_disjoint(1) o_assoc)
qed

lemma swapidseq_ext_of_cycles:
  assumes "cycle cs" shows "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)"
  using assms
proof (induct cs rule: cycle_of_list.induct)
  case (1 i j cs) show ?case
    using comp[OF 1(1), of i j] 1(2) by (simp add: o_def)
next
  case "2_1" show ?case
    by (simp, metis eq_id_iff empty)
next
  case ("2_2" v) show ?case
    using single[OF empty, of v] by (simp, metis eq_id_iff)
qed

lemma cycle_decomp_imp_swapidseq_ext:
  assumes "cycle_decomp S p" shows "\<exists>n. swapidseq_ext S n p"
  using assms
proof (induction)
  case empty show ?case
    using swapidseq_ext.empty by blast
next
  case (comp I p cs)
  then obtain m where m: "swapidseq_ext I m p" by blast
  hence "swapidseq_ext (set cs) (length cs - 1) (cycle_of_list cs)"
    using comp.hyps(2) swapidseq_ext_of_cycles by blast
  thus ?case using swapidseq_ext_extension m
    using comp.hyps(3) by blast
qed

lemma swapidseq_ext_of_permutation:
  assumes "p permutes S" and "finite S" shows "\<exists>n. swapidseq_ext S n p"
  using cycle_decomp_imp_swapidseq_ext[OF cycle_decomposition[OF assms]] .

lemma split_swapidseq_ext:
  assumes "k \<le> n" and "swapidseq_ext S n p"
  obtains q r U V where "swapidseq_ext U (n - k) q" and "swapidseq_ext V k r" and "p = q \<circ> r" and "U \<union> V = S"
proof -
  from assms
  have "\<exists>q r U V. swapidseq_ext U (n - k) q \<and> swapidseq_ext V k r \<and> p = q \<circ> r \<and> U \<union> V = S"
   (is "\<exists>q r U V. ?split k q r U V")
  proof (induct k rule: inc_induct)
    case base thus ?case
      by (metis diff_self_eq_0 id_o sup_bot.left_neutral empty)
  next
    case (step m)
    then obtain q r U V
      where q: "swapidseq_ext U (n - Suc m) q" and r: "swapidseq_ext V (Suc m) r"
        and p: "p = q \<circ> r" and S: "U \<union> V = S"
      by blast
    obtain a b r' V'
      where "a \<noteq> b" and r': "V = (insert a (insert b V'))" "swapidseq_ext V' m r'" "r = (transpose a b) \<circ> r'"
      using swapidseq_ext_backwards[OF r] by blast
    have "swapidseq_ext (insert a (insert b U)) (n - m) (q \<circ> (transpose a b))"
      using swapidseq_ext_endswap[OF q \<open>a \<noteq> b\<close>] step(2) by (metis Suc_diff_Suc)
    hence "?split m (q \<circ> (transpose a b)) r' (insert a (insert b U)) V'"
      using r' S unfolding p by fastforce
    thus ?case by blast
  qed
  thus ?thesis
    using that by blast
qed

subsection \<open>Unsolvability of Symmetric Groups\<close>

text \<open>We show that symmetric groups (\<^term>\<open>sym_group n\<close>) are unsolvable for \<^term>\<open>n \<ge> 5\<close>.\<close>

abbreviation three_cycles :: "nat \<Rightarrow> (nat \<Rightarrow> nat) set"
  where "three_cycles n \<equiv>
           { cycle_of_list cs | cs. cycle cs \<and> length cs = 3 \<and> set cs \<subseteq> {1..n} }"

lemma stupid_lemma:
  assumes "length cs = 3" shows "cs = [ (cs ! 0), (cs ! 1), (cs ! 2) ]"
  using assms by (auto intro!: nth_equalityI)
    (metis Suc_lessI less_2_cases not_less_eq nth_Cons_0
           nth_Cons_Suc numeral_2_eq_2 numeral_3_eq_3)

lemma three_cycles_incl: "three_cycles n \<subseteq> carrier (alt_group n)"
proof
  fix p assume "p \<in> three_cycles n"
  then obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
    by auto
  obtain a b c where cs_def: "cs = [ a, b, c ]"
    using stupid_lemma[OF cs(3)] by auto
  have "swapidseq (Suc (Suc 0)) ((transpose a b) \<circ> (Fun.swap b c id))"
    using comp_Suc[OF comp_Suc[OF id], of b c a b] cs(2) unfolding cs_def by simp
  hence "evenperm p"
    using cs(1) unfolding cs_def by (simp add: evenperm_unique)
  thus "p \<in> carrier (alt_group n)"
    using permutes_subset[OF cycle_permutes cs(4)]
    unfolding alt_group_carrier cs(1) by simp
qed

lemma alt_group_carrier_as_three_cycles:
  "carrier (alt_group n) = generate (alt_group n) (three_cycles n)"
proof -
  interpret A: group "alt_group n"
    using alt_group_is_group by simp

  show ?thesis
  proof
    show "generate (alt_group n) (three_cycles n) \<subseteq> carrier (alt_group n)"
      using A.generate_subgroup_incl[OF three_cycles_incl A.subgroup_self] .
  next
    show "carrier (alt_group n) \<subseteq> generate (alt_group n) (three_cycles n)"
    proof
      { fix q :: "nat \<Rightarrow> nat" and a b c
        assume "a \<noteq> b" "b \<noteq> c" "{ a, b, c } \<subseteq> {1..n}"
        have "cycle_of_list [a, b, c] \<in> generate (alt_group n) (three_cycles n)"
        proof (cases)
          assume "c = a"
          hence "cycle_of_list [ a, b, c ] = id"
            by (simp add: swap_commute)
          thus "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
            using one[of "alt_group n"] unfolding alt_group_one by simp
        next
          assume "c \<noteq> a"
          have "distinct [a, b, c]"
            using \<open>a \<noteq> b\<close> and \<open>b \<noteq> c\<close> and \<open>c \<noteq> a\<close> by auto
          with \<open>{ a, b, c } \<subseteq> {1..n}\<close>
          show "cycle_of_list [ a, b, c ] \<in> generate (alt_group n) (three_cycles n)"
            by (intro incl, fastforce)
        qed } note aux_lemma1 = this

      { fix S :: "nat set" and q :: "nat \<Rightarrow> nat"
        assume seq: "swapidseq_ext S (Suc (Suc 0)) q" and S: "S \<subseteq> {1..n}"
        have "q \<in> generate (alt_group n) (three_cycles n)"
        proof -
          obtain a b q' where ab: "a \<noteq> b" "a \<in> S" "b \<in> S"
            and q': "swapidseq_ext S (Suc 0) q'" "q = (transpose a b) \<circ> q'"
            using swapidseq_ext_backwards'[OF seq] by auto
          obtain c d where cd: "c \<noteq> d" "c \<in> S" "d \<in> S"
            and q: "q = (transpose a b) \<circ> (Fun.swap c d id)"
            using swapidseq_ext_backwards'[OF q'(1)]
                  swapidseq_ext_zero_imp_id
            unfolding q'(2)
            by fastforce

          consider (eq) "b = c" | (ineq) "b \<noteq> c" by auto
          thus ?thesis
          proof cases
            case eq then have "q = cycle_of_list [ a, b, d ]"
              unfolding q by simp
            moreover have "{ a, b, d } \<subseteq> {1..n}"
              using ab cd S by blast
            ultimately show ?thesis
              using aux_lemma1[OF ab(1)] cd(1) eq by simp
          next
            case ineq
            hence "q = cycle_of_list [ a, b, c ] \<circ> cycle_of_list [ b, c, d ]"
              unfolding q by (simp add: swap_nilpotent o_assoc)
            moreover have "{ a, b, c } \<subseteq> {1..n}" and "{ b, c, d } \<subseteq> {1..n}"
              using ab cd S by blast+
            ultimately show ?thesis
              using eng[OF aux_lemma1[OF ab(1) ineq] aux_lemma1[OF ineq cd(1)]]
              unfolding alt_group_mult by simp
          qed
        qed } note aux_lemma2 = this

      fix p assume "p \<in> carrier (alt_group n)" then have p: "p permutes {1..n}" "evenperm p"
        unfolding alt_group_carrier by auto
      obtain m where m: "swapidseq_ext {1..n} m p"
        using swapidseq_ext_of_permutation[OF p(1)] by auto
      have "even m"
        using swapidseq_ext_imp_swapidseq[OF m] p(2) evenperm_unique by blast
      then obtain k where k: "m = 2 * k"
        by auto
      show "p \<in> generate (alt_group n) (three_cycles n)"
        using m unfolding k
      proof (induct k arbitrary: p)
        case 0 then have "p = id"
          using swapidseq_ext_zero_imp_id by simp
        show ?case
          using generate.one[of "alt_group n" "three_cycles n"]
          unfolding alt_group_one \<open>p = id\<close> .
      next
        case (Suc m)
        have arith: "2 * (Suc m) - (Suc (Suc 0)) = 2 * m" and "Suc (Suc 0) \<le> 2 * Suc m"
          by auto
        then obtain q r U V
          where q: "swapidseq_ext U (2 * m) q" and r: "swapidseq_ext V (Suc (Suc 0)) r"
            and p: "p = q \<circ> r" and UV: "U \<union> V = {1..n}"
          using split_swapidseq_ext[OF _ Suc(2), of "Suc (Suc 0)"] unfolding arith by metis
        have "swapidseq_ext {1..n} (2 * m) q"
          using UV q swapidseq_ext_finite_expansion[OF swapidseq_ext_finite[OF r] q] by simp
        thus ?case
          using eng[OF Suc(1) aux_lemma2[OF r], of q] UV unfolding alt_group_mult p by blast
      qed
    qed
  qed
qed

theorem derived_alt_group_const:
  assumes "n \<ge> 5" shows "derived (alt_group n) (carrier (alt_group n)) = carrier (alt_group n)"
proof
  show "derived (alt_group n) (carrier (alt_group n)) \<subseteq> carrier (alt_group n)"
    using group.derived_in_carrier[OF alt_group_is_group] by simp
next
  { fix p assume "p \<in> three_cycles n" have "p \<in> derived (alt_group n) (carrier (alt_group n))"
    proof -
      obtain cs where cs: "p = cycle_of_list cs" "cycle cs" "length cs = 3" "set cs \<subseteq> {1..n}"
        using \<open>p \<in> three_cycles n\<close> by auto
      then obtain a b c where cs_def: "cs = [ a, b, c ]"
        using stupid_lemma[OF cs(3)] by blast
      have "card (set cs) = 3"
        using cs(2-3)
        by (simp add: distinct_card)

      have "set cs \<noteq> {1..n}"
        using assms cs(3) unfolding sym[OF distinct_card[OF cs(2)]] by auto
      then obtain d where d: "d \<notin> set cs" "d \<in> {1..n}"
        using cs(4) by blast

      hence "cycle (d # cs)" and "length (d # cs) = 4" and "card {1..n} = n"
        using cs(2-3) by auto
      hence "set (d # cs) \<noteq> {1..n}"
        using assms unfolding sym[OF distinct_card[OF \<open>cycle (d # cs)\<close>]]
        by (metis Suc_n_not_le_n eval_nat_numeral(3))
      then obtain e where e: "e \<notin> set (d # cs)" "e \<in> {1..n}"
        using d cs(4) by (metis insert_subset list.simps(15) subsetI subset_antisym)

      define q where "q = (Fun.swap d e id) \<circ> (Fun.swap b c id)"
      hence "bij q"
        by (simp add: bij_comp)
      moreover have "q b = c" and "q c = b"
        using d(1) e(1) unfolding q_def cs_def by simp+
      moreover have "q a = a"
        using d(1) e(1) cs(2) unfolding q_def cs_def by auto
      ultimately have "q \<circ> p \<circ> (inv' q) = cycle_of_list [ a, c, b ]"
        using conjugation_of_cycle[OF cs(2), of q]
        unfolding sym[OF cs(1)] unfolding cs_def by simp
      also have " ... = p \<circ> p"
        using cs(2) unfolding cs(1) cs_def
        by (simp add: comp_swap swap_commute transpose_comp_triple)
      finally have "q \<circ> p \<circ> (inv' q) = p \<circ> p" .
      moreover have "bij p"
        unfolding cs(1) cs_def by (simp add: bij_comp)
      ultimately have p: "q \<circ> p \<circ> (inv' q) \<circ> (inv' p) = p"
        by (simp add: bijection.intro bijection.inv_comp_right comp_assoc)

      have "swapidseq (Suc (Suc 0)) q"
        using comp_Suc[OF comp_Suc[OF id], of b c d e] e(1) cs(2)  unfolding q_def cs_def by auto
      hence "evenperm q"
        using even_Suc_Suc_iff evenperm_unique by blast
      moreover have "q permutes { d, e, b, c }"
        unfolding q_def by (simp add: permutes_compose permutes_swap_id)
      hence "q permutes {1..n}"
        using cs(4) d(2) e(2) permutes_subset unfolding cs_def by fastforce
      ultimately have "q \<in> carrier (alt_group n)"
        unfolding alt_group_carrier by simp
      moreover have "p \<in> carrier (alt_group n)"
        using \<open>p \<in> three_cycles n\<close> three_cycles_incl by blast
      ultimately have "p \<in> derived_set (alt_group n) (carrier (alt_group n))"
        using p alt_group_inv_equality unfolding alt_group_mult
        by (metis (no_types, lifting) UN_iff singletonI)
      thus "p \<in> derived (alt_group n) (carrier (alt_group n))"
        unfolding derived_def by (rule incl)
    qed } note aux_lemma = this

  interpret A: group "alt_group n"
    using alt_group_is_group .

  have "generate (alt_group n) (three_cycles n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
    using A.generate_subgroup_incl[OF _ A.derived_is_subgroup] aux_lemma by (meson subsetI)
  thus "carrier (alt_group n) \<subseteq> derived (alt_group n) (carrier (alt_group n))"
    using alt_group_carrier_as_three_cycles by simp
qed

corollary alt_group_is_unsolvable:
  assumes "n \<ge> 5" shows "\<not> solvable (alt_group n)"
proof (rule ccontr)
  assume "\<not> \<not> solvable (alt_group n)"
  then obtain m where "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = { id }"
    using group.solvable_iff_trivial_derived_seq[OF alt_group_is_group] unfolding alt_group_one by blast
  moreover have "(derived (alt_group n) ^^ m) (carrier (alt_group n)) = carrier (alt_group n)"
    using derived_alt_group_const[OF assms] by (induct m) (auto)
  ultimately have card_eq_1: "card (carrier (alt_group n)) = 1"
    by simp
  have ge_2: "n \<ge> 2"
    using assms by simp
  moreover have "2 = fact n"
    using alt_group_card_carrier[OF ge_2] unfolding card_eq_1
    by (metis fact_2 mult.right_neutral of_nat_fact)
  ultimately have "n = 2"
      by (metis antisym_conv fact_ge_self)
  thus False
    using assms by simp
qed

corollary sym_group_is_unsolvable:
  assumes "n \<ge> 5" shows "\<not> solvable (sym_group n)"
proof -
  interpret Id: group_hom "alt_group n" "sym_group n" id
    using group.canonical_inj_is_hom[OF sym_group_is_group alt_group_is_subgroup] alt_group_def by simp
  show ?thesis
    using Id.inj_hom_imp_solvable alt_group_is_unsolvable[OF assms] by auto
qed

end


(*  Title:       General Algorithms for Iterators
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section \<open>General Algorithms for Iterators over Finite Sets\<close>
theory SetIteratorGA
imports Main SetIteratorOperations
begin

subsection \<open>Quantification\<close>

definition iterate_ball where
    "iterate_ball (it::('x,bool) set_iterator) P = it id (\<lambda>x \<sigma>. P x) True"

lemma iterate_ball_correct :
assumes it: "set_iterator it S0"
shows "iterate_ball it P = (\<forall>x\<in>S0. P x)"
unfolding iterate_ball_def
apply (rule set_iterator_rule_P [OF it,
            where I = "\<lambda>S \<sigma>. \<sigma> = (\<forall>x\<in>S0-S. P x)"])
apply auto
done

definition iterate_bex where
    "iterate_bex (it::('x,bool) set_iterator) P = it (\<lambda>\<sigma>. \<not>\<sigma>) (\<lambda>x \<sigma>. P x) False"

lemma iterate_bex_correct :
assumes it: "set_iterator it S0"
shows "iterate_bex it P = (\<exists>x\<in>S0. P x)"
unfolding iterate_bex_def
apply (rule set_iterator_rule_P [OF it, where I = "\<lambda>S \<sigma>. \<sigma> = (\<exists>x\<in>S0-S. P x)"])
apply auto
done

subsection \<open>Iterator to List\<close>

definition iterate_to_list where
    "iterate_to_list (it::('x,'x list) set_iterator) = it (\<lambda>_. True) (\<lambda>x \<sigma>. x # \<sigma>) []"

lemma iterate_to_list_foldli [simp] :
  "iterate_to_list (foldli xs) = rev xs"
unfolding iterate_to_list_def
by (induct xs rule: rev_induct, simp_all add: foldli_snoc)

lemma iterate_to_list_genord_correct :
assumes it: "set_iterator_genord it S0 R"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted_wrt R (rev (iterate_to_list it))"
using it unfolding set_iterator_genord_foldli_conv by auto

lemma iterate_to_list_correct :
assumes it: "set_iterator it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it)"
using iterate_to_list_genord_correct [OF it[unfolded set_iterator_def]]
by simp

lemma (in linorder) iterate_to_list_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_linord it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted (rev (iterate_to_list it))"
using it_OK unfolding set_iterator_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_rev_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_rev_linord it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted (iterate_to_list it)"
using it_OK unfolding set_iterator_rev_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "map_of (iterate_to_list it) = m \<and> distinct (map fst (iterate_to_list it)) \<and>
       sorted (map fst (rev (iterate_to_list it)))"
using it_OK unfolding map_iterator_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])

lemma (in linorder) iterate_to_list_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "map_of (iterate_to_list it) = m \<and> distinct (map fst (iterate_to_list it)) \<and>
       sorted (map fst (iterate_to_list it))"
using it_OK unfolding map_iterator_rev_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])

subsection \<open>Size\<close>

lemma set_iterator_finite :
assumes it: "set_iterator it S0"
shows "finite S0"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]] .

lemma map_iterator_finite :
assumes it: "map_iterator it m"
shows "finite (dom m)"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
by (simp add: finite_map_to_set)

definition iterate_size where
    "iterate_size (it::('x,nat) set_iterator) = it (\<lambda>_. True) (\<lambda>x \<sigma>. Suc \<sigma>) 0"

lemma iterate_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_size it = card S0 \<and> finite S0"
unfolding iterate_size_def
apply (rule_tac set_iterator_rule_insert_P [OF it,
    where I = "\<lambda>S \<sigma>. \<sigma> = card S \<and> finite S"])
apply auto
done

definition iterate_size_abort where
  "iterate_size_abort (it::('x,nat) set_iterator) n = it (\<lambda>\<sigma>. \<sigma> < n) (\<lambda>x \<sigma>. Suc \<sigma>) 0"

lemma iterate_size_abort_correct :
assumes it: "set_iterator it S0"
shows "iterate_size_abort it n = (min n (card S0)) \<and> finite S0"
unfolding iterate_size_abort_def
proof (rule set_iterator_rule_insert_P [OF it,
   where I = "\<lambda>S \<sigma>. \<sigma> = (min n (card S)) \<and> finite S"], goal_cases)
  case (4 \<sigma> S)
  assume "S \<subseteq> S0" "S \<noteq> S0" "\<not> \<sigma> < n" "\<sigma> = min n (card S) \<and> finite S"

  from \<open>\<sigma> = min n (card S) \<and> finite S\<close> \<open>\<not> \<sigma> < n\<close>
  have "\<sigma> = n" "n \<le> card S"
    by (auto simp add: min_less_iff_disj)

  note fin_S0 = set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
  from card_mono [OF fin_S0 \<open>S \<subseteq> S0\<close>] have "card S \<le> card S0" .

  with \<open>\<sigma> = n\<close> \<open>n \<le> card S\<close> fin_S0
  show "\<sigma> = min n (card S0) \<and> finite S0" by simp
qed simp_all

subsection \<open>Emptyness Check\<close>

definition iterate_is_empty_by_size where
    "iterate_is_empty_by_size it = (iterate_size_abort it 1 = 0)"

lemma iterate_is_empty_by_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty_by_size it = (S0 = {})"
using iterate_size_abort_correct[OF it, of 1]
unfolding iterate_is_empty_by_size_def
by (cases "card S0") auto

definition iterate_is_empty where
    "iterate_is_empty (it::('x,bool) set_iterator) = (it (\<lambda>b. b) (\<lambda>_ _. False) True)"

lemma iterate_is_empty_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty it = (S0 = {})"
unfolding iterate_is_empty_def
apply (rule set_iterator_rule_insert_P [OF it,
   where I = "\<lambda>S \<sigma>. \<sigma> \<longleftrightarrow> S = {}"])
apply auto
done

subsection \<open>Check for singleton Sets\<close>

definition iterate_is_sng where
    "iterate_is_sng it = (iterate_size_abort it 2 = 1)"

lemma iterate_is_sng_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_sng it = (card S0 = 1)"
using iterate_size_abort_correct[OF it, of 2]
unfolding iterate_is_sng_def
apply (cases "card S0", simp, rename_tac n')
apply (case_tac n')
apply auto
done

subsection \<open>Selection\<close>

definition iterate_sel where
    "iterate_sel (it::('x,'y option) set_iterator) f = it (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. f x) None"

lemma iterate_sel_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel it f = None \<longleftrightarrow> (\<forall>x\<in>S0. (f x = None))"
      "iterate_sel it f = Some y \<Longrightarrow> (\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y. f x' = Some y' \<longrightarrow> R x x'))"
proof -
  show "iterate_sel it f = None \<longleftrightarrow> (\<forall>x\<in>S0. (f x = None))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
       where I = "\<lambda>S \<sigma>. (\<sigma> = None) \<longleftrightarrow> (\<forall>x\<in>S. (f x = None))"])
    apply auto
  done
next
  have "iterate_sel it f = Some y \<longrightarrow> (\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y'. f x' = Some y' \<longrightarrow> R x x'))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
       where I = "\<lambda>S \<sigma>. (\<forall>y. \<sigma> = Some y \<longrightarrow> (\<exists>x \<in> S. f x = Some y \<and> (\<forall>x' \<in> S-{x}.\<forall>y'. f x' = Some y' \<longrightarrow> R x x'))) \<and>
                        ((\<sigma> = None) \<longleftrightarrow> (\<forall>x\<in>S. f x = None))"])
    apply simp
    apply (auto simp add: Bex_def subset_iff Ball_def)
    apply metis
  done
  moreover assume "iterate_sel it f = Some y"
  finally show "(\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y. f x' = Some y' \<longrightarrow> R x x'))" by blast
qed

definition iterate_sel_no_map where
    "iterate_sel_no_map it P = iterate_sel it (\<lambda>x. if P x then Some x else None)"
lemmas iterate_sel_no_map_alt_def = iterate_sel_no_map_def[unfolded iterate_sel_def, code]

lemma iterate_sel_no_map_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x' \<in> S0-{x}. P x' \<longrightarrow> R x x'))"
unfolding iterate_sel_no_map_def
using iterate_sel_genord_correct[OF it_OK, of "\<lambda>x. if P x then Some x else None"]
apply (simp_all add: Bex_def)
apply (metis option.inject option.simps(2))
done

lemma iterate_sel_no_map_correct :
assumes it_OK: "set_iterator it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> x \<in> S0 \<and> P x"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> x \<in> S0 \<and> P x"
    by simp_all
qed

lemma (in linorder) iterate_sel_no_map_linord_correct :
assumes it_OK: "set_iterator_linord it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x \<le> x'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x \<le> x'))"
    by auto
qed

lemma (in linorder) iterate_sel_no_map_rev_linord_correct :
assumes it_OK: "set_iterator_rev_linord it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x' \<le> x))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x' \<le> x))"
    by auto
qed

lemma iterate_sel_no_map_map_correct :
assumes it_OK: "map_iterator it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v))"
    by (auto simp add: map_to_set_def)
qed

lemma (in linorder) iterate_sel_no_map_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k \<le> k'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k \<le> k'))"
    apply (auto simp add: map_to_set_def Ball_def)
  done
qed

lemma (in linorder) iterate_sel_no_map_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k' \<le> k))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k' \<le> k))"
    apply (auto simp add: map_to_set_def Ball_def)
  done
qed

subsection \<open>Creating ordered iterators\<close>

text \<open>One can transform an iterator into an ordered one by converting it to list,
        sorting this list and then converting back to an iterator. In general, this brute-force
        method is inefficient, though.\<close>

definition iterator_to_ordered_iterator where
  "iterator_to_ordered_iterator sort_fun it =
   foldli (sort_fun (iterate_to_list it))"

lemma iterator_to_ordered_iterator_correct :
assumes sort_fun_OK: "\<And>l. sorted_wrt R (sort_fun l) \<and> mset (sort_fun l) = mset l"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator sort_fun it) S0 R"
proof -
  define l where "l = iterate_to_list it"
  have l_props: "set l = S0" "distinct l"
    using iterate_to_list_correct [OF it_OK, folded l_def] by simp_all

  with sort_fun_OK[of l] have sort_l_props:
    "sorted_wrt R (sort_fun l)"
    "set (sort_fun l) = S0" "distinct (sort_fun l)"
    apply (simp_all)
    apply (metis set_mset_mset)
    apply (metis distinct_count_atmost_1 set_mset_mset)
  done

  show ?thesis
    apply (rule set_iterator_genord_I[of "sort_fun l"])
    apply (simp_all add: sort_l_props iterator_to_ordered_iterator_def l_def[symmetric])
  done
qed

definition iterator_to_ordered_iterator_quicksort where
  "iterator_to_ordered_iterator_quicksort R it =
   iterator_to_ordered_iterator (quicksort_by_rel R []) it"

lemmas iterator_to_ordered_iterator_quicksort_code[code] =
  iterator_to_ordered_iterator_quicksort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_quicksort_correct :
assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
    and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_quicksort R it) S0 R"
unfolding iterator_to_ordered_iterator_quicksort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_wrt_quicksort_by_rel[OF lin trans_R])
done

definition iterator_to_ordered_iterator_mergesort where
  "iterator_to_ordered_iterator_mergesort R it =
   iterator_to_ordered_iterator (mergesort_by_rel R) it"

lemmas iterator_to_ordered_iterator_mergesort_code[code] =
  iterator_to_ordered_iterator_mergesort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_mergesort_correct :
assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
    and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_mergesort R it) S0 R"
unfolding iterator_to_ordered_iterator_mergesort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_wrt_mergesort_by_rel[OF lin trans_R])
done

end


theory SPMF_Applicative imports
  Applicative_Lifting.Applicative_PMF
  Set_Applicative
  "HOL-Probability.SPMF"
begin

subsection \<open>Applicative instance for @{typ "'a spmf"}\<close>

abbreviation (input) pure_spmf :: "'a \<Rightarrow> 'a spmf"
where "pure_spmf \<equiv> return_spmf"

definition ap_spmf :: "('a \<Rightarrow> 'b) spmf \<Rightarrow> 'a spmf \<Rightarrow> 'b spmf"
where "ap_spmf f x = map_spmf (\<lambda>(f, x). f x) (pair_spmf f x)"

lemma ap_spmf_conv_bind: "ap_spmf f x = bind_spmf f (\<lambda>f. bind_spmf x (\<lambda>x. return_spmf (f x)))"
by(simp add: ap_spmf_def map_spmf_conv_bind_spmf pair_spmf_alt_def)

adhoc_overloading Applicative.ap ap_spmf

context includes applicative_syntax begin

lemma ap_spmf_id: "pure_spmf (\<lambda>x. x) \<diamondop> x = x"
by(simp add: ap_spmf_def pair_spmf_return_spmf1 spmf.map_comp o_def)

lemma ap_spmf_comp: "pure_spmf (\<circ>) \<diamondop> u \<diamondop> v \<diamondop> w = u \<diamondop> (v \<diamondop> w)"
by(simp add: ap_spmf_def pair_spmf_return_spmf1 pair_map_spmf1 pair_map_spmf2 spmf.map_comp o_def split_def pair_pair_spmf)

lemma ap_spmf_homo: "pure_spmf f \<diamondop> pure_spmf x = pure_spmf (f x)"
by(simp add: ap_spmf_def pair_spmf_return_spmf1)

lemma ap_spmf_interchange: "u \<diamondop> pure_spmf x = pure_spmf (\<lambda>f. f x) \<diamondop> u"
by(simp add: ap_spmf_def pair_spmf_return_spmf1 pair_spmf_return_spmf2 spmf.map_comp o_def)

lemma ap_spmf_C: "return_spmf (\<lambda>f x y. f y x) \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x"
apply(simp add: ap_spmf_def pair_map_spmf1 spmf.map_comp pair_spmf_return_spmf1 pair_pair_spmf o_def split_def)
apply(subst (2) pair_commute_spmf)
apply(simp add: pair_map_spmf2 spmf.map_comp o_def split_def)
done

applicative spmf (C)
for
  pure: pure_spmf
  ap: ap_spmf
by(rule ap_spmf_id ap_spmf_comp[unfolded o_def[abs_def]] ap_spmf_homo ap_spmf_interchange ap_spmf_C)+

lemma set_ap_spmf [simp]: "set_spmf (p \<diamondop> q) = set_spmf p \<diamondop> set_spmf q"
by(auto simp add: ap_spmf_def ap_set_def)

lemma bind_ap_spmf: "bind_spmf (p \<diamondop> x) f = bind_spmf p (\<lambda>p. x \<bind> (\<lambda>x. f (p x)))"
by(simp add: ap_spmf_conv_bind)

lemma bind_pmf_ap_return_spmf [simp]: "bind_pmf (ap_spmf (return_spmf f) p) g = bind_pmf p (g \<circ> map_option f)"
by(auto simp add: ap_spmf_conv_bind bind_spmf_def bind_return_pmf bind_assoc_pmf intro: bind_pmf_cong split: option.split)

lemma map_spmf_conv_ap [applicative_unfold]: "map_spmf f p = return_spmf f \<diamondop> p"
by(simp add: map_spmf_conv_bind_spmf ap_spmf_conv_bind)

end

end


theory Base
  imports Main HOL.Orderings Common
begin

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

(*
  A preference profile is a tuple containing a preference relation for each voter
*)
type_synonym 'a PP = "nat \<Rightarrow> 'a relation"

locale choice_setting =
  (* The nonempty finite universe of alternatives *)
  fixes U :: "'a set"
  assumes nonempty_universe: "U \<noteq> {}"
  assumes finite_universe: "finite U"

locale social_choice_setting = choice_setting +
  (* The amount of voters *)
  fixes n :: nat
  assumes n_pos: "n > 0"
begin

(* The finite set of voters, actually just a set {0, 1, ..., n} *)
abbreviation N where "N \<equiv> {i . i < n}"
lemma filled_N: "filled N" by (metis empty_def finite_Collect_less_nat mem_Collect_eq n_pos)
lemma filled_G: "G \<sqsubseteq> N \<Longrightarrow> filled G" by (metis filled_N sub_finite)

end

abbreviation asymm :: "'a relation \<Rightarrow> 'a relation" where "asymm R \<equiv> \<lambda>x y. R x y \<and> \<not> R y x"

locale general_preference = choice_setting +
  (* x R y means that x is at least as good as y, possibly indifferent *)
  fixes R :: "'a relation" (infix "R" 50)
  (* R never relates elements that are not alternatives *)
  assumes R_domain: "(x \<notin> U \<or> y \<notin> U) \<Longrightarrow> \<not> x R y"
begin

(* The asymmetric part of R, i.e. x P y means that x is strictly better than y *)
definition P :: "'a relation" (infix "P" 50) where "(P) \<equiv> asymm (R)"

lemma P_subrelation_of_R: "x P y \<Longrightarrow> x R y" using P_def by simp

definition Max :: "'a set \<Rightarrow> 'a set" where "Max A = {x \<in> A . \<not>(\<exists>y \<in> A . y P x)}"

end

locale transitive_preference = general_preference +
  assumes transitive: "x R y \<Longrightarrow> y R z \<Longrightarrow> x R z"
begin

lemma P_trans: "x P y \<Longrightarrow> y P z \<Longrightarrow> x P z" unfolding P_def using transitive by blast
lemma P_trans2: "x P y \<Longrightarrow> z R x \<Longrightarrow> z P y" unfolding P_def using transitive by blast

lemma Max_nonempty: "A \<sqsubseteq> U \<Longrightarrow> Max A \<noteq> {}" proof -
  assume "A \<sqsubseteq> U"
  hence "finite A" using finite_universe rev_finite_subset by auto
  thus "A \<sqsubseteq> U \<Longrightarrow> Max A \<noteq> {}" proof (induction rule: finite_psubset_induct)
    case (psubset A)
    then obtain a where a: "a \<in> A" by auto
    let ?B = "{b \<in> A. b P a}"
    show ?case proof (cases "?B = {}")
      case True
      thus ?thesis using P_def Max_def[of A] \<open>a \<in> A\<close> by auto
    next
      case False
      then obtain bmax where "bmax \<in> Max ?B" using psubset.prems P_def a psubset.IH[of ?B] by auto
      moreover
      hence "bmax P a" unfolding P_def Max_def by auto
      hence "y R bmax \<Longrightarrow> y P a" for y using P_trans2 by auto
      ultimately
      show ?thesis unfolding P_def Max_def by auto
    qed
  qed
qed

end

locale reflexive_preference = general_preference +
  assumes reflexive: "x \<in> U \<Longrightarrow> x R x"

locale complete_preference = general_preference +
  assumes complete: "x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x R y \<or> y R x"
begin

lemma Max_comp: "A \<sqsubseteq> U \<Longrightarrow> Max A = {x \<in> A . (\<forall>y \<in> A . x R y)}" unfolding Max_def using complete
  by (metis (mono_tags, lifting) P_def in_mono)

end

(* We usually assume that individual preference relations are complete, reflexive, and transitive *)
locale preference_relation = transitive_preference + reflexive_preference + complete_preference

context choice_setting
begin
definition triv_pref where "triv_pref \<equiv> \<lambda>x y. x \<in> U \<and> y \<in> U"
interpretation triv_pref: preference_relation U triv_pref
  unfolding triv_pref_def by unfold_locales auto

end

locale preference_profile = social_choice_setting +
  constrains U :: "'a set"
  fixes R\<^sub>N :: "'a PP"
  assumes R\<^sub>N: "i \<in> N \<Longrightarrow> preference_relation U (R\<^sub>N i)"
  assumes R\<^sub>N_domain: "i \<notin> N \<or> x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> R\<^sub>N i x y"
begin
abbreviation P\<^sub>N :: "'a PP" where "P\<^sub>N i x y \<equiv> i \<in> N \<and> general_preference.P (R\<^sub>N i) x y"

lemma refl: "i \<in> N \<Longrightarrow> a \<in> U \<Longrightarrow> R\<^sub>N i a a" proof -
  fix i a
  assume "i \<in> N"
  hence "reflexive_preference U (R\<^sub>N i)" using R\<^sub>N by (auto simp add: preference_relation.axioms(2))
  moreover assume "a \<in> U"
  ultimately show "R\<^sub>N i a a" using reflexive_preference.reflexive[of U] by auto
qed

end

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.*)
  theory TIP_sort_NMSortTDSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "int => int" where
  "nmsorttdhalf1 x =
   (if (x = 1) then 0 else
      (if (x = 0) then 0 else 1 + (nmsorttdhalf1 (x - 2))))"
  by pat_completeness auto

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function nmsorttd :: "int list => int list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "ordered (nmsorttd xs)"
  oops

end


theory Unification
imports Main
begin

type_synonym var = nat

datatype 'a expression =
  VAR var
| CON 'a "'a expression list"

fun vars :: "'a expression \<Rightarrow> var set" where
  "vars (VAR x) = {x}"
| "vars (CON s es) = \<Union> (vars ` set es)"

datatype 'a substitution =
  EMPTY
| EXTEND var "'a expression" "'a substitution"

primrec subst\<^sub>e :: "var \<Rightarrow> 'a expression \<Rightarrow> 'a expression \<Rightarrow> 'a expression"  where
  "subst\<^sub>e x e' (VAR y) = (if x = y then e' else VAR y)"
| "subst\<^sub>e x e' (CON s es) = CON s (map (subst\<^sub>e x e') es)"

primrec subst\<^sub>\<Theta> :: "'a substitution \<Rightarrow> var \<Rightarrow> 'a expression" where
  "subst\<^sub>\<Theta> EMPTY x = VAR x"
| "subst\<^sub>\<Theta> (EXTEND y e \<Theta>) x = (if x = y then e else subst\<^sub>e y e (subst\<^sub>\<Theta> \<Theta> x))"

primrec subst\<^sub>e\<^sub>\<Theta> :: "'a substitution \<Rightarrow> 'a expression \<Rightarrow> 'a expression" where
  "subst\<^sub>e\<^sub>\<Theta> \<Theta> (VAR x) = subst\<^sub>\<Theta> \<Theta> x"
| "subst\<^sub>e\<^sub>\<Theta> \<Theta> (CON s es) = CON s (map (subst\<^sub>e\<^sub>\<Theta> \<Theta>) es)"

type_synonym 'a equation = "'a expression \<times> 'a expression"

primrec subst\<^sub>e\<^sub>q\<^sub>n :: "var \<Rightarrow> 'a expression \<Rightarrow> 'a equation \<Rightarrow> 'a equation" where
  "subst\<^sub>e\<^sub>q\<^sub>n x e' (e\<^sub>1, e\<^sub>2) = (subst\<^sub>e x e' e\<^sub>1, subst\<^sub>e x e' e\<^sub>2)"

primrec subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s :: "var \<Rightarrow> 'a expression \<Rightarrow> 'a equation list \<Rightarrow> 'a equation list" where
  "subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s x e' [] = []"
| "subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s x e' (eq # eqs) = subst\<^sub>e\<^sub>q\<^sub>n x e' eq # subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s x e' eqs"

function unify' :: "'a equation list \<Rightarrow> 'a substitution option" where
  "unify' [] = Some EMPTY"
| "unify' ((CON s es\<^sub>1, CON t es\<^sub>2) # eqs) = (
    if s = t \<and> length es\<^sub>1 = length es\<^sub>2 then unify' (zip es\<^sub>1 es\<^sub>2 @ eqs)
    else None)"
| "unify' ((CON s es, VAR x) # eqs) = unify' ((VAR x, CON s es) # eqs)"
| "unify' ((VAR x, t) # eqs) = (
    if t = VAR x then unify' eqs
    else if x \<in> vars t then None
    else case unify' (subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s x t eqs) of
        None \<Rightarrow> None
      | Some \<Theta> \<Rightarrow> Some (EXTEND x (subst\<^sub>e\<^sub>\<Theta> \<Theta> t) \<Theta>))"
  by pat_completeness auto

definition unify :: "'a expression \<Rightarrow> 'a expression \<Rightarrow> 'a substitution option" where
  "unify e\<^sub>1 e\<^sub>2 = unify' [(e\<^sub>1, e\<^sub>2)]"

(* unification termination *)

(* useless function, useful induction pattern: expression_complete.induct *)
fun expression_complete :: "'a expression \<Rightarrow> bool" where
  "expression_complete (VAR y) = True"
| "expression_complete (CON s []) = True"
| "expression_complete (CON s (e # es)) = (expression_complete e \<and> expression_complete (CON s es))"

(* useless function, useful induction pattern: two_lists.induct *)
fun two_lists :: "'a list \<Rightarrow> 'b list \<Rightarrow> bool" where
  "two_lists [] [] = True"
| "two_lists [] (b # bs) = True"
| "two_lists (a # as) [] = True"
| "two_lists (a # as) (b # bs) = two_lists as bs"

fun vars_first :: "'a equation list \<Rightarrow> nat" where
  "vars_first [] = 0"
| "vars_first ((VAR x, t) # eqs) = 1"
| "vars_first ((CON s es, t) # eqs) = 2"

primrec cons :: "'a expression \<Rightarrow> nat"
    and conss :: "'a expression list \<Rightarrow> nat" where
  "cons (VAR x) = 0"
| "cons (CON s es) = Suc (conss es)"
| "conss [] = 0"
| "conss (e # es) = cons e + conss es"

primrec vars\<^sub>e\<^sub>q\<^sub>n :: "'a equation \<Rightarrow> var set" where
  "vars\<^sub>e\<^sub>q\<^sub>n (e\<^sub>1, e\<^sub>2) = vars e\<^sub>1 \<union> vars e\<^sub>2"

primrec vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s :: "'a equation list \<Rightarrow> var set" where
  "vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s [] = {}"
| "vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s (eq # eqs) = vars\<^sub>e\<^sub>q\<^sub>n eq \<union> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs"

primrec cons\<^sub>e\<^sub>q\<^sub>n :: "'a equation \<Rightarrow> nat" where
  "cons\<^sub>e\<^sub>q\<^sub>n (e\<^sub>1, e\<^sub>2) = cons e\<^sub>1 + cons e\<^sub>2"

primrec cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s :: "'a equation list \<Rightarrow> nat" where
  "cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s [] = 0"
| "cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s (eq # eqs) = cons\<^sub>e\<^sub>q\<^sub>n eq + cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs"

lemma [simp]: "x \<notin> vars t \<Longrightarrow> vars (subst\<^sub>e x t e) =
    (if x \<in> vars e then vars e - {x} \<union> vars t else vars e - {x})"
  by (induction e rule: expression_complete.induct) auto

lemma [simp]: "x \<notin> vars e \<Longrightarrow> subst\<^sub>e x t e = e"
  by (induction e rule: expression_complete.induct) simp_all

lemma [simp]: "vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s (eqs @ eqs') = vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs \<union> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs'"
  by (induction eqs arbitrary: eqs') auto

lemma [simp]: "length es1 = length es2 \<Longrightarrow> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s (zip es1 es2) = \<Union> (vars ` set (es1 @ es2))"
  by (induction es1 es2 rule: two_lists.induct) auto

lemma [simp]: "cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s (eqs @ eqs') = cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs + cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs'"
  by (induction eqs arbitrary: eqs') auto

lemma [simp]: "length es1 = length es2 \<Longrightarrow> cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s (zip es1 es2) = conss es1 + conss es2"
  by (induction es1 es2 rule: two_lists.induct) auto

lemma [simp]: "finite (vars\<^sub>e\<^sub>q\<^sub>n eq)"
  by (induction eq) simp_all

lemma [simp]: "finite (vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs)"
  by (induction eqs) simp_all

lemma [simp]: "x \<notin> vars t \<Longrightarrow> vars\<^sub>e\<^sub>q\<^sub>n (subst\<^sub>e\<^sub>q\<^sub>n x t eq) =
    (if x \<in> vars\<^sub>e\<^sub>q\<^sub>n eq then vars\<^sub>e\<^sub>q\<^sub>n eq - {x} \<union> vars t else vars\<^sub>e\<^sub>q\<^sub>n eq - {x})"
  by (induction eq) auto

lemma unfold_vars_subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s: "x \<notin> vars t \<Longrightarrow> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s (subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s x t eqs) =
    (if x \<in> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs then vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs - {x} \<union> vars t else vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs - {x})"
  by (induction eqs) auto

lemma [simp]: "x \<notin> vars t \<Longrightarrow> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s (subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s x t eqs) \<subset> insert x (vars t \<union> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs)"
  by (auto simp add: unfold_vars_subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s)

lemma [simp]: "x \<notin> vars t \<Longrightarrow>
    card (vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s (subst\<^sub>e\<^sub>q\<^sub>n\<^sub>s x t eqs)) < card (insert x (vars t \<union> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs))"
  by (simp add: psubset_card_mono)

lemma [simp]: "card (vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs) < card (insert x (vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs)) \<or>
    card (vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs) = card (insert x (vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs))"
  by (cases "x \<in> vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s eqs") (simp_all add: insert_absorb)

termination unify'
  by (relation "measures [card o vars\<^sub>e\<^sub>q\<^sub>n\<^sub>s, cons\<^sub>e\<^sub>q\<^sub>n\<^sub>s, length, vars_first]") simp_all

end