(*
    Author:     Tobias Nipkow, 2008
*)

header "The Gibbard-Satterthwaite Theorem"

theory GS imports Arrow_Order
begin

text{* The Gibbard-Satterthwaite theorem as a corollary to Arrow's
theorem. The proof follows Nisan~\cite{NisanRTV07}. *}

definition "manipulable f == \<exists>P\<in>Prof. \<exists>i. \<exists>L\<in>Lin. (f P, f(P(i:=L))) : P i"

definition "dict f i == \<forall>P\<in>Prof.\<forall>a. a \<noteq> f P \<longrightarrow> (a,f P) : P i"

definition
 Top :: "alt set \<Rightarrow> pref \<Rightarrow> pref" where
"Top S L \<equiv> {(a,b). (a,b) \<in> L \<and> (a \<in> S \<and> b \<in> S \<or> a \<notin> S \<and> b \<notin> S)} \<union>
             {(a,b). a \<notin> S \<and> b \<in> S}"

lemma Top_in_Lin: "L:Lin \<Longrightarrow> Top S L : Lin"
apply(simp add:Top_def slo_defs Sigma_def)
unfolding trans_def
apply blast
done

lemma Top_in_Prof: "P:Prof \<Longrightarrow> Top S o P : Prof"
by(simp add:Prof_def Pi_def Top_in_Lin)

lemma not_manipulable: "\<not> manipulable f \<longleftrightarrow>
 (\<forall>P\<in>Prof.\<forall>i.\<forall>L\<in>Lin. f P \<noteq> f(P(i:=L)) \<longrightarrow>
   (f(P(i := L)), f P) : P i \<and> (f P, f(P(i := L))) : L)" (is "?A = ?B")
proof
  assume ?A
  show ?B
  proof(clarsimp)
    fix P i L assume 0: "P \<in> Prof" "L \<in> Lin" "f P \<noteq> f (P(i := L))"
    moreover hence 1: "P i: Lin" "P(i:=L): Prof" by(simp add:Prof_def Pi_def)+
    ultimately have "(f (P(i := L)), f P) \<in> P i" (is ?L)
      using `?A` unfolding manipulable_def by (metis notin_Lin_iff)
    moreover have "(f P, f (P(i := L))) \<in> L" (is ?R)
      using 0 1 fun_upd_upd[of P] fun_upd_triv[of P] fun_upd_same[of P]
      using `?A` unfolding manipulable_def by (metis notin_Lin_iff)
    ultimately show "?L \<and> ?R" ..
  qed
next
  assume ?B
  show ?A
  proof(clarsimp simp:manipulable_def)
    fix P i L assume "P \<in> Prof" "L \<in> Lin" "(f P, f (P(i := L))) \<in> P i"
    moreover hence "P i: Lin" by(simp add:Prof_def Pi_def)
    ultimately show False
      using `?B` by(metis Lin_irrefl)
  qed
qed

definition "swf(f) \<equiv> \<lambda>P. {(a,b). a\<noteq>b \<and> f(Top {a,b} o P) = b}"

locale GS =
fixes f
assumes not_manip: "\<not> manipulable f"
and onto: "f ` Prof = UNIV"
begin

lemma mono:
assumes "P\<in>Prof" "P'\<in>Prof" "\<forall>i a. (a, f P) : P i \<longrightarrow> (a, f P) : P' i"
shows "f P' = f P"
proof-
  obtain h :: "indi \<Rightarrow> nat" where
    injh: "inj h" and surjh: "h ` I = {0..<N}"
    by(metis ex_bij_betw_finite_nat[OF finite_indi] bij_betw_def)
  let ?M = "%n i. if h i < n then P' i else P i"
  have N: "!!i. h i < N" using surjh by auto
  have MProf: "!!n. ?M n : Prof" and P'Lin: "!!i. P' i : Lin"
    using `P:Prof` `P':Prof` by(simp add:Prof_def Pi_def)+
  { fix n have "n<=N \<Longrightarrow> f(?M n) = f P"
    proof(induct n)
      case 0 show ?case by simp
    next
      case (Suc n)
      let ?up = "(?M n)(inv h n := P' (inv h n))"
      have 1: "?M(Suc n) = ?up" using surjh Suc(2)
        by(simp (no_asm_simp) add:fun_eq_iff f_inv_into_f)
          (metis injh inv_f_f less_antisym)
      show ?case
      proof(rule ccontr)
        assume "\<not> ?case"
        with `?M(Suc n) = ?up` Suc have 0: "f ?up \<noteq> f(?M n)" by simp
        from nonmanip[OF MProf P'Lin 0] assms(3) show False
          using N surjh Suc Lin_irrefl[OF P'Lin]
          by(fastforce simp: f_inv_into_f)
      qed
    qed
  }
  from this[of N] N show "f P' = f P" by simp
qed

lemma una_Top: assumes "P:Prof" "S \<noteq> {}" shows "f(Top S o P) : S"
proof -
  obtain h :: "indi \<Rightarrow> nat" where
    injh: "inj h" and surjh: "h ` I = {0..<N}"
    by(metis ex_bij_betw_finite_nat[OF finite_indi] bij_betw_def)
  from assms obtain a where "a:S" by blast
  from onto obtain Pa where "Pa:Prof" "f Pa = a"
    by(metis inv_into_into UNIV_I f_inv_into_f)
  let ?M = "%n i. if h i < n then Top S (P i) else Pa i"
  have N: "!!i. h i < N" using surjh by auto
  have MProf: "!!n. ?M n : Prof" using `P:Prof` `Pa:Prof`
    by(simp add:Prof_def Pi_def Top_in_Lin mktop_Lin)
  { fix n have "n<=N \<Longrightarrow> f(?M n) : S"
    proof(induct n)
      case 0 thus ?case using `f Pa = a` `a:S` by simp
    next
      case (Suc n)
      show ?case
      proof cases
        assume "f(?M n) = f(?M(Suc n))"
        thus ?case using Suc by simp
      next
        let ?up = "(?M n)(inv h n := Top S (P(inv h n)))"
        assume "f(?M n) \<noteq> f(?M(Suc n))"
        also have eq: "?M(Suc n) = ?up" using surjh Suc
          by(simp (no_asm_simp) add:fun_eq_iff f_inv_into_f)
            (metis injh inv_f_eq less_antisym)
        finally have n: "f(?M n) \<noteq> f(?up)" .
        with nonmanip[OF MProf Top_in_Lin n[symmetric]] Suc eq `P:Prof`
        show ?case by (simp add:Top_def Prof_def Pi_def)
      qed
    qed
  }
  from this[of N] N show ?thesis by(simp add:comp_def)
qed

lemma SWF_swf: "swf f : SWF"
proof (rule Pi_I)
  fix P assume "P: Prof"
  show "swf f P : Lin"
  proof(unfold Lin_def strict_linear_order_on_def, auto)
    show "total(swf f P)"
    proof(simp add: total_on_def, intro allI impI)
      fix a b :: alt assume "a\<noteq>b"
      thus "(a,b) \<in> swf f P \<or> (b,a) \<in> swf f P"
        unfolding swf_def using una_Top[of P "{a,b}"] `P:Prof`
        by simp(metis insert_commute)
    qed
    show "irrefl(swf f P)" by(simp add: irrefl_def swf_def)
    show "trans(swf f P)"
    proof (clarsimp simp:trans_def swf_def insert_commute)
      fix a b c assume "a\<noteq>b" "b\<noteq>c" "f(Top{a,b} \<circ> P) = b" "f(Top{b,c} \<circ> P) = c"
      hence "a\<noteq>c" by(auto simp: insert_commute)
      note 3 = Top_in_Prof[OF `P:Prof`, of "{a,b,c}"]
      { assume "f (Top {a, b, c} \<circ> P) = a"
        hence "f(Top{a,b} \<circ> P) = a"
          using mono[OF 3 Top_in_Prof[OF `P:Prof`], of "{a,b}"]
          by(auto simp:Top_def)
        with `f(Top{a,b} \<circ> P) = b` `a\<noteq>b` have False by simp
      } moreover
      { assume "f (Top {a, b, c} \<circ> P) = b"
        hence "f(Top{b,c} \<circ> P) = b"
          using mono[OF 3 Top_in_Prof[OF `P:Prof`], of "{b,c}"]
          by(auto simp:Top_def)
        with `f(Top{b,c} \<circ> P) = c` `b\<noteq>c` have False by simp
      }
      ultimately have "f (Top {a, b, c} \<circ> P) = c"
        using una_Top[OF `P:Prof`, of "{a,b,c}", simplified] by blast
      hence "f(Top{a,c} \<circ> P) = c" (is ?R)
        using mono[OF 3 Top_in_Prof[OF `P:Prof`], of "{a,c}"]
        by (auto simp:Top_def)
      thus "a\<noteq>c \<and> ?R" using `a\<noteq>c` by blast
    qed
  qed
qed

lemma Top_top: "L:Lin \<Longrightarrow> (!!a. a\<noteq>b \<Longrightarrow> (a,b) : L) \<Longrightarrow> Top {b} L = L"
apply(auto simp:Top_def slo_defs)
apply (metis trans_def)
apply (metis trans_def)
done

lemma una_swf: "unanimity(swf f)"
proof(clarsimp simp:swf_def unanimity_def)
  fix P a b
  assume "P:Prof" and abP: "\<forall>i. (a, b) \<in> P i"
  hence "a \<noteq> b" by(fastforce simp:Prof_def Pi_def slo_defs)
  let ?abP = "Top {a,b} \<circ> P"
  have "?abP : Prof" using `P:Prof` by(simp add:Prof_def Pi_def Top_in_Lin)
  have top: "!!i c. b\<noteq>c \<Longrightarrow> (c,b) : Top {a,b} (P i)"
    using abP by(auto simp:Top_def)
  have "Top {b} o ?abP = ?abP" using `P:Prof`
    by (simp add:fun_eq_iff top Top_top Prof_def Pi_def Top_in_Lin)
  moreover have "f(Top {b} o ?abP) = b"
    by (metis una_Top[OF `?abP : Prof`] empty_not_insert singletonE)
  ultimately have "f ?abP = b" by simp
  thus "a\<noteq>b \<and> f ?abP = b" using `a\<noteq>b` by blast
qed

lemma IIA_swf: "IIA(swf f)"
proof(clarsimp simp: IIA_def)
  fix P P' a b
  assume "P:Prof" "P':Prof" and iff: "\<forall>i. ((a,b) \<in> P i) = ((a,b) \<in> P' i)"
  hence [simp]: "!!i x. (x,x) ~: P i \<and> (x,x) ~: P' i"
    by(simp add:Prof_def Pi_def slo_defs)
  have iff':  "a\<noteq>b \<longrightarrow> (\<forall>i. ((b,a) \<in> P i) = ((b,a) \<in> P' i))"
    using iff `P:Prof` `P':Prof` unfolding Prof_def Pi_def
    by simp (metis iff notin_Lin_iff)
  let ?abP = "Top {a,b} o P" let ?abP' = "Top {a,b} o P'"
  have "\<forall>i c. (c, f ?abP) : ?abP i \<longrightarrow> (c, f ?abP) : ?abP' i"
    using una_Top[of P "{a,b}", OF `P:Prof`] iff iff' by(auto simp add:Top_def)
  then have "f (Top {a,b} \<circ> P) = f (Top {a,b} \<circ> P')"
    using Top_in_Prof[OF `P:Prof`] Top_in_Prof[OF `P':Prof`]
          mono[of "Top {a, b} \<circ> P"]  by metis
  thus "(a <\<^bsub>swf f P\<^esub> b) = (a <\<^bsub>swf f P'\<^esub> b)" by(simp add: swf_def)
qed

lemma dict_swf: assumes "dictator (swf f) i" shows "dict f i"
proof (auto simp:dict_def)
  fix P a assume "P:Prof" "a\<noteq>f P"
  have "f (Top {a,f P} \<circ> P) = f P"
    using mono[OF `P:Prof` Top_in_Prof[OF `P:Prof`,of "{a,f P}"]]
    by (auto simp:Top_def)
  moreover have "P i = {(a,b). a\<noteq>b \<and> f(Top {a,b} \<circ> P) = b}"
    using assms `P:Prof` by(simp add:dictator_def swf_def)
  ultimately show "(a,f P) : P i" using `a\<noteq>f P` by simp
qed

theorem Gibbard_Satterthwaite:
  "\<exists>i. dict f i"
by (metis Arrow SWF_swf una_swf IIA_swf dict_swf)

end

theorem Gibbard_Satterthwaite:
  "\<not> manipulable f \<Longrightarrow> \<forall>a.\<exists>P\<in>Prof. a = f P \<Longrightarrow> \<exists>i. dict f i"
using GS.Gibbard_Satterthwaite[of f,unfolded GS_def]
by blast

end


theory Rewrite_Examples
imports Main "HOL-Library.Rewrite"
begin

section \<open>The rewrite Proof Method by Example\<close>

text\<open>
This theory gives an overview over the features of the pattern-based rewrite proof method.

Documentation: @{url "https://arxiv.org/abs/2111.04082"}
\<close>

lemma
  fixes a::int and b::int and c::int
  assumes "P (b + a)"
  shows "P (a + b)"
by (rewrite at "a + b" add.commute)
   (rule assms)

(* Selecting a specific subterm in a large, ambiguous term. *)
lemma
  fixes a b c :: int
  assumes "f (a - a + (a - a)) + f (   0    + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f _ + f \<hole> = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite at "f (_ + \<hole>) + f _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (  0   + (a - a)) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (\<hole> + _) + _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (_ + \<hole>) + _ = _" diff_self) fact

lemma
  fixes x y :: nat
  shows"x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" add.commute) assumption

(* We can also rewrite in the assumptions.  *)
lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in "x + y > c" at asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" at asm  add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "x+1" in "{x::int. \<hole> }" add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "any_identifier_will_work+1" in "{any_identifier_will_work::int. \<hole> }" add.commute)
   fact

lemma
  assumes "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. s * t + y - 3)}"
  shows   "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. y + s * t - 3)}"
  by (rewrite at "b + d * e" in "\<lambda>(a, b, c). _ = Q (\<lambda>d e. \<hole>)" add.commute) fact

(* This is not limited to the first assumption *)
lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

(* Rewriting "at asm" selects each full assumption, not any parts *)
lemma
  assumes "(PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP S \<Longrightarrow> PROP R)"
  shows "PROP S \<Longrightarrow> (PROP P \<Longrightarrow> PROP Q) \<Longrightarrow> PROP R"
  apply (rewrite at asm assms)
  apply assumption
  done

(* Rewriting with conditional rewriting rules works just as well. *)
lemma test_theorem:
  fixes x :: nat
  shows "x \<le> y \<Longrightarrow> x \<ge> y \<Longrightarrow> x = y"
  by (rule Orderings.order_antisym)

(* Premises of the conditional rule yield new subgoals. The
   assumptions of the goal are propagated into these subgoals
*)
lemma
  fixes f :: "nat \<Rightarrow> nat"
  shows "f x \<le> 0 \<Longrightarrow> f x \<ge> 0 \<Longrightarrow> f x = 0"
  apply (rewrite at "f x" to "0" test_theorem)
  apply assumption
  apply assumption
  apply (rule refl)
  done

(* This holds also for rewriting in assumptions. The order of assumptions is preserved *)
lemma
  assumes rewr: "PROP P \<Longrightarrow> PROP Q \<Longrightarrow> PROP R \<equiv> PROP R'"
  assumes A1: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP P"
  assumes A2: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP Q"
  assumes C: "PROP S \<Longrightarrow> PROP R' \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  shows "PROP S \<Longrightarrow> PROP R \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  apply (rewrite at asm rewr)
  apply (fact A1)
  apply (fact A2)
  apply (fact C)
  done

(*
   Instantiation.

   Since all rewriting is now done via conversions,
   instantiation becomes fairly easy to do.
*)

(* We first introduce a function f and an extended
   version of f that is annotated with an invariant. *)
fun f :: "nat \<Rightarrow> nat" where "f n = n"
definition "f_inv (I :: nat \<Rightarrow> bool) n \<equiv> f n"

lemma annotate_f: "f = f_inv I"
  by (simp add: f_inv_def fun_eq_iff)

(* We have a lemma with a bound variable n, and
   want to add an invariant to f. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>_. True) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite to "f_inv (\<lambda>_. True)" annotate_f) fact

(* We can also add an invariant that contains the variable n bound in the outer context.
   For this, we need to bind this variable to an identifier. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>n. \<hole>" to "f_inv (\<lambda>x. n < x + 1)" annotate_f) fact

(* Any identifier will work *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>abc. \<hole>" to "f_inv (\<lambda>x. abc < x + 1)" annotate_f) fact

(* The "for" keyword. *)
lemma
  assumes "P (2 + 1)"
  shows "\<And>x y. P (1 + 2 :: nat)"
by (rewrite in "P (1 + 2)" at for (x) add.commute) fact

lemma
  assumes "\<And>x y. P (y + x)"
  shows "\<And>x y. P (x + y :: nat)"
by (rewrite in "P (x + _)" at for (x y) add.commute) fact

lemma
  assumes "\<And>x y z. y + x + z = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "x + y" in "x + y + z" in for (x y z) add.commute) fact

lemma
  assumes "\<And>x y z. z + (x + y) = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "(_ + y) + z" in for (y z) add.commute) fact

lemma
  assumes "\<And>x y z. x + y + z = y + z + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "\<hole> + _" at "_ = \<hole>" in for () add.commute) fact

lemma
  assumes eq: "\<And>x. P x \<Longrightarrow> g x = x"
  assumes f1: "\<And>x. Q x \<Longrightarrow> P x"
  assumes f2: "\<And>x. Q x \<Longrightarrow> x"
  shows "\<And>x. Q x \<Longrightarrow> g x"
  apply (rewrite at "g x" in for (x) eq)
  apply (fact f1)
  apply (fact f2)
  done

(* The for keyword can be used anywhere in the pattern where there is an \<And>-Quantifier. *)
lemma
  assumes "(\<And>(x::int). x < 1 + x)"
  and     "(x::int) + 1 > x"
  shows   "(\<And>(x::int). x + 1 > x) \<Longrightarrow> (x::int) + 1 > x"
by (rewrite at "x + 1" in for (x) at asm add.commute)
   (rule assms)

(* The rewrite method also has an ML interface *)
lemma
  assumes "\<And>a b. P ((a + 1) * (1 + b)) "
  shows "\<And>a b :: nat. P ((a + 1) * (b + 1))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
      (* Note that the pattern order is reversed *)
      val pat = [
        Rewrite.For [(x, SOME \<^Type>\<open>nat\<close>)],
        Rewrite.In,
        Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>nat\<close> for \<open>Free (x, \<^Type>\<open>nat\<close>)\<close> \<^term>\<open>1 :: nat\<close>\<close>, [])]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

lemma
  assumes "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. a + b))"
  shows "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
      val pat = [
        Rewrite.Concl,
        Rewrite.In,
        Rewrite.Term (Free ("Q", (\<^Type>\<open>int\<close> --> TVar (("'b",0), [])) --> \<^Type>\<open>bool\<close>)
          $ Abs ("x", \<^Type>\<open>int\<close>, Rewrite.mk_hole 1 (\<^Type>\<open>int\<close> --> TVar (("'b",0), [])) $ Bound 0), [(x, \<^Type>\<open>int\<close>)]),
        Rewrite.In,
        Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>int\<close> for \<open>Free (x, \<^Type>\<open>int\<close>)\<close> \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close>\<close>, [])
        ]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

(* There is also conversion-like rewrite function: *)
ML \<open>
  val ct = \<^cprop>\<open>Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))\<close>
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
  val pat = [
    Rewrite.Concl,
    Rewrite.In,
    Rewrite.Term (Free ("Q", (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) --> \<^typ>\<open>bool\<close>)
      $ Abs ("x", \<^typ>\<open>int\<close>, Rewrite.mk_hole 1 (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) $ Bound 0), [(x, \<^typ>\<open>int\<close>)]),
    Rewrite.In,
    Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>int\<close> for \<open>Free (x, \<^Type>\<open>int\<close>)\<close> \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close>\<close>, [])
    ]
  val to = NONE
  val th = Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute} ct
\<close>

text \<open>Some regression tests\<close>

ML \<open>
  val ct = \<^cterm>\<open>(\<lambda>b :: int. (\<lambda>a. b + a))\<close>
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
  val pat = [
    Rewrite.In,
    Rewrite.Term (\<^Const>\<open>plus \<^Type>\<open>int\<close> for \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close> \<open>Var (("c", 0), \<^Type>\<open>int\<close>)\<close>\<close>, [])
    ]
  val to = NONE
  val _ =
    case try (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) ct of
      NONE => ()
    | _ => error "should not have matched anything"
\<close>

ML \<open>
  Rewrite.params_pconv (Conv.all_conv |> K |> K) \<^context> (Vartab.empty, []) \<^cterm>\<open>\<And>x. PROP A\<close>
\<close>

lemma
  assumes eq: "PROP A \<Longrightarrow> PROP B \<equiv> PROP C"
  assumes f1: "PROP D \<Longrightarrow> PROP A"
  assumes f2: "PROP D \<Longrightarrow> PROP C"
  shows "\<And>x. PROP D \<Longrightarrow> PROP B"
  apply (rewrite eq)
  apply (fact f1)
  apply (fact f2)
  done

end


theory Test_Suite
imports Traversal_Set State_Preamble State_Separator
begin

type_synonym IO_Sequence = "(Input \<times> Output) list"
type_synonym Preamble_Sequence = IO_Sequence
type_synonym Traversal_Sequence = IO_Sequence
type_synonym Test_Sequences = "IO_Sequence list"

type_synonym Test_Case = "(Preamble_Sequence \<times> ((Traversal_Sequence \<times> Test_Sequences) list))"
type_synonym Test_Case' = "(Preamble_Sequence set \<times> ((Traversal_Sequence \<times> Test_Sequences) list))"

fun contains_io_sequence' :: "'a Transition set \<Rightarrow> 'a \<Rightarrow> IO_Sequence \<Rightarrow> bool" where
  "contains_io_sequence' H q [] = True" |
  "contains_io_sequence' H q (io#ios) = (\<exists> t \<in> H . t_source t = q \<and> t_input t = fst io \<and> t_output t = snd io \<and> contains_io_sequence' H (t_target t) ios)"

value "contains_io_sequence' (h M_ex_H) 1 [(0,0)]"
value "contains_io_sequence' (h M_ex_H) 1 [(0,1),(0,0)]"
value "contains_io_sequence' (h M_ex_H) 1 [(0,1),(0,0),(0,1),(0,0),(0,1),(0,0),(0,1),(0,0)]"
value "contains_io_sequence' (h M_ex_H) 1 [(0,1),(0,0),(0,1),(0,0),(0,1),(0,0),(0,1),(0,0),(0,0)]"

definition contains_io_sequence :: "('a,'b) FSM_scheme \<Rightarrow> 'a \<Rightarrow> IO_Sequence \<Rightarrow> bool" where
  "contains_io_sequence M q io = contains_io_sequence' (h M) q io"

lemma contains_io_sequence_soundness :
  assumes "q \<in> nodes M"
  and     "contains_io_sequence M q io"
shows "io \<in> LS M q"
proof -
  have "\<exists> p . path M q p \<and> p_io p = io"
  using assms proof (induction io arbitrary: q)
    case Nil
    then show ?case by auto
  next
    case (Cons io ios)
    then obtain t where "t \<in> h M" and "t_source t = q" and "t_input t = fst io" and "t_output t = snd io" and "contains_io_sequence M (t_target t) ios"
      unfolding contains_io_sequence_def by auto

    obtain p where "path M (t_target t) p" and "p_io p = ios"
      using Cons.IH[OF wf_transition_target[OF \<open>t \<in> h M\<close>] \<open>contains_io_sequence M (t_target t) ios\<close>] by blast

    have "path M q (t#p)"
      using \<open>path M (t_target t) p\<close> \<open>t \<in> h M\<close> \<open>t_source t = q\<close> by auto
    moreover have "p_io (t#p) = io#ios"
      using \<open>p_io p = ios\<close> \<open>t_input t = fst io\<close> \<open>t_output t = snd io\<close> by auto
    ultimately show ?case
      by auto
  qed

  then show ?thesis by auto
qed

lemma contains_io_sequence_exhaustiveness :
  assumes "io \<in> LS M q"
  shows "contains_io_sequence M q io"
proof -
  from assms obtain p where "length p = length io" and  "path M q p" and "p_io p = io"
    by auto
  then show ?thesis
  proof (induction p io arbitrary: q rule: list_induct2)
    case Nil
    then show ?case
      unfolding contains_io_sequence_def using contains_io_sequence'.simps(1) by auto
  next
    case (Cons t p io ios)
    then have "path M (t_target t) p" and "p_io p = ios"
      by auto

    then have "contains_io_sequence M (t_target t) ios"
      using Cons.IH by auto
    moreover have "t \<in> h M" and "t_source t = q" and "t_input t = fst io" and "t_output t = snd io"
      using Cons by auto
    ultimately have "t \<in> h M" and "t_source t = q \<and> t_input t = fst io \<and> t_output t = snd io \<and> contains_io_sequence' (h M) (t_target t) ios"
      unfolding contains_io_sequence_def using Cons by auto

    then show ?case
      unfolding contains_io_sequence_def contains_io_sequence'.simps by blast
  qed
qed

lemma contains_io_sequence_intersection :
  assumes "q \<in> nodes M"
shows "set xs \<inter> LS M q = set (filter (contains_io_sequence M q) xs)"
  using contains_io_sequence_soundness[OF assms] contains_io_sequence_exhaustiveness[of _ M q]
  by force

lemma contains_io_sequence_intersection_initial :
shows "set xs \<inter> L M = set (filter (contains_io_sequence M (initial M)) xs)"
  using contains_io_sequence_intersection[OF nodes.initial] by assumption

lemma contains_io_sequence_intersection_initial_set :
  "A \<inter> L M = { x \<in> A . contains_io_sequence M (initial M) x}"
  using contains_io_sequence_soundness[OF nodes.initial] contains_io_sequence_exhaustiveness[of _ M "initial M"]
  by force

(* TODO: reevaluate necessity, if traversal paths are used, then no such function is required here *)
(*

fun io_target' :: "'a Transition list \<Rightarrow> 'a \<Rightarrow> IO_Sequence \<Rightarrow> 'a option" where
  "io_target' H q [] = Some q" |
  "io_target' H q (io#ios) = (case find (\<lambda> t . t_source t = q \<and> t_input t = fst io \<and> t_output t = snd io) H of
    Some t \<Rightarrow> io_target' H (t_target t) ios |
    None   \<Rightarrow> None)"

value "io_target' (wf_transitions M_ex_H) 1 [(0,0)]"
value "io_target' (wf_transitions M_ex_H) 1 [(0,1),(0,0)]"
value "io_target' (wf_transitions M_ex_H) 1 [(0,1),(0,0),(0,1),(0,0),(0,1),(0,0),(0,1),(0,0)]"
value "io_target' (wf_transitions M_ex_H) 1 [(0,1),(0,0),(0,1),(0,0),(0,1),(0,0),(0,1),(0,0),(0,0)]"

definition io_target_opt :: "('a,'b) FSM_scheme \<Rightarrow> 'a \<Rightarrow> IO_Sequence \<Rightarrow> 'a option" where
  "io_target_opt M q io = io_target' (wf_transitions M) q io"

lemma io_target_soundness :
  assumes "q \<in> nodes M"
  and     "io_target_opt M q io = Some q'"
shows "\<exists> p . path M q p \<and> p_io p = io \<and> target p q = q'"
  using assms proof (induction io arbitrary: q q')
    case Nil
    then show ?case unfolding io_target_opt_def by auto
  next
    case (Cons io ios)

    obtain t where "t \<in> h M" and "t_source t = q" and "t_input t = fst io" and "t_output t = snd io" and "io_target_opt M (t_target t) ios = Some q'"

    proof (cases "find (\<lambda>t. t_source t = q \<and> t_input t = fst io \<and> t_output t = snd io) (wf_transitions M)")
      case None
      then show ?thesis
        using Cons.IH[OF Cons.prems(1)] Cons.prems(2)
        unfolding io_target_opt_def io_target'.simps by auto
    next
      case (Some a)
      then have "io_target' (wf_transitions M) (t_target a) ios = Some q'"
        using  Cons.prems(2)
        unfolding io_target_opt_def io_target'.simps by auto
      then show ?thesis
          using Cons.IH[of "t_target a" q']

    qed

    obtain p where "path M (t_target t) p" and "p_io p = ios"
      using Cons.IH[OF wf_transition_target[OF \<open>t \<in> h M\<close>] \<open>contains_io_sequence M (t_target t) ios\<close>] by blast

    have "path M q (t#p)"
      using \<open>path M (t_target t) p\<close> \<open>t \<in> h M\<close> \<open>t_source t = q\<close> by auto
    moreover have "p_io (t#p) = io#ios"
      using \<open>p_io p = ios\<close> \<open>t_input t = fst io\<close> \<open>t_output t = snd io\<close> by auto
    ultimately show ?case
      by auto
  qed

  then show ?thesis by auto
qed
*)

(* TODO: only apply fail sequences? state_separation_fail_sequence_set_from_state_separator *)
(* TODO: implement faster state_separation_fail_sequence_set_from_state_separator using the above function instead of calculating L M *)

(* after each traversal sequence all state separators that r-d the reached state from some other state are added *)
(* TODO: add only relevant separators *)
fun test_suite_naive :: "('a,'b) FSM_scheme \<Rightarrow> nat \<Rightarrow> Test_Case' list" where
  "test_suite_naive M m = (let qqSS = r_distinguishable_state_pairs_with_separators_naive M;
                               MRS = maximal_repetition_sets_from_separators M;
                               Q = map
                                    (\<lambda> qp . (snd qp, map
                                              (\<lambda> t . (p_io t, concat (map
                                                          (\<lambda> qqS . LS_acyclic_opt (snd qqS))
                                                          (filter
                                                                  (\<lambda> qqS . fst (fst qqS) = target t (fst qp))
                                                                  qqSS))))
                                              (m_traversal_paths M (fst qp) MRS m)))
                                    (d_reachable_states_with_preambles M)

                          in Q)"

value "test_suite_naive M_ex_H 4"
value "test_suite_naive M_ex_9 4"

end


(*
 * Title:      Decreasing Diagrams II
 * Author:     Bertram Felgenhauer (2015)
 * Maintainer: Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at>
 * License:    LGPL
 *)
section \<open>Decreasing Diagrams\<close>

theory Decreasing_Diagrams_II
imports
  Decreasing_Diagrams_II_Aux
  "HOL-Cardinals.Wellorder_Extension"
  "Abstract-Rewriting.Abstract_Rewriting"
begin

subsection \<open>Greek accents\<close>

datatype accent = Acute | Grave | Macron

lemma UNIV_accent: "UNIV = { Acute, Grave, Macron }"
using accent.nchotomy by blast

lemma finite_accent: "finite (UNIV :: accent set)"
by (simp add: UNIV_accent)

type_synonym 'a letter = "accent \<times> 'a"

definition letter_less :: "('a \<times> 'a) set \<Rightarrow> ('a letter \<times> 'a letter) set" where
  [simp]: "letter_less R = {(a,b). (snd a, snd b) \<in> R}"

lemma mono_letter_less: "mono letter_less"
by (auto simp add: mono_def)

subsection \<open>Comparing Greek strings\<close>

type_synonym 'a greek = "'a letter list"

definition adj_msog :: "'a greek \<Rightarrow> 'a greek \<Rightarrow> ('a letter \<times> 'a greek) \<Rightarrow> ('a letter \<times> 'a greek)"
where
  "adj_msog xs zs l \<equiv>
    case l of (y,ys) \<Rightarrow> (y, case fst y of Acute \<Rightarrow> ys @ zs | Grave \<Rightarrow> xs @ ys | Macron \<Rightarrow> ys)"

definition ms_of_greek :: "'a greek \<Rightarrow> ('a letter \<times> 'a greek) multiset" where
  "ms_of_greek as = mset
    (map (\<lambda>(xs, y, zs) \<Rightarrow> adj_msog xs zs (y, [])) (list_splits as))"

lemma adj_msog_adj_msog[simp]:
  "adj_msog xs zs (adj_msog xs' zs' y) = adj_msog (xs @ xs') (zs' @ zs) y"
by (auto simp: adj_msog_def split: accent.splits prod.splits)

lemma compose_adj_msog[simp]: "adj_msog xs zs \<circ> adj_msog xs' zs' = adj_msog (xs @ xs') (zs' @ zs)"
by (simp add: comp_def)

lemma adj_msog_single:
  "adj_msog xs zs (x,[]) = (x, (case fst x of Grave \<Rightarrow> xs | Acute \<Rightarrow> zs | Macron \<Rightarrow> []))"
by (simp add: adj_msog_def split: accent.splits)

lemma ms_of_greek_elem:
  assumes "(x,xs) \<in> set_mset (ms_of_greek ys)"
  shows "x \<in> set ys"
using assms by (auto dest: elem_list_splits_elem simp: adj_msog_def ms_of_greek_def)

lemma ms_of_greek_shorter:
  assumes "(x, t) \<in># ms_of_greek s"
  shows "length s > length t"
using assms[unfolded ms_of_greek_def in_multiset_in_set]
by (auto simp: elem_list_splits_length adj_msog_def split: accent.splits)

lemma msog_append: "ms_of_greek (xs @ ys) = image_mset (adj_msog [] ys) (ms_of_greek xs) +
  image_mset (adj_msog xs []) (ms_of_greek ys)"
by (auto simp: ms_of_greek_def list_splits_append multiset.map_comp comp_def prod.case_distrib)

definition nest :: "('a \<times> 'a) set \<Rightarrow> ('a greek \<times> 'a greek) set \<Rightarrow> ('a greek \<times> 'a greek) set" where
  [simp]: "nest r s = {(a,b). (ms_of_greek a, ms_of_greek b) \<in> mult (letter_less r <*lex*> s)}"

lemma mono_nest: "mono (nest r)"
unfolding mono_def
proof (intro allI impI subsetI)
  fix R S x
  assume 1: "R \<subseteq> S" and 2: "x \<in> nest r R"
  from 1 have "mult (letter_less r <*lex*> R) \<subseteq> mult (letter_less r <*lex*> S)"
  using mono_mult mono_lex2[of "letter_less r"] unfolding mono_def by blast
  with 2 show "x \<in> nest r S" by auto
qed

lemma nest_mono[mono_set]: "x \<subseteq> y \<Longrightarrow> (a,b) \<in> nest r x \<longrightarrow> (a,b) \<in> nest r y"
using mono_nest[unfolded mono_def, rule_format, of x y r] by blast

definition greek_less :: "('a \<times> 'a) set \<Rightarrow> ('a greek \<times> 'a greek) set" where
  "greek_less r = lfp (nest r)"

lemma greek_less_unfold:
  "greek_less r = nest r (greek_less r)"
using mono_nest[of r] lfp_unfold[of "nest r"] by (simp add: greek_less_def)

subsection \<open>Preservation of strict partial orders\<close>

lemma strict_order_letter_less:
  assumes "strict_order r"
  shows "strict_order (letter_less r)"
using assms unfolding irrefl_def trans_def letter_less_def by fast

lemma strict_order_nest:
  assumes r: "strict_order r" and R: "strict_order R"
  shows "strict_order (nest r R)"
proof -
  have "strict_order (mult (letter_less r <*lex*> R))"
  using strict_order_letter_less[of r] irrefl_lex_prod[of "letter_less r" R]
    trans_lex_prod[of "letter_less r" R] strict_order_mult[of "letter_less r <*lex*> R"] assms
  by fast
  from this show "strict_order (nest r R)" unfolding nest_def trans_def irrefl_def by fast
qed

lemma strict_order_greek_less:
  assumes "strict_order r"
  shows "strict_order (greek_less r)"
by (simp add: greek_less_def strict_order_lfp[OF mono_nest strict_order_nest[OF assms]])

lemma trans_letter_less:
  assumes "trans r"
  shows "trans (letter_less r)"
using assms unfolding trans_def letter_less_def by fast

lemma trans_order_nest: "trans (nest r R)"
using trans_mult unfolding nest_def trans_def by fast

lemma trans_greek_less[simp]: "trans (greek_less r)"
by (subst greek_less_unfold) (rule trans_order_nest)

lemma mono_greek_less: "mono greek_less"
unfolding greek_less_def mono_def
proof (intro allI impI lfp_mono)
  fix r s :: "('a \<times> 'a) set" and R :: "('a greek \<times> 'a greek) set"
  assume "r \<subseteq> s"
  then have "letter_less r <*lex*> R \<subseteq> letter_less s <*lex*> R"
  using mono_letter_less mono_lex1 unfolding mono_def by metis
  then show "nest r R \<subseteq> nest s R" using mono_mult unfolding nest_def mono_def by blast
qed

subsection \<open>Involution\<close>

definition inv_letter :: "'a letter \<Rightarrow> 'a letter" where
  "inv_letter l \<equiv>
    case l of (a, x) \<Rightarrow> (case a of Grave \<Rightarrow> Acute | Acute \<Rightarrow> Grave | Macron \<Rightarrow> Macron, x)"

lemma inv_letter_pair[simp]:
  "inv_letter (a, x) = (case a of Grave \<Rightarrow> Acute | Acute \<Rightarrow> Grave | Macron \<Rightarrow> Macron, x)"
by (simp add: inv_letter_def)

lemma snd_inv_letter[simp]:
  "snd (inv_letter x) = snd x"
by (simp add: inv_letter_def split: prod.splits)

lemma inv_letter_invol[simp]:
  "inv_letter (inv_letter x) = x"
by (simp add: inv_letter_def split: prod.splits accent.splits)

lemma inv_letter_mono[simp]:
  assumes "(x, y) \<in> letter_less r"
  shows "(inv_letter x, inv_letter y) \<in> letter_less r"
using assms by simp

definition inv_greek :: "'a greek \<Rightarrow> 'a greek" where
  "inv_greek s = rev (map inv_letter s)"

lemma inv_greek_invol[simp]:
  "inv_greek (inv_greek s) = s"
by (simp add: inv_greek_def rev_map comp_def)

lemma inv_greek_append:
  "inv_greek (s @ t) = inv_greek t @ inv_greek s"
by (simp add: inv_greek_def)

definition inv_msog :: "('a letter \<times> 'a greek) multiset \<Rightarrow> ('a letter \<times> 'a greek) multiset" where
  "inv_msog M = image_mset (\<lambda>(x, t). (inv_letter x, inv_greek t)) M"

lemma inv_msog_invol[simp]:
  "inv_msog (inv_msog M) = M"
by (simp add: inv_msog_def multiset.map_comp comp_def prod.case_distrib)

lemma ms_of_greek_inv_greek:
  "ms_of_greek (inv_greek M) = inv_msog (ms_of_greek M)"
unfolding inv_msog_def inv_greek_def ms_of_greek_def list_splits_rev list_splits_map mset_map
  multiset.map_comp mset_rev inv_letter_def adj_msog_def
by (rule cong[OF cong[OF refl[of "image_mset"]] refl]) (auto split: accent.splits)

lemma inv_greek_mono:
  assumes "trans r" and "(s, t) \<in> greek_less r"
  shows "(inv_greek s, inv_greek t) \<in> greek_less r"
using assms(2)
proof (induct "length s + length t" arbitrary: s t rule: less_induct)
  note * = trans_lex_prod[OF trans_letter_less[OF \<open>trans r\<close>] trans_greek_less[of r]]
  case (less s t)
  have "(inv_msog (ms_of_greek s), inv_msog (ms_of_greek t)) \<in> mult (letter_less r <*lex*> greek_less r)"
  unfolding inv_msog_def
  proof (induct rule: mult_of_image_mset[OF * *])
    case (1 x y) thus ?case
    by (auto intro: less(1) split: prod.splits dest!: ms_of_greek_shorter)
  next
    case 2 thus ?case using less(2) by (subst(asm) greek_less_unfold) simp
  qed
  thus ?case by (subst greek_less_unfold) (auto simp: ms_of_greek_inv_greek)
qed

subsection \<open>Monotonicity of @{term "greek_less r"}\<close>

lemma greek_less_rempty[simp]:
  "(a,[]) \<in> greek_less r \<longleftrightarrow> False"
by (subst greek_less_unfold) (auto simp: ms_of_greek_def)

lemma greek_less_nonempty:
  assumes "b \<noteq> []"
  shows "(a,b) \<in> greek_less r \<longleftrightarrow> (a,b) \<in> nest r (greek_less r)"
by (subst greek_less_unfold) simp

lemma greek_less_lempty[simp]:
  "([],b) \<in> greek_less r \<longleftrightarrow> b \<noteq> []"
proof
  assume "([],b) \<in> greek_less r"
  then show "b \<noteq> []" using greek_less_rempty by fast
next
  assume "b \<noteq> []"
  then show "([],b) \<in> greek_less r"
  unfolding greek_less_nonempty[OF \<open>b \<noteq> []\<close>] by (simp add: ms_of_greek_def)
qed

lemma greek_less_singleton:
  "(a, b) \<in> letter_less r \<Longrightarrow> ([a], [b]) \<in> greek_less r"
by (subst greek_less_unfold) (auto split: accent.splits simp: adj_msog_def ms_of_greek_def)

lemma ms_of_greek_cons:
  "ms_of_greek (x # s) = {# adj_msog [] s (x,[]) #} + image_mset (adj_msog [x] []) (ms_of_greek s)"
using msog_append[of "[x]" s]
by (auto simp add: adj_msog_def ms_of_greek_def accent.splits)

lemma greek_less_cons_mono:
  assumes "trans r"
  shows "(s, t) \<in> greek_less r \<Longrightarrow> (x # s, x # t) \<in> greek_less r"
proof (induct "length s + length t" arbitrary: s t rule: less_induct)
  note * = trans_lex_prod[OF trans_letter_less[OF \<open>trans r\<close>] trans_greek_less[of r]]
  case (less s t)
  {
    fix M have "(M + image_mset (adj_msog [x] []) (ms_of_greek s),
      M + image_mset (adj_msog [x] []) (ms_of_greek t)) \<in> mult (letter_less r <*lex*> greek_less r)"
    proof (rule mult_on_union, induct rule: mult_of_image_mset[OF * *])
      case (1 x y) thus ?case unfolding adj_msog_def
      by (auto intro: less(1) split: prod.splits accent.splits dest!: ms_of_greek_shorter)
    next
      case 2 thus ?case using less(2) by (subst(asm) greek_less_unfold) simp
    qed
  }
  moreover {
    fix N have "({# adj_msog [] s (x,[]) #} + N,{# adj_msog [] t (x,[]) #} + N) \<in>
      (mult (letter_less r <*lex*> greek_less r))\<^sup>="
    by (auto simp: adj_msog_def less split: accent.splits) }
  ultimately show ?case using transD[OF trans_mult]
  by (subst greek_less_unfold) (fastforce simp: ms_of_greek_cons)
qed

lemma greek_less_app_mono2:
  assumes "trans r" and "(s, t) \<in> greek_less r"
  shows "(p @ s, p @ t) \<in> greek_less r"
using assms by (induct p) (auto simp add: greek_less_cons_mono)

lemma greek_less_app_mono1:
  assumes "trans r" and "(s, t) \<in> greek_less r"
  shows "(s @ p, t @ p) \<in> greek_less r"
using inv_greek_mono[of r "inv_greek p @ inv_greek s" "inv_greek p @ inv_greek t"]
by (simp add: assms inv_greek_append inv_greek_mono greek_less_app_mono2)

subsection \<open>Well-founded-ness of @{term "greek_less r"}\<close>

lemma greek_embed:
  assumes "trans r"
  shows "list_emb (\<lambda>a b. (a, b): reflcl (letter_less r)) a b \<Longrightarrow> (a, b) \<in> reflcl (greek_less r)"
proof (induct rule: list_emb.induct)
  case (list_emb_Cons a b y) thus ?case
  using trans_greek_less[unfolded trans_def] \<open>trans r\<close>
    greek_less_app_mono1[of r "[]" "[y]" a] greek_less_app_mono2[of r a b "[y]"] by auto
next
  case (list_emb_Cons2 x y a b) thus ?case
  using trans_greek_less[unfolded trans_def] \<open>trans r\<close> greek_less_singleton[of x y r]
    greek_less_app_mono1[of r "[x]" "[y]" a] greek_less_app_mono2[of r a b "[y]"] by auto
qed simp

lemma wqo_letter_less:
  assumes t: "trans r" and w: "wqo_on (\<lambda>a b. (a, b) \<in> r\<^sup>=) UNIV"
  shows "wqo_on (\<lambda>a b. (a, b) \<in> (letter_less r)\<^sup>=) UNIV"
proof (rule wqo_on_hom[of _ id _ "prod_le (=) (\<lambda>a b. (a, b) \<in> r\<^sup>=)", unfolded image_id id_apply])
  show "wqo_on (prod_le ((=) :: accent \<Rightarrow> accent \<Rightarrow> bool) (\<lambda>a b. (a, b) \<in> r\<^sup>=)) UNIV"
  by (rule dickson[OF finite_eq_wqo_on[OF finite_accent] w, unfolded UNIV_Times_UNIV])
qed (insert t, auto simp: transp_on_def trans_def prod_le_def)

lemma wf_greek_less:
  assumes "wf r" and "trans r"
  shows "wf (greek_less r)"
proof -
  obtain q where "r \<subseteq> q" and "well_order q" by (metis total_well_order_extension \<open>wf r\<close>)
  define q' where "q' = q - Id"
  from \<open>well_order q\<close> have "reflcl q' = q"
  by (auto simp add: well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def
      refl_on_def q'_def)
  from \<open>well_order q\<close> have "trans q'" and "irrefl q'"
  unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def antisym_def
    trans_def irrefl_def q'_def by blast+
  from \<open>r \<subseteq> q\<close> \<open>wf r\<close> have "r \<subseteq> q'" by (auto simp add: q'_def)
  have "wqo_on (\<lambda>a b. (a,b) \<in> (greek_less q')\<^sup>=) UNIV"
  proof (intro wqo_on_hom[of "(\<lambda>a b. (a, b) \<in> (greek_less q')\<^sup>=)" "id" UNIV
         "list_emb (\<lambda>a b. (a, b) \<in> (letter_less q')\<^sup>=)", unfolded surj_id])
    show "transp_on (\<lambda>a b. (a, b) \<in> (greek_less q')\<^sup>=) UNIV"
    using trans_greek_less[of q'] unfolding trans_def transp_on_def by blast
  next
    show "\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. list_emb (\<lambda>a b. (a, b) \<in> (letter_less q')\<^sup>=) x y \<longrightarrow>
          (id x, id y) \<in> (greek_less q')\<^sup>="
    using greek_embed[OF \<open>trans q'\<close>] by auto
  next
    show "wqo_on (list_emb (\<lambda>a b. (a, b) \<in> (letter_less q')\<^sup>=)) UNIV"
    using higman[OF wqo_letter_less[OF \<open>trans q'\<close>]] \<open>well_order q\<close> \<open>reflcl q' = q\<close>
    by (auto simp: well_order_implies_wqo)
  qed
  with wqo_on_imp_wfp_on[OF this] strict_order_strict[OF strict_order_greek_less]
    \<open>irrefl q'\<close> \<open>trans q'\<close>
  have "wfp_on (\<lambda>a b. (a, b) \<in> greek_less q') UNIV" by force
  then show ?thesis
  using mono_greek_less \<open>r \<subseteq> q'\<close> wf_subset unfolding wf_iff_wfp_on[symmetric] mono_def by metis
qed

subsection \<open>Basic Comparisons\<close>

lemma pairwise_imp_mult:
  assumes "N \<noteq> {#}" and "\<forall>x \<in> set_mset M. \<exists>y \<in> set_mset N. (x, y) \<in> r"
  shows "(M, N) \<in> mult r"
using assms one_step_implies_mult[of _ _ _ "{#}"] by auto

lemma singleton_greek_less:
  assumes as: "snd ` set as \<subseteq> under r b"
  shows "(as, [(a,b)]) \<in> greek_less r"
proof -
  {
    fix e assume "e \<in> set_mset (ms_of_greek as)"
    with as ms_of_greek_elem[of _ _ as]
    have "(e, ((a,b),[])) \<in> letter_less r <*lex*> greek_less r"
    by (cases e) (fastforce simp: adj_msog_def under_def)
  }
  moreover have "ms_of_greek [(a,b)] = {# ((a,b),[]) #}"
  by (auto simp: ms_of_greek_def adj_msog_def split: accent.splits)
  ultimately show ?thesis
  by (subst greek_less_unfold) (auto intro!: pairwise_imp_mult)
qed

lemma peak_greek_less:
  assumes as: "snd ` set as \<subseteq> under r a" and b': "b' \<in> {[(Grave,b)],[]}"
  and cs: "snd ` set cs \<subseteq> under r a \<union> under r b" and a': "a' \<in> {[(Acute,a)],[]}"
  and bs: "snd ` set bs \<subseteq> under r b"
  shows "(as @ b' @ cs @ a' @ bs, [(Acute,a),(Grave,b)]) \<in> greek_less r"
proof -
  let ?A = "(Acute,a)" and ?B = "(Grave,b)"
  have "(ms_of_greek (as @ b' @ cs @ a' @ bs), ms_of_greek [?A,?B]) \<in> mult (letter_less r <*lex*> greek_less r)"
  proof (intro pairwise_imp_mult)
    (* we distinguish 5 cases depending on where in xs an element e originates *)
    {
      fix e assume "e \<in> set_mset (ms_of_greek as)"
      with as ms_of_greek_elem[of _ _ as]
      have "(adj_msog [] (b' @ cs @ a' @ bs) e, (?A,[?B])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def under_def)
    }
    moreover {
      fix e assume "e \<in> set_mset (ms_of_greek b')"
      with b' singleton_greek_less[OF as] ms_of_greek_elem[of _ _ b']
      have "(adj_msog as (cs @ a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
    }
    moreover {
      fix e assume "e \<in> set_mset (ms_of_greek cs)"
      with cs ms_of_greek_elem[of _ _ cs]
      have "(adj_msog (as @ b') (a' @ bs) e, (?A,[?B])) \<in> letter_less r <*lex*> greek_less r \<or>
            (adj_msog (as @ b') (a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def under_def)
    }
    moreover {
      fix e assume "e \<in> set_mset (ms_of_greek a')"
      with a' singleton_greek_less[OF bs] ms_of_greek_elem[of _ _ a']
      have "(adj_msog (as @ b' @ cs) bs e, (?A,[?B])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
    }
    moreover {
      fix e assume "e \<in> set_mset (ms_of_greek bs)"
      with bs ms_of_greek_elem[of _ _ bs]
      have "(adj_msog (as @ b' @ cs @ a') [] e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def under_def)
    }
    moreover have "ms_of_greek [?A,?B] = {# (?B,[?A]), (?A,[?B]) #}"
    by (simp add: adj_msog_def ms_of_greek_def)
    ultimately show "\<forall>x\<in>set_mset (ms_of_greek (as @ b' @ cs @ a' @ bs)).
      \<exists>y\<in>set_mset (ms_of_greek [?A,?B]). (x, y) \<in> letter_less r <*lex*> greek_less r"
    by (auto simp: msog_append) blast
  qed (auto simp: ms_of_greek_def)
  then show ?thesis by (subst greek_less_unfold) auto
qed

lemma rcliff_greek_less1:
  assumes "trans r" (* unused assumption kept for symmetry with lcliff_greek_less1 *)
  and as: "snd ` set as \<subseteq> under r a \<inter> under r b" and b': "b' \<in> {[(Grave,b)],[]}"
  and cs: "snd ` set cs \<subseteq> under r b" and a': "a' = [(Macron,a)]"
  and bs: "snd ` set bs \<subseteq> under r b"
  shows "(as @ b' @ cs @ a' @ bs, [(Macron,a),(Grave,b)]) \<in> greek_less r"
proof -
  let ?A = "(Macron,a)" and ?B = "(Grave,b)"
  have *: "ms_of_greek [?A,?B] = {#(?B,[?A]), (?A,[])#}" "ms_of_greek [?A] = {#(?A,[])#}"
  by (simp_all add: ms_of_greek_def adj_msog_def)
  then have **: "ms_of_greek [(Macron, a), (Grave, b)] - {#((Macron, a), [])#} \<noteq> {#}"
  by (auto)
  (* we distinguish 5 cases depending on where in xs an element e originates *)
  {
    fix e assume "e \<in> set_mset (ms_of_greek as)"
    with as ms_of_greek_elem[of _ _ as]
    have "(adj_msog [] (b' @ cs @ a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
    by (cases e) (force simp: adj_msog_def under_def)
  }
  moreover {
    fix e assume "e \<in> set_mset (ms_of_greek b')"
    with b' singleton_greek_less as ms_of_greek_elem[of _ _ b']
    have "(adj_msog as (cs @ a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
    by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
  }
  moreover {
    fix e assume "e \<in> set_mset (ms_of_greek cs)"
    with cs ms_of_greek_elem[of _ _ cs]
    have "(adj_msog (as @ b') (a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
    by (cases e) (fastforce simp: adj_msog_def under_def)
  }
  moreover {
    fix e assume "e \<in> set_mset (ms_of_greek bs)"
    with bs ms_of_greek_elem[of _ _ bs]
    have "(adj_msog (as @ b' @ cs @ a') [] e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
    by (cases e) (fastforce simp: adj_msog_def under_def)
  }
  moreover have "ms_of_greek [?A,?B] = {# (?B,[?A]), (?A,[]) #}"
  by (simp add: adj_msog_def ms_of_greek_def)
  ultimately have "\<forall>x\<in>set_mset (ms_of_greek (as @ b' @ cs @ a' @ bs) - {#(?A,[])#}).
    \<exists>y\<in>set_mset (ms_of_greek [?A,?B] - {#(?A,[])#}). (x, y) \<in> letter_less r <*lex*> greek_less r"
  unfolding msog_append by (auto simp: a' msog_append ac_simps * adj_msog_single)
  from one_step_implies_mult[OF ** this,of "{#(?A,[])#}"]
  have "(ms_of_greek (as @ b' @ cs @ a' @ bs), ms_of_greek [?A,?B]) \<in> mult (letter_less r <*lex*> greek_less r)"
  unfolding a' msog_append by (auto simp: a' ac_simps * adj_msog_single)
  then show ?thesis
  by (subst greek_less_unfold) auto
qed

lemma rcliff_greek_less2:
  assumes "trans r" (* unused assumption kept for symmetry with lcliff_greek_less2 *)
  and as: "snd ` set as \<subseteq> under r a" and b': "b' \<in> {[(Grave,b)],[]}"
  and cs: "snd ` set cs \<subseteq> under r a \<union> under r b"
  shows "(as @ b' @ cs, [(Macron,a),(Grave,b)]) \<in> greek_less r"
proof -
  let ?A = "(Macron,a)" and ?B = "(Grave,b)"
  have "(ms_of_greek (as @ b' @ cs), ms_of_greek [?A,?B]) \<in> mult (letter_less r <*lex*> greek_less r)"
  proof (intro pairwise_imp_mult)
    (* we distinguish 3 cases depending on where in xs an element e originates *)
    {
      fix e assume "e \<in> set_mset (ms_of_greek as)"
      with as ms_of_greek_elem[of _ _ as]
      have "(adj_msog [] (b' @ cs) e, (?A,[])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def under_def)
    }
    moreover {
      fix e assume "e \<in> set_mset (ms_of_greek b')"
      with b' singleton_greek_less[OF as] ms_of_greek_elem[of _ _ b']
      have "(adj_msog as (cs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
    }
    moreover {
      fix e assume "e \<in> set_mset (ms_of_greek cs)"
      with cs ms_of_greek_elem[of _ _ cs]
      have "(adj_msog (as @ b') [] e, (?A,[])) \<in> letter_less r <*lex*> greek_less r \<or>
            (adj_msog (as @ b') [] e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
      by (cases e) (fastforce simp: adj_msog_def under_def)
    }
    moreover have *: "ms_of_greek [?A,?B] = {# (?B,[?A]), (?A,[]) #}"
    by (simp add: adj_msog_def ms_of_greek_def)
    ultimately show "\<forall>x\<in>set_mset (ms_of_greek (as @ b' @ cs)).
      \<exists>y\<in>set_mset (ms_of_greek [?A,?B]). (x, y) \<in> letter_less r <*lex*> greek_less r"
    by (auto simp: msog_append adj_msog_single ac_simps *) blast
  qed (auto simp: ms_of_greek_def)
  then show ?thesis by (subst greek_less_unfold) auto
qed

lemma snd_inv_greek [simp]: "snd ` set (inv_greek as) = snd ` set as"
by (force simp: inv_greek_def)

lemma lcliff_greek_less1:
  assumes "trans r"
  and as: "snd ` set as \<subseteq> under r a" and b': "b' = [(Macron,b)]"
  and cs: "snd ` set cs \<subseteq> under r a" and a': "a' \<in> {[(Acute,a)],[]}"
  and bs: "snd ` set bs \<subseteq> under r a \<inter> under r b"
  shows "(as @ b' @ cs @ a' @ bs, [(Acute,a),(Macron,b)]) \<in> greek_less r"
proof -
  have *: "inv_greek [(Acute,a),(Macron,b)] = [(Macron,b),(Grave,a)]" by (simp add: inv_greek_def)
  have "(inv_greek (inv_greek (as @ b' @ cs @ a' @ bs)),
   inv_greek (inv_greek ([(Acute,a),(Macron,b)]))) \<in> greek_less r"
   apply (rule inv_greek_mono[OF \<open>trans r\<close>])
   apply (unfold inv_greek_append append_assoc *)
   apply (insert assms)
   apply (rule rcliff_greek_less1, auto simp: inv_greek_def)
  done
  then show ?thesis by simp
qed

lemma lcliff_greek_less2:
  assumes "trans r"
  and cs: "snd ` set cs \<subseteq> under r a \<union> under r b" and a': "a' \<in> {[(Acute,a)],[]}"
  and bs: "snd ` set bs \<subseteq> under r b"
  shows "(cs @ a' @ bs, [(Acute,a),(Macron,b)]) \<in> greek_less r"
proof -
  have *: "inv_greek [(Acute,a),(Macron,b)] = [(Macron,b),(Grave,a)]" by (simp add: inv_greek_def)
  have "(inv_greek (inv_greek (cs @ a' @ bs)),
    inv_greek (inv_greek ([(Acute,a),(Macron,b)]))) \<in> greek_less r"
   apply (rule inv_greek_mono[OF \<open>trans r\<close>])
   apply (unfold inv_greek_append append_assoc *)
   apply (insert assms)
   apply (rule rcliff_greek_less2, auto simp: inv_greek_def)
  done
  then show ?thesis by simp
qed

subsection \<open>Labeled abstract rewriting\<close>

context
  fixes L R E :: "'b \<Rightarrow> 'a rel"
begin

definition lstep :: "'b letter \<Rightarrow> 'a rel" where
  [simp]: "lstep x = (case x of (a, i) \<Rightarrow> (case a of Acute \<Rightarrow> (L i)\<inverse> | Grave \<Rightarrow> R i | Macron \<Rightarrow> E i))"

fun lconv :: "'b greek \<Rightarrow> 'a rel" where
  "lconv [] = Id"
| "lconv (x # xs) = lstep x O lconv xs"

lemma lconv_append[simp]:
  "lconv (xs @ ys) = lconv xs O lconv ys"
by (induct xs) auto

lemma conversion_join_or_peak_or_cliff:
  obtains (join) as bs cs where "set as \<subseteq> {Grave}" and "set bs \<subseteq> {Macron}" and "set cs \<subseteq> {Acute}"
    and "ds = as @ bs @ cs"
  | (peak) as bs where "ds = as @ ([Acute] @ [Grave]) @ bs"
  | (lcliff) as bs where "ds = as @ ([Acute] @ [Macron]) @ bs"
  | (rcliff) as bs where "ds = as @ ([Macron] @ [Grave]) @ bs"
proof (induct ds arbitrary: thesis)
  case (Cons d ds thesis) note IH = this show ?case
  proof (rule IH(1))
    fix as bs assume "ds = as @ ([Acute] @ [Grave]) @ bs" then show ?case
    using IH(3)[of "d # as" bs] by simp
  next
    fix as bs assume "ds = as @ ([Acute] @ [Macron]) @ bs" then show ?case
    using IH(4)[of "d # as" bs] by simp
  next
    fix as bs assume "ds = as @ ([Macron] @ [Grave]) @ bs" then show ?case
    using IH(5)[of "d # as" bs] by simp
  next
    fix as bs cs assume *: "set as \<subseteq> {Grave}" "set bs \<subseteq> {Macron}" "set cs \<subseteq> {Acute}" "ds = as @ bs @ cs"
    show ?case
    proof (cases d)
      case Grave thus ?thesis using * IH(2)[of "d # as" bs cs] by simp
    next
      case Macron show ?thesis
      proof (cases as)
        case Nil thus ?thesis using * Macron IH(2)[of as "d # bs" cs] by simp
      next
        case (Cons a as) thus ?thesis using * Macron IH(5)[of "[]" "as @ bs @ cs"] by simp
      qed
    next
      case Acute show ?thesis
      proof (cases as)
        case Nil note as = this show ?thesis
        proof (cases bs)
          case Nil thus ?thesis using * as Acute IH(2)[of "[]" "[]" "d # cs"] by simp
        next
          case (Cons b bs) thus ?thesis using * as Acute IH(4)[of "[]" "bs @ cs"] by simp
        qed
      next
        case (Cons a as) thus ?thesis using * Acute IH(3)[of "[]" "as @ bs @ cs"] by simp
      qed
    qed
  qed
qed auto

lemma map_eq_append_split:
  assumes "map f xs = ys1 @ ys2"
  obtains xs1 xs2 where "ys1 = map f xs1" "ys2 = map f xs2" "xs = xs1 @ xs2"
proof (insert assms, induct ys1 arbitrary: xs thesis)
  case (Cons y ys) note IH = this show ?case
  proof (cases xs)
    case (Cons x xs') show ?thesis
    proof (rule IH(1))
      fix xs1 xs2 assume "ys = map f xs1" "ys2 = map f xs2" "xs' = xs1 @ xs2" thus ?thesis
      using Cons IH(2)[of "x # xs1" xs2] IH(3) by simp
    next
      show "map f xs' = ys @ ys2" using Cons IH(3) by simp
    qed
  qed (insert Cons, simp)
qed auto

lemmas map_eq_append_splits = map_eq_append_split map_eq_append_split[OF sym]

abbreviation "conversion' M \<equiv> ((\<Union>i \<in> M. R i) \<union> (\<Union>i \<in> M. E i) \<union> (\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"
abbreviation "valley' M \<equiv>  (\<Union>i \<in> M. R i)\<^sup>* O (\<Union>i \<in> M. E i)\<^sup>* O ((\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"

lemma conversion_to_lconv:
  assumes "(u, v) \<in> conversion' M"
  obtains xs where "snd ` set xs \<subseteq> M" and "(u, v) \<in> lconv xs"
using assms
proof (induct arbitrary: thesis rule: converse_rtrancl_induct)
  case base show ?case using base[of "[]"] by simp
next
  case (step u' x)
  from step(1) obtain p where "snd p \<in> M" and "(u', x) \<in> lstep p"
  by (force split: accent.splits)
  moreover obtain xs where "snd ` set xs \<subseteq> M" "(x, v) \<in> lconv xs" by (rule step(3))
  ultimately show ?case using step(4)[of "p # xs"] by auto
qed

definition lpeak :: "'b rel \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b greek \<Rightarrow> bool" where
  "lpeak r a b xs \<longleftrightarrow> (\<exists>as b' cs a' bs. snd ` set as \<subseteq> under r a \<and> b' \<in> {[(Grave,b)],[]} \<and>
    snd ` set cs \<subseteq> under r a \<union> under r b \<and> a' \<in> {[(Acute,a)],[]} \<and>
    snd ` set bs \<subseteq> under r b \<and> xs = as @ b' @ cs @ a' @ bs)"

definition lcliff :: "'b rel \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b greek \<Rightarrow> bool" where
  "lcliff r a b xs \<longleftrightarrow> (\<exists>as b' cs a' bs. snd ` set as \<subseteq> under r a \<and> b' = [(Macron,b)] \<and>
    snd ` set cs \<subseteq> under r a \<and> a' \<in> {[(Acute,a)],[]} \<and>
    snd ` set bs \<subseteq> under r a \<inter> under r b \<and> xs = as @ b' @ cs @ a' @ bs) \<or>
    (\<exists>cs a' bs. snd ` set cs \<subseteq> under r a \<union> under r b \<and> a' \<in> {[(Acute,a)],[]} \<and>
    snd ` set bs \<subseteq> under r b \<and> xs = cs @ a' @ bs)"

definition rcliff :: "'b rel \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b greek \<Rightarrow> bool" where
  "rcliff r a b xs \<longleftrightarrow> (\<exists>as b' cs a' bs. snd ` set as \<subseteq> under r a \<inter> under r b \<and> b' \<in> {[(Grave,b)],[]} \<and>
    snd ` set cs \<subseteq> under r b \<and> a' = [(Macron,a)] \<and>
    snd ` set bs \<subseteq> under r b \<and> xs = as @ b' @ cs @ a' @ bs) \<or>
    (\<exists>as b' cs. snd ` set as \<subseteq> under r a \<and> b' \<in> {[(Grave,b)],[]} \<and>
    snd ` set cs \<subseteq> under r a \<union> under r b \<and> xs = as @ b' @ cs)"

lemma dd_commute_modulo_conv[case_names wf trans peak lcliff rcliff]:
  assumes "wf r" and "trans r"
  and pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow> \<exists>xs. lpeak r a b xs \<and> (t, u) \<in> lconv xs"
  and lc: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> E b \<Longrightarrow> \<exists>xs. lcliff r a b xs \<and> (t, u) \<in> lconv xs"
  and rc: "\<And>a b s t u. (s, t) \<in> (E a)\<inverse> \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow> \<exists>xs. rcliff r a b xs \<and> (t, u) \<in> lconv xs"
  shows "conversion' UNIV \<subseteq> valley' UNIV"
proof (intro subrelI)
  fix u v
  assume "(u,v) \<in> conversion' UNIV"
  then obtain xs where "(u, v) \<in> lconv xs" by (auto intro: conversion_to_lconv[of u v])
  then show "(u, v) \<in> valley' UNIV"
  proof (induct xs rule: wf_induct[of "greek_less r"])
    case 1 thus ?case using wf_greek_less[OF \<open>wf r\<close> \<open>trans r\<close>] .
  next
    case (2 xs) show ?case
    proof (rule conversion_join_or_peak_or_cliff[of "map fst xs"])
      fix as bs cs
      assume *: "set as \<subseteq> {Grave}" "set bs \<subseteq> {Macron}" "set cs \<subseteq> {Acute}" "map fst xs = as @ bs @ cs"
      then show "(u, v) \<in> valley' UNIV"
      proof (elim map_eq_append_splits)
        fix as' bs' cs' bcs'
        assume as: "set as \<subseteq> {Grave}" "as = map fst as'" and
          bs: "set bs \<subseteq> {Macron}" "bs = map fst bs'" and
          cs: "set cs \<subseteq> {Acute}" "cs = map fst cs'" and
          xs: "xs = as' @ bcs'" "bcs' = bs' @ cs'"
        from as(1)[unfolded as(2)] have as': "\<And>x y. (x,y) \<in> lconv as' \<Longrightarrow> (x,y) \<in> (\<Union>a. R a)\<^sup>*"
        proof (induct as')
          case (Cons x' xs)
          have "\<And>x y z i. (x,y) \<in> R i \<Longrightarrow> (y,z) \<in> (\<Union>a. R a)\<^sup>* \<Longrightarrow> (x,z) \<in> (\<Union>a. R a)\<^sup>*"
          by (rule rtrancl_trans) auto
          with Cons show ?case by auto
        qed simp
        from bs(1)[unfolded bs(2)] have bs': "\<And>x y. (x,y) \<in> lconv bs' \<Longrightarrow> (x,y) \<in> (\<Union>a. E a)\<^sup>*"
        proof (induct bs')
          case (Cons x' xs)
          have "\<And>x y z i. (x,y) \<in> E i \<Longrightarrow> (y,z) \<in> (\<Union>a. E a)\<^sup>* \<Longrightarrow> (x,z) \<in> (\<Union>a. E a)\<^sup>*"
          by (rule rtrancl_trans) auto
          with Cons show ?case by auto
        qed simp
        from cs(1)[unfolded cs(2)] have cs': "\<And>x y. (x,y) \<in> lconv cs' \<Longrightarrow> (x,y) \<in> ((\<Union>a. L a)\<inverse>)\<^sup>*"
        proof (induct cs')
          case (Cons x' xs)
          have "\<And>x y z i. (x,y) \<in> (L i)\<inverse> \<Longrightarrow> (y,z) \<in> ((\<Union>a. L a)\<inverse>)\<^sup>* \<Longrightarrow> (x,z) \<in> ((\<Union>a. L a)\<inverse>)\<^sup>*"
          by (rule rtrancl_trans) auto
          with Cons show ?case by auto
        qed simp
        from 2(2) as' bs' cs' show "(u, v) \<in> valley' UNIV"
        unfolding xs lconv_append by auto (meson relcomp.simps)
      qed
    next
      fix as bs assume *: "map fst xs = as @ ([Acute] @ [Grave]) @ bs"
      {
        fix p a b q t' s' u'
        assume xs: "xs = p @ [(Acute,a),(Grave,b)] @ q" and p: "(u,t') \<in> lconv p"
          and a: "(s',t') \<in> L a" and b: "(s',u') \<in> R b" and q: "(u',v) \<in> lconv q"
        obtain js where lp: "lpeak r a b js" and js: "(t',u') \<in> lconv js" using pk[OF a b] by auto
        from lp have "(js, [(Acute,a),(Grave,b)]) \<in> greek_less r"
        unfolding lpeak_def using peak_greek_less[of _ r a _ b] by fastforce
        then have "(p @ js @ q, xs) \<in> greek_less r" unfolding xs
        by (intro greek_less_app_mono1 greek_less_app_mono2 \<open>trans r\<close>) auto
        moreover have "(u, v) \<in> lconv (p @ js @ q)"
        using p q js by auto
        ultimately have "(u, v) \<in> valley' UNIV" using 2(1) by blast
      }
      with * show "(u, v) \<in> valley' UNIV" using 2(2)
      by (auto elim!: map_eq_append_splits relcompEpair simp del: append.simps) simp
    next
      fix as bs assume *: "map fst xs = as @ ([Acute] @ [Macron]) @ bs"
      {
        fix p a b q t' s' u'
        assume xs: "xs = p @ [(Acute,a),(Macron,b)] @ q" and p: "(u,t') \<in> lconv p"
          and a: "(s',t') \<in> L a" and b: "(s',u') \<in> E b" and q: "(u',v) \<in> lconv q"
        obtain js where lp: "lcliff r a b js" and js: "(t',u') \<in> lconv js" using lc[OF a b] by auto
        from lp have "(js, [(Acute,a),(Macron,b)]) \<in> greek_less r"
        unfolding lcliff_def
        using lcliff_greek_less1[OF \<open>trans r\<close>, of _ a _ b] lcliff_greek_less2[OF \<open>trans r\<close>, of _ a b]
        by fastforce
        then have "(p @ js @ q, xs) \<in> greek_less r" unfolding xs
        by (intro greek_less_app_mono1 greek_less_app_mono2 \<open>trans r\<close>) auto
        moreover have "(u, v) \<in> lconv (p @ js @ q)"
        using p q js by auto
        ultimately have "(u, v) \<in> valley' UNIV" using 2(1) by blast
      }
      with * show "(u, v) \<in> valley' UNIV" using 2(2)
      by (auto elim!: map_eq_append_splits relcompEpair simp del: append.simps) simp
    next
      fix as bs assume *: "map fst xs = as @ ([Macron] @ [Grave]) @ bs"
      {
        fix p a b q t' s' u'
        assume xs: "xs = p @ [(Macron,a),(Grave,b)] @ q" and p: "(u,t') \<in> lconv p"
          and a: "(s',t') \<in> (E a)\<inverse>" and b: "(s',u') \<in> R b" and q: "(u',v) \<in> lconv q"
        obtain js where lp: "rcliff r a b js" and js: "(t',u') \<in> lconv js" using rc[OF a b] by auto
        from lp have "(js, [(Macron,a),(Grave,b)]) \<in> greek_less r"
        unfolding rcliff_def
        using rcliff_greek_less1[OF \<open>trans r\<close>, of _ a b] rcliff_greek_less2[OF \<open>trans r\<close>, of _ a _ b]
        by fastforce
        then have "(p @ js @ q, xs) \<in> greek_less r" unfolding xs
        by (intro greek_less_app_mono1 greek_less_app_mono2 \<open>trans r\<close>) auto
        moreover have "(u, v) \<in> lconv (p @ js @ q)"
        using p q js by auto
        ultimately have "(u, v) \<in> valley' UNIV" using 2(1) by blast
      }
      with * show "(u, v) \<in> valley' UNIV" using 2(2)
      by (auto elim!: map_eq_append_splits relcompEpair simp del: append.simps) simp
    qed
  qed
qed

section \<open>Results\<close>

subsection \<open>Church-Rosser modulo\<close>

text \<open>Decreasing diagrams for Church-Rosser modulo, commutation version.\<close>

lemma dd_commute_modulo[case_names wf trans peak lcliff rcliff]:
  assumes "wf r" and "trans r"
  and pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow>
    (t, u) \<in> conversion' (under r a) O (R b)\<^sup>= O conversion' (under r a \<union> under r b) O
      ((L a)\<inverse>)\<^sup>= O conversion' (under r b)"
  and lc: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> E b \<Longrightarrow>
    (t, u) \<in> conversion' (under r a) O E b O conversion' (under r a) O
      ((L a)\<inverse>)\<^sup>= O conversion' (under r a \<inter> under r b) \<or>
    (t, u) \<in> conversion' (under r a \<union> under r b) O ((L a )\<inverse>)\<^sup>= O conversion' (under r b)"
  and rc: "\<And>a b s t u. (s, t) \<in> (E a)\<inverse> \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow>
    (t, u) \<in> conversion' (under r a \<inter> under r b) O (R b)\<^sup>= O conversion' (under r b) O
      E a O conversion' (under r b) \<or>
    (t, u) \<in> conversion' (under r a) O (R b)\<^sup>= O conversion' (under r a \<union> under r b)"
  shows "conversion' UNIV \<subseteq> valley' UNIV"
proof (cases rule: dd_commute_modulo_conv[of r])
  case (peak a b s t u)
  {
    fix w x y z
    assume "(t, w) \<in> conversion' (under r a)"
    from conversion_to_lconv[OF this]
    obtain as where "snd ` set as \<subseteq> under r a" "(t, w) \<in> lconv as" by auto
    moreover assume "(w, x) \<in> (R b)\<^sup>="
    then obtain b' where "b' \<in> {[(Grave,b)],[]}" "(w, x) \<in> lconv b'" by fastforce
    moreover assume "(x, y) \<in> conversion' (under r a \<union> under r b)"
    from conversion_to_lconv[OF this]
    obtain cs where "snd ` set cs \<subseteq> under r a \<union> under r b" "(x, y) \<in> lconv cs" by auto
    moreover assume "(y, z) \<in> ((L a)\<inverse>)\<^sup>="
    then obtain a' where "a' \<in> {[(Acute,a)],[]}" "(y, z) \<in> lconv a'" by fastforce
    moreover assume "(z, u) \<in> conversion' (under r b)"
    from conversion_to_lconv[OF this]
    obtain bs where "snd ` set bs \<subseteq> under r b" "(z, u) \<in> lconv bs" by auto
    ultimately have "\<exists>xs. lpeak r a b xs \<and> (t, u) \<in> lconv xs"
    by (intro exI[of _ "as @ b' @ cs @ a' @ bs"], unfold lconv_append lpeak_def) blast
  }
  then show ?case using pk[OF peak] by blast
next
  case (lcliff a b s t u)
  {
    fix w x y z
    assume "(t, w) \<in> conversion' (under r a)"
    from conversion_to_lconv[OF this]
    obtain as where "snd ` set as \<subseteq> under r a" "(t, w) \<in> lconv as" by auto
    moreover assume "(w, x) \<in> E b"
    then obtain b' where "b' = [(Macron,b)]" "(w, x) \<in> lconv b'" by fastforce
    moreover assume "(x, y) \<in> conversion' (under r a)"
    from conversion_to_lconv[OF this]
    obtain cs where "snd ` set cs \<subseteq> under r a" "(x, y) \<in> lconv cs" by auto
    moreover assume "(y, z) \<in> ((L a)\<inverse>)\<^sup>="
    then obtain a' where "a' \<in> {[(Acute,a)],[]}" "(y, z) \<in> lconv a'" by fastforce
    moreover assume "(z, u) \<in> conversion' (under r a \<inter> under r b)"
    from conversion_to_lconv[OF this]
    obtain bs where "snd ` set bs \<subseteq> under r a \<inter> under r b" "(z, u) \<in> lconv bs" by auto
    ultimately have "\<exists>xs. lcliff r a b xs \<and> (t, u) \<in> lconv xs"
    by (intro exI[of _ "as @ b' @ cs @ a' @ bs"], unfold lconv_append lcliff_def) blast
  }
  moreover {
    fix w x
    assume "(t, w) \<in> conversion' (under r a \<union> under r b)"
    from conversion_to_lconv[OF this]
    obtain cs where "snd ` set cs \<subseteq> under r a \<union> under r b" "(t, w) \<in> lconv cs" by auto
    moreover assume "(w, x) \<in> ((L a)\<inverse>)\<^sup>="
    then obtain a' where "a' \<in> {[(Acute,a)],[]}" "(w, x) \<in> lconv a'" by fastforce
    moreover assume "(x, u) \<in> conversion' (under r b)"
    from conversion_to_lconv[OF this]
    obtain bs where "snd ` set bs \<subseteq> under r b" "(x, u) \<in> lconv bs" by auto
    ultimately have "\<exists>xs. lcliff r a b xs \<and> (t, u) \<in> lconv xs"
    by (intro exI[of _ "cs @ a' @ bs"], unfold lconv_append lcliff_def) blast
  }
  ultimately show ?case using lc[OF lcliff] by blast
next
  case (rcliff a b s t u)
  {
    fix w x y z
    assume "(t, w) \<in> conversion' (under r a \<inter> under r b)"
    from conversion_to_lconv[OF this]
    obtain as where "snd ` set as \<subseteq> under r a \<inter> under r b" "(t, w) \<in> lconv as" by auto
    moreover assume "(w, x) \<in> (R b)\<^sup>="
    then obtain b' where "b' \<in> {[(Grave,b)],[]}" "(w, x) \<in> lconv b'" by fastforce
    moreover assume "(x, y) \<in> conversion' (under r b)"
    from conversion_to_lconv[OF this]
    obtain cs where "snd ` set cs \<subseteq> under r b" "(x, y) \<in> lconv cs" by auto
    moreover assume "(y, z) \<in> E a"
    then obtain a' where "a' = [(Macron,a)]" "(y, z) \<in> lconv a'" by fastforce
    moreover assume "(z, u) \<in> conversion' (under r b)"
    from conversion_to_lconv[OF this]
    obtain bs where "snd ` set bs \<subseteq> under r b" "(z, u) \<in> lconv bs" by auto
    ultimately have "\<exists>xs. rcliff r a b xs \<and> (t, u) \<in> lconv xs"
    by (intro exI[of _ "as @ b' @ cs @ a' @ bs"], unfold lconv_append rcliff_def) blast
  }
  moreover {
    fix w x
    assume "(t, w) \<in> conversion' (under r a)"
    from conversion_to_lconv[OF this]
    obtain as where "snd ` set as \<subseteq> under r a" "(t, w) \<in> lconv as" by auto
    moreover assume "(w, x) \<in> (R b)\<^sup>="
    then obtain b' where "b' \<in> {[(Grave,b)],[]}" "(w, x) \<in> lconv b'" by fastforce
    moreover assume "(x, u) \<in> conversion' (under r a \<union> under r b)"
    from conversion_to_lconv[OF this]
    obtain cs where "snd ` set cs \<subseteq> under r a \<union> under r b" "(x, u) \<in> lconv cs" by auto
    ultimately have "\<exists>xs. rcliff r a b xs \<and> (t, u) \<in> lconv xs"
    by (intro exI[of _ "as @ b' @ cs"], unfold lconv_append rcliff_def) blast
  }
  ultimately show ?case using rc[OF rcliff] by blast
qed fact+

end (* context *)

text \<open>Decreasing diagrams for Church-Rosser modulo.\<close>

lemma dd_cr_modulo[case_names wf trans symE peak cliff]:
  assumes "wf r" and "trans r" and E: "\<And>i. sym (E i)"
  and pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> L b \<Longrightarrow>
    (t, u) \<in> conversion' L L E (under r a) O (L b)\<^sup>= O conversion' L L E (under r a \<union> under r b) O
      ((L a)\<inverse>)\<^sup>= O conversion' L L E (under r b)"
  and cl: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> E b \<Longrightarrow>
    (t, u) \<in> conversion' L L E (under r a) O E b O conversion' L L E (under r a) O
      ((L a)\<inverse>)\<^sup>= O conversion' L L E (under r a \<inter> under r b) \<or>
    (t, u) \<in> conversion' L L E (under r a \<union> under r b) O ((L a )\<inverse>)\<^sup>= O conversion' L L E (under r b)"
  shows "conversion' L L E UNIV \<subseteq> valley' L L E UNIV"
proof (induct rule: dd_commute_modulo[of r])
  note E' = E[unfolded sym_conv_converse_eq]
  case (rcliff a b s t u) show ?case
  using cl[OF rcliff(2) rcliff(1)[unfolded E'], unfolded converse_iff[of t u,symmetric]]
  by (auto simp only: ac_simps E' converse_inward)
qed fact+

subsection \<open>Commutation and confluence\<close>

abbreviation "conversion'' L R M \<equiv> ((\<Union>i \<in> M. R i) \<union> (\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"
abbreviation "valley'' L R M \<equiv> (\<Union>i \<in> M. R i)\<^sup>* O ((\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"

text \<open>Decreasing diagrams for commutation.\<close>

text \<open>Decreasing diagrams for confluence.\<close>

lemmas dd_cr[case_names wf trans peak] =
  dd_commute[of _ L L for L, unfolded CR_iff_self_commute[symmetric]]

subsection \<open>Extended decreasing diagrams\<close>

context
  fixes r q :: "'b rel"
  assumes "wf r" and "trans r" and "trans q" and "refl q" and compat: "r O q \<subseteq> r"
begin

private abbreviation (input) down :: "('b \<Rightarrow> 'a rel) \<Rightarrow> ('b \<Rightarrow> 'a rel)" where
  "down L \<equiv> \<lambda>i. \<Union>j \<in> under q i. L j"

private lemma Union_down: "(\<Union>i. down L i) = (\<Union>i. L i)"
using \<open>refl q\<close> by (auto simp: refl_on_def under_def)

text \<open>Extended decreasing diagrams for commutation.\<close>

lemma edd_commute[case_names wf transr transq reflq compat peak]:
  assumes pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow>
    (t, u) \<in> conversion'' L R (under r a) O (down R b)\<^sup>= O conversion'' L R (under r a \<union> under r b) O
      ((down L a)\<inverse>)\<^sup>= O conversion'' L R (under r b)"
  shows "commute (\<Union>i. L i) (\<Union>i. R i)"
unfolding Union_down[of L, symmetric] Union_down[of R, symmetric]
proof (induct rule: dd_commute[of r "down L" "down R"])
  case (peak a b s t u)
  then obtain a' b' where a': "(a', a) \<in> q" "(s, t) \<in> L a'" and b': "(b', b) \<in> q" "(s, u) \<in> R b'"
  by (auto simp: under_def)
  have "\<And>a' a. (a',a) \<in> q \<Longrightarrow> under r a' \<subseteq> under r a" using compat by (auto simp: under_def)
  then have aux1: "\<And>a' a L. (a',a) \<in> q \<Longrightarrow> (\<Union>i \<in> under r a'. L i) \<subseteq> (\<Union>i \<in> under r a. L i)" by auto
  have aux2: "\<And>a' a L. (a',a) \<in> q \<Longrightarrow> down L a' \<subseteq> down L a"
    using \<open>trans q\<close> by (auto simp: under_def trans_def)
  have aux3: "\<And>a L. (\<Union>i \<in> under r a. L i) \<subseteq> (\<Union>i \<in> under r a. down L i)"
    using \<open>refl q\<close> by (auto simp: under_def refl_on_def)
  from aux1[OF a'(1), of L] aux1[OF a'(1), of R] aux2[OF a'(1), of L]
       aux1[OF b'(1), of L] aux1[OF b'(1), of R] aux2[OF b'(1), of R]
       aux3[of L] aux3[of R]
  show ?case
  by (intro subsetD[OF _ pk[OF \<open>(s, t) \<in> L a'\<close> \<open>(s, u) \<in> R b'\<close>]], unfold UN_Un)
     (intro relcomp_mono rtrancl_mono Un_mono iffD2[OF converse_mono]; fast)
qed fact+

text \<open>Extended decreasing diagrams for confluence.\<close>

lemmas edd_cr[case_names wf transr transq reflq compat peak] =
  edd_commute[of L L for L, unfolded CR_iff_self_commute[symmetric]]

end (* context *)

end (* Decreasing_Diagrams_II *)


lemma tan_square_eq_1D:
  assumes "tan (z :: complex) ^ 2 = 1"
  shows "(\<exists>n. z = of_real ((of_int n + 1 / 2) * pi / 2))"
proof -
  from assms have "sin z ^ 2 = cos z ^ 2" "cos z \<noteq> 0"
    by (auto simp: tan_def field_simps)
  note this(1)
  also have "cos z ^ 2 = 1 - sin z ^ 2"
    by (simp add: cos_squared_eq)
  finally have "1 - 2 * sin z ^ 2 = 0"
    by simp
  also have "1 - 2 * sin z ^ 2 = cos (2 * z)"
    by (simp add: cos_double_sin)
  finally have "cos (2 * z) = 0" .
  then obtain n where "2 * z = complex_of_real (real_of_int n * pi) + complex_of_real pi / 2"
    unfolding cos_eq_0 by blast
  also have "\<dots> = (of_int n + 1/2) * pi"
    by (simp add: ring_distribs)
  finally have z: "z = (of_int n + 1/2) * pi / 2"
    by (simp add: mult_ac)
  thus "(\<exists>n. z = of_real ((of_int n + 1 / 2) * pi / 2))" ..
qed

lemma tan_eq_1_iff: "tan (z :: complex) = 1 \<longleftrightarrow> (\<exists>n. z = (of_int n + 1 / 4) * of_real pi)"
proof
  assume "\<exists>n. z = (of_int n + 1 / 4) * of_real pi"
  then obtain n where n: "z = (of_int n + 1 / 4) * of_real pi"
    by auto
  have "z = of_real ((real_of_int n + 1/4) * pi)"
    by (simp add: n)
  also have "tan \<dots> = of_real (tan ((real_of_int n + 1/4) * pi))"
    by (subst tan_of_real) auto
  also have "(real_of_int n + 1/4) * pi = pi / 4 + real_of_int n * pi"
    by (simp add: algebra_simps)
  also have "tan \<dots> = tan (pi / 4)"
    by (rule tan_periodic_int)
  also have "\<dots> = 1"
    by (simp add: tan_45)
  finally show "tan z = 1"
    by simp
next
  assume "tan z = 1"
  then obtain n where z: "z = (of_int n + 1/2) * pi / 2"
    using tan_square_eq_1D[of z] by auto
  define z' where "z' = (real_of_int n + 1/2) * pi / 2"
  have z': "z = of_real z'"
    by (simp add: z z'_def)

  have "even n"
  proof (rule ccontr)
    assume "odd n"
    then obtain k where k: "n = 2 * k + 1"
      by (elim oddE)
    have "tan z = of_real (tan z')"
      by (simp add: z' tan_of_real)
    also have "tan z' = tan (z' - (k + 1) * pi)"
      using tan_periodic_int[of z' "-(k + 1)"] by (simp add: algebra_simps)
    also have "z' - (k + 1) * pi = -pi / 4"
      by (simp add: z'_def field_simps k)
    also have "tan \<dots> = -1"
      by (simp add: tan_45)
    finally show False using \<open>tan z = 1\<close>
      by simp
  qed
  then obtain k where k: "n = 2 * k"
    by (elim evenE)
  have "z = (of_int k + 1 / 4) * of_real pi"
    by (simp add: k z)
  thus "\<exists>n. z = (of_int n + 1 / 4) * of_real pi" ..
qed

lemma tan_eq_neg1_iff: "tan (z :: complex) = -1 \<longleftrightarrow> (\<exists>n. z = (of_int n - 1 / 4) * of_real pi)"
proof
  assume "\<exists>n. z = (of_int n - 1 / 4) * of_real pi"
  then obtain n where n: "z = (of_int n - 1 / 4) * of_real pi"
    by auto
  have "z = of_real ((real_of_int n - 1/4) * pi)"
    by (simp add: n)
  also have "tan \<dots> = of_real (tan ((real_of_int n - 1/4) * pi))"
    by (subst tan_of_real) auto
  also have "(real_of_int n - 1/4) * pi = -pi / 4 + real_of_int n * pi"
    by (simp add: algebra_simps)
  also have "tan \<dots> = tan (-pi / 4)"
    by (rule tan_periodic_int)
  also have "\<dots> = -1"
    by (simp add: tan_45)
  finally show "tan z = -1"
    by simp
next
  assume "tan z = -1"
  hence "tan (-z) = 1"
    by simp
  then obtain n where n: "-z = (of_int n + 1 / 4) * of_real pi"
    by (subst (asm) tan_eq_1_iff) blast
  hence "z = (of_int (-n) - 1 / 4) * of_real pi"
    unfolding of_int_minus by (subst (asm) minus_equation_iff) (simp add: algebra_simps)
  thus "\<exists>n. z = (of_int n - 1 / 4) * of_real pi" ..
qed

lift_definition poly_roots :: "'a :: idom poly \<Rightarrow> 'a multiset" is
  "\<lambda>p x. if p = 0 then 0 else order x p"
proof -
  fix p :: "'a poly"
  have "{x. (if p = 0 then 0 else Polynomial.order x p) > 0} =
          (if p = 0 then {} else {x. poly p x = 0})"
    by (auto simp: order_root)
  also have "finite \<dots>"
    by (auto intro: poly_roots_finite)
  finally show "(\<lambda>x. if p = 0 then 0 else Polynomial.order x p) \<in> multiset"
    unfolding multiset_def by simp
qed

lemma poly_roots_0 [simp]: "poly_roots 0 = {#}"
  by transfer auto

lemma count_poly_roots [simp]:
  "p \<noteq> 0 \<Longrightarrow> count (poly_roots p) x = order x p"
  by transfer simp

lemma set_mset_poly_roots: "p \<noteq> 0 \<Longrightarrow> set_mset (poly_roots p) = {x. poly p x = 0}"
  by (simp add: set_mset_def order_root)

lemma in_poly_roots_iff: "p \<noteq> 0 \<Longrightarrow> x \<in># poly_roots p \<longleftrightarrow> poly p x = 0"
  by (simp add: set_mset_poly_roots)

lemma poly_roots_const [simp]: "poly_roots [:c:] = {#}"
  by transfer' (auto split: if_splits simp: fun_eq_iff order_0I)

lemma poly_roots_1 [simp]: "poly_roots 1 = {#}"
  unfolding one_pCons poly_roots_const ..

lemma poly_roots_smult: "poly_roots (Polynomial.smult c p) = (if c = 0 then {#} else poly_roots p)"
proof (cases "p = 0")
  case False
  thus ?thesis
    by (intro multiset_eqI) (auto simp: order_smult)
qed auto

lemma poly_roots_smult' [simp]: "c \<noteq> 0 \<Longrightarrow> poly_roots (Polynomial.smult c p) = poly_roots p"
  by (subst poly_roots_smult) auto

lemma poly_roots_uminus [simp]: "poly_roots (-p) = poly_roots p"
  using poly_roots_smult'[of "-1" p] by (simp del: poly_roots_smult')

lemma poly_roots_monom:
  "poly_roots (Polynomial.monom c n) = (if c = 0 then {#} else replicate_mset n 0)"
  by (intro multiset_eqI) (auto intro: order_0I simp: poly_monom)

lemma poly_roots_monom' [simp]:
  "c \<noteq> 0 \<Longrightarrow> poly_roots (Polynomial.monom c n) = replicate_mset n 0"
  by (subst poly_roots_monom) auto

lemma poly_roots_mult:
  assumes "p \<noteq> 0" "q \<noteq> 0"
  shows   "poly_roots (p * q) = poly_roots p + poly_roots q"
  using assms by (intro multiset_eqI) (auto simp: order_mult)

lemma poly_roots_power [simp]: "poly_roots (p ^ n) = repeat_mset n (poly_roots p)"
proof (cases "p = 0")
  case True
  thus ?thesis by (cases n) auto
next
  case False
  thus ?thesis by (induction n) (auto simp: poly_roots_mult)
qed

lemma poly_roots_prod:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0"
  shows   "poly_roots (prod f A) = (\<Sum>x\<in>A. poly_roots (f x))"
  using assms by (induction A rule: infinite_finite_induct) (auto simp: poly_roots_mult)

lemma poly_roots_rsquarefree:
  assumes "rsquarefree p"
  shows   "poly_roots p = mset_set {x. poly p x = 0}"
proof -
  from assms have [simp]: "p \<noteq> 0"
    by (auto simp: rsquarefree_def)
  show ?thesis
  proof (rule multiset_eqI)
    fix x
    find_consts name:poly_roots
    show "count (poly_roots p)
  using assms poly_roots_finite[of p]
  apply (intro multiset_eqI)
  apply (auto simp: count_mset_set)