theory LexerSimp
  imports "Lexer"
begin

section {* Lexer including some simplifications *}

fun F_RIGHT where
  "F_RIGHT f v = Right (f v)"

fun F_LEFT where
  "F_LEFT f v = Left (f v)"

fun F_ALT where
  "F_ALT f\<^sub>1 f\<^sub>2 (Right v) = Right (f\<^sub>2 v)"
| "F_ALT f\<^sub>1 f\<^sub>2 (Left v) = Left (f\<^sub>1 v)"
| "F_ALT f1 f2 v = v"

fun F_SEQ1 where
  "F_SEQ1 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 Void) (f\<^sub>2 v)"

fun F_SEQ2 where
  "F_SEQ2 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 v) (f\<^sub>2 Void)"

fun F_SEQ where
  "F_SEQ f\<^sub>1 f\<^sub>2 (Seq v\<^sub>1 v\<^sub>2) = Seq (f\<^sub>1 v\<^sub>1) (f\<^sub>2 v\<^sub>2)"
| "F_SEQ f1 f2 v = v"

fun simp_ALT where
  "simp_ALT (ZERO, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_RIGHT f\<^sub>2)"
| "simp_ALT (r\<^sub>1, f\<^sub>1) (ZERO, f\<^sub>2) = (r\<^sub>1, F_LEFT f\<^sub>1)"
| "simp_ALT (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (ALT r\<^sub>1 r\<^sub>2, F_ALT f\<^sub>1 f\<^sub>2)"

fun simp_SEQ where
  "simp_SEQ (ONE, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_SEQ1 f\<^sub>1 f\<^sub>2)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (ONE, f\<^sub>2) = (r\<^sub>1, F_SEQ2 f\<^sub>1 f\<^sub>2)"
| "simp_SEQ (ZERO, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (ZERO, undefined)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (ZERO, f\<^sub>2) = (ZERO, undefined)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (SEQ r\<^sub>1 r\<^sub>2, F_SEQ f\<^sub>1 f\<^sub>2)"

lemma simp_SEQ_simps[simp]:
  "simp_SEQ p1 p2 = (if (fst p1 = ONE) then (fst p2, F_SEQ1 (snd p1) (snd p2))
                    else (if (fst p2 = ONE) then (fst p1, F_SEQ2 (snd p1) (snd p2))
                    else (if (fst p1 = ZERO) then (ZERO, undefined)
                    else (if (fst p2 = ZERO) then (ZERO, undefined)
                    else (SEQ (fst p1) (fst p2), F_SEQ (snd p1) (snd p2))))))"
by (induct p1 p2 rule: simp_SEQ.induct) (auto)

lemma simp_ALT_simps[simp]:
  "simp_ALT p1 p2 = (if (fst p1 = ZERO) then (fst p2, F_RIGHT (snd p2))
                    else (if (fst p2 = ZERO) then (fst p1, F_LEFT (snd p1))
                    else (ALT (fst p1) (fst p2), F_ALT (snd p1) (snd p2))))"
by (induct p1 p2 rule: simp_ALT.induct) (auto)

fun
  simp :: "rexp \<Rightarrow> rexp * (val \<Rightarrow> val)"
where
  "simp (ALT r1 r2) = simp_ALT (simp r1) (simp r2)"
| "simp (SEQ r1 r2) = simp_SEQ (simp r1) (simp r2)"
| "simp r = (r, id)"

fun
  slexer :: "rexp \<Rightarrow> string \<Rightarrow> val option"
where
  "slexer r [] = (if nullable r then Some(mkeps r) else None)"
| "slexer r (c#s) = (let (rs, fr) = simp (der c r) in
                         (case (slexer rs s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c (fr v))))"

lemma slexer_better_simp:
  "slexer r (c#s) = (case (slexer (fst (simp (der c r))) s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c ((snd (simp (der c r))) v)))"
by (auto split: prod.split option.split)

lemma L_fst_simp:
  shows "L(r) = L(fst (simp r))"
by (induct r) (auto)

lemma Posix_simp:
  assumes "s \<in> (fst (simp r)) \<rightarrow> v"
  shows "s \<in> r \<rightarrow> ((snd (simp r)) v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case (ALT r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (ALT r1 r2)) \<rightarrow> v" by fact
  consider (ZERO_ZERO) "fst (simp r1) = ZERO" "fst (simp r2) = ZERO"
         | (ZERO_NZERO) "fst (simp r1) = ZERO" "fst (simp r2) \<noteq> ZERO"
         | (NZERO_ZERO) "fst (simp r1) \<noteq> ZERO" "fst (simp r2) = ZERO"
         | (NZERO_NZERO) "fst (simp r1) \<noteq> ZERO" "fst (simp r2) \<noteq> ZERO" by auto
  then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
    proof(cases)
      case (ZERO_ZERO)
      with as have "s \<in> ZERO \<rightarrow> v" by simp
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" by (rule Posix_elims(1))
    next
      case (ZERO_NZERO)
      with as have "s \<in> fst (simp r2) \<rightarrow> v" by simp
      with IH2 have "s \<in> r2 \<rightarrow> snd (simp r2) v" by simp
      moreover
      from ZERO_NZERO have "fst (simp r1) = ZERO" by simp
      then have "L (fst (simp r1)) = {}" by simp
      then have "L r1 = {}" using L_fst_simp by simp
      then have "s \<notin> L r1" by simp
      ultimately have "s \<in> ALT r1 r2 \<rightarrow> Right (snd (simp r2) v)" by (rule Posix_ALT2)
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
      using ZERO_NZERO by simp
    next
      case (NZERO_ZERO)
      with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
      with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      then have "s \<in> ALT r1 r2 \<rightarrow> Left (snd (simp r1) v)" by (rule Posix_ALT1)
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_ZERO by simp
    next
      case (NZERO_NZERO)
      with as have "s \<in> ALT (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then consider (Left) v1 where "v = Left v1" "s \<in> (fst (simp r1)) \<rightarrow> v1"
                  | (Right) v2 where "v = Right v2" "s \<in> (fst (simp r2)) \<rightarrow> v2" "s \<notin> L (fst (simp r1))"
                  by (erule_tac Posix_elims(4))
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
      proof(cases)
        case (Left)
        then have "v = Left v1" "s \<in> r1 \<rightarrow> (snd (simp r1) v1)" using IH1 by simp_all
        then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_NZERO
          by (simp_all add: Posix_ALT1)
      next
        case (Right)
        then have "v = Right v2" "s \<in> r2 \<rightarrow> (snd (simp r2) v2)" "s \<notin> L r1" using IH2 L_fst_simp by simp_all
        then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_NZERO
          by (simp_all add: Posix_ALT2)
      qed
    qed
next
  case (SEQ r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (SEQ r1 r2)) \<rightarrow> v" by fact
  consider (ONE_ONE) "fst (simp r1) = ONE" "fst (simp r2) = ONE"
         | (ONE_NONE) "fst (simp r1) = ONE" "fst (simp r2) \<noteq> ONE"
         | (NONE_ONE) "fst (simp r1) \<noteq> ONE" "fst (simp r2) = ONE"
         | (NONE_NONE) "fst (simp r1) \<noteq> ONE" "fst (simp r2) \<noteq> ONE"
         by auto
  then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v"
  proof(cases)
      case (ONE_ONE)
      with as have b: "s \<in> ONE \<rightarrow> v" by simp
      from b have "s \<in> r1 \<rightarrow> snd (simp r1) v" using IH1 ONE_ONE by simp
      moreover
      from b have c: "s = []" "v = Void" using Posix_elims(2) by auto
      moreover
      have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
      then have "[] \<in> fst (simp r2) \<rightarrow> Void" using ONE_ONE by simp
      then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "([] @ []) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) Void)"
        using Posix_SEQ by blast
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using c ONE_ONE by simp
    next
      case (ONE_NONE)
      with as have b: "s \<in> fst (simp r2) \<rightarrow> v" by simp
      from b have "s \<in> r2 \<rightarrow> snd (simp r2) v" using IH2 ONE_NONE by simp
      moreover
      have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
      then have "[] \<in> fst (simp r1) \<rightarrow> Void" using ONE_NONE by simp
      then have "[] \<in> r1 \<rightarrow> snd (simp r1) Void" using IH1 by simp
      moreover
      from ONE_NONE(1) have "L (fst (simp r1)) = {[]}" by simp
      then have "L r1 = {[]}" by (simp add: L_fst_simp[symmetric])
      ultimately have "([] @ s) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) v)"
        by(rule_tac Posix_SEQ) auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using ONE_NONE by simp
    next
      case (NONE_ONE)
        with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
        with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      moreover
        have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
        then have "[] \<in> fst (simp r2) \<rightarrow> Void" using NONE_ONE by simp
        then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "(s @ []) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) v) (snd (simp r2) Void)"
        by(rule_tac Posix_SEQ) auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using NONE_ONE by simp
    next
      case (NONE_NONE)
      from as have 00: "fst (simp r1) \<noteq> ZERO" "fst (simp r2) \<noteq> ZERO"
        apply(auto)
        apply(smt Posix_elims(1) fst_conv)
        by (smt NONE_NONE(2) Posix_elims(1) fstI)
      with NONE_NONE as have "s \<in> SEQ (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then obtain s1 s2 v1 v2 where eqs: "s = s1 @ s2" "v = Seq v1 v2"
                     "s1 \<in> (fst (simp r1)) \<rightarrow> v1" "s2 \<in> (fst (simp r2)) \<rightarrow> v2"
                     "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)"
                     by (erule_tac Posix_elims(5)) (auto simp add: L_fst_simp[symmetric])
      then have "s1 \<in> r1 \<rightarrow> (snd (simp r1) v1)" "s2 \<in> r2 \<rightarrow> (snd (simp r2) v2)"
        using IH1 IH2 by auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using eqs NONE_NONE 00
        by(auto intro: Posix_SEQ)
    qed
qed (simp_all)

lemma slexer_correctness:
  shows "slexer r s = lexer r s"
proof(induct s arbitrary: r)
  case Nil
  show "slexer r [] = lexer r []" by simp
next
  case (Cons c s r)
  have IH: "\<And>r. slexer r s = lexer r s" by fact
  show "slexer r (c # s) = lexer r (c # s)"
   proof (cases "s \<in> L (der c r)")
     case True
       assume a1: "s \<in> L (der c r)"
       then obtain v1 where a2: "lexer (der c r) s = Some v1" "s \<in> der c r \<rightarrow> v1"
         using lexer_correct_Some by auto
       from a1 have "s \<in> L (fst (simp (der c r)))" using L_fst_simp[symmetric] by simp
       then obtain v2 where a3: "lexer (fst (simp (der c r))) s = Some v2" "s \<in> (fst (simp (der c r))) \<rightarrow> v2"
          using lexer_correct_Some by auto
       then have a4: "slexer (fst (simp (der c r))) s = Some v2" using IH by simp
       from a3(2) have "s \<in> der c r \<rightarrow> (snd (simp (der c r))) v2" using Posix_simp by simp
       with a2(2) have "v1 = (snd (simp (der c r))) v2" using Posix_determ by simp
       with a2(1) a4 show "slexer r (c # s) = lexer r (c # s)" by (auto split: prod.split)
     next
     case False
       assume b1: "s \<notin> L (der c r)"
       then have "lexer (der c r) s = None" using lexer_correct_None by simp
       moreover
       from b1 have "s \<notin> L (fst (simp (der c r)))" using L_fst_simp[symmetric] by simp
       then have "lexer (fst (simp (der c r))) s = None" using lexer_correct_None by simp
       then have "slexer (fst (simp (der c r))) s = None" using IH by simp
       ultimately show "slexer r (c # s) = lexer r (c # s)"
         by (simp del: slexer.simps add: slexer_better_simp)
   qed
 qed

unused_thms

end


(*  Title:      ZF/Constructible/Formula.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>First-Order Formulas and the Definition of the Class L\<close>

theory Formula imports ZF begin

subsection\<open>Internalized formulas of FOL\<close>

text\<open>De Bruijn representation.
  Unbound variables get their denotations from an environment.\<close>

consts   formula :: i
datatype
  "formula" = Member ("x \<in> nat", "y \<in> nat")
            | Equal  ("x \<in> nat", "y \<in> nat")
            | Nand ("p \<in> formula", "q \<in> formula")
            | Forall ("p \<in> formula")

declare formula.intros [TC]

definition
  Neg :: "i\<Rightarrow>i" where
  "Neg(p) \<equiv> Nand(p,p)"

definition
  And :: "[i,i]\<Rightarrow>i" where
  "And(p,q) \<equiv> Neg(Nand(p,q))"

definition
  Or :: "[i,i]\<Rightarrow>i" where
  "Or(p,q) \<equiv> Nand(Neg(p),Neg(q))"

definition
  Implies :: "[i,i]\<Rightarrow>i" where
  "Implies(p,q) \<equiv> Nand(p,Neg(q))"

definition
  Iff :: "[i,i]\<Rightarrow>i" where
  "Iff(p,q) \<equiv> And(Implies(p,q), Implies(q,p))"

definition
  Exists :: "i\<Rightarrow>i" where
  "Exists(p) \<equiv> Neg(Forall(Neg(p)))"

lemma Neg_type [TC]: "p \<in> formula \<Longrightarrow> Neg(p) \<in> formula"
by (simp add: Neg_def)

lemma And_type [TC]: "\<lbrakk>p \<in> formula; q \<in> formula\<rbrakk> \<Longrightarrow> And(p,q) \<in> formula"
by (simp add: And_def)

lemma Or_type [TC]: "\<lbrakk>p \<in> formula; q \<in> formula\<rbrakk> \<Longrightarrow> Or(p,q) \<in> formula"
by (simp add: Or_def)

lemma Implies_type [TC]:
     "\<lbrakk>p \<in> formula; q \<in> formula\<rbrakk> \<Longrightarrow> Implies(p,q) \<in> formula"
by (simp add: Implies_def)

lemma Iff_type [TC]:
     "\<lbrakk>p \<in> formula; q \<in> formula\<rbrakk> \<Longrightarrow> Iff(p,q) \<in> formula"
by (simp add: Iff_def)

lemma Exists_type [TC]: "p \<in> formula \<Longrightarrow> Exists(p) \<in> formula"
by (simp add: Exists_def)

consts   satisfies :: "[i,i]\<Rightarrow>i"
primrec (*explicit lambda is required because the environment varies*)
  "satisfies(A,Member(x,y)) =
      (\<lambda>env \<in> list(A). bool_of_o (nth(x,env) \<in> nth(y,env)))"

  "satisfies(A,Equal(x,y)) =
      (\<lambda>env \<in> list(A). bool_of_o (nth(x,env) = nth(y,env)))"

  "satisfies(A,Nand(p,q)) =
      (\<lambda>env \<in> list(A). not ((satisfies(A,p)`env) and (satisfies(A,q)`env)))"

  "satisfies(A,Forall(p)) =
      (\<lambda>env \<in> list(A). bool_of_o (\<forall>x\<in>A. satisfies(A,p) ` (Cons(x,env)) = 1))"

lemma satisfies_type: "p \<in> formula \<Longrightarrow> satisfies(A,p) \<in> list(A) -> bool"
by (induct set: formula) simp_all

abbreviation
  sats :: "[i,i,i] \<Rightarrow> o" where
  "sats(A,p,env) \<equiv> satisfies(A,p)`env = 1"

lemma sats_Member_iff [simp]:
  "env \<in> list(A) \<Longrightarrow> sats(A, Member(x,y), env) \<longleftrightarrow> nth(x,env) \<in> nth(y,env)"
by simp

lemma sats_Equal_iff [simp]:
  "env \<in> list(A) \<Longrightarrow> sats(A, Equal(x,y), env) \<longleftrightarrow> nth(x,env) = nth(y,env)"
by simp

lemma sats_Nand_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> (sats(A, Nand(p,q), env)) \<longleftrightarrow> \<not> (sats(A,p,env) \<and> sats(A,q,env))"
by (simp add: Bool.and_def Bool.not_def cond_def)

lemma sats_Forall_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> sats(A, Forall(p), env) \<longleftrightarrow> (\<forall>x\<in>A. sats(A, p, Cons(x,env)))"
by simp

declare satisfies.simps [simp del]

subsection\<open>Dividing line between primitive and derived connectives\<close>

lemma sats_Neg_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> sats(A, Neg(p), env) \<longleftrightarrow> \<not> sats(A,p,env)"
by (simp add: Neg_def)

lemma sats_And_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> (sats(A, And(p,q), env)) \<longleftrightarrow> sats(A,p,env) \<and> sats(A,q,env)"
by (simp add: And_def)

lemma sats_Or_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> (sats(A, Or(p,q), env)) \<longleftrightarrow> sats(A,p,env) | sats(A,q,env)"
by (simp add: Or_def)

lemma sats_Implies_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> (sats(A, Implies(p,q), env)) \<longleftrightarrow> (sats(A,p,env) \<longrightarrow> sats(A,q,env))"
by (simp add: Implies_def, blast)

lemma sats_Iff_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> (sats(A, Iff(p,q), env)) \<longleftrightarrow> (sats(A,p,env) \<longleftrightarrow> sats(A,q,env))"
by (simp add: Iff_def, blast)

lemma sats_Exists_iff [simp]:
  "env \<in> list(A)
   \<Longrightarrow> sats(A, Exists(p), env) \<longleftrightarrow> (\<exists>x\<in>A. sats(A, p, Cons(x,env)))"
by (simp add: Exists_def)

subsubsection\<open>Derived rules to help build up formulas\<close>

lemma mem_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (x\<in>y) \<longleftrightarrow> sats(A, Member(i,j), env)"
by (simp add: satisfies.simps)

lemma equal_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (x=y) \<longleftrightarrow> sats(A, Equal(i,j), env)"
by (simp add: satisfies.simps)

lemma not_iff_sats:
      "\<lbrakk>P \<longleftrightarrow> sats(A,p,env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (\<not>P) \<longleftrightarrow> sats(A, Neg(p), env)"
by simp

lemma conj_iff_sats:
      "\<lbrakk>P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (P \<and> Q) \<longleftrightarrow> sats(A, And(p,q), env)"
by (simp)

lemma disj_iff_sats:
      "\<lbrakk>P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (P | Q) \<longleftrightarrow> sats(A, Or(p,q), env)"
by (simp)

lemma iff_iff_sats:
      "\<lbrakk>P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (P \<longleftrightarrow> Q) \<longleftrightarrow> sats(A, Iff(p,q), env)"
by (simp)

lemma imp_iff_sats:
      "\<lbrakk>P \<longleftrightarrow> sats(A,p,env); Q \<longleftrightarrow> sats(A,q,env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (P \<longrightarrow> Q) \<longleftrightarrow> sats(A, Implies(p,q), env)"
by (simp)

lemma ball_iff_sats:
      "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> P(x) \<longleftrightarrow> sats(A, p, Cons(x, env)); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (\<forall>x\<in>A. P(x)) \<longleftrightarrow> sats(A, Forall(p), env)"
by (simp)

lemma bex_iff_sats:
      "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> P(x) \<longleftrightarrow> sats(A, p, Cons(x, env)); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> (\<exists>x\<in>A. P(x)) \<longleftrightarrow> sats(A, Exists(p), env)"
by (simp)

lemmas FOL_iff_sats =
        mem_iff_sats equal_iff_sats not_iff_sats conj_iff_sats
        disj_iff_sats imp_iff_sats iff_iff_sats imp_iff_sats ball_iff_sats
        bex_iff_sats

subsection\<open>Arity of a Formula: Maximum Free de Bruijn Index\<close>

consts   arity :: "i\<Rightarrow>i"
primrec
  "arity(Member(x,y)) = succ(x) \<union> succ(y)"

  "arity(Equal(x,y)) = succ(x) \<union> succ(y)"

  "arity(Nand(p,q)) = arity(p) \<union> arity(q)"

  "arity(Forall(p)) = Arith.pred(arity(p))"

lemma arity_type [TC]: "p \<in> formula \<Longrightarrow> arity(p) \<in> nat"
by (induct_tac p, simp_all)

lemma arity_Neg [simp]: "arity(Neg(p)) = arity(p)"
by (simp add: Neg_def)

lemma arity_And [simp]: "arity(And(p,q)) = arity(p) \<union> arity(q)"
by (simp add: And_def)

lemma arity_Or [simp]: "arity(Or(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Or_def)

lemma arity_Implies [simp]: "arity(Implies(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Implies_def)

lemma arity_Iff [simp]: "arity(Iff(p,q)) = arity(p) \<union> arity(q)"
by (simp add: Iff_def, blast)

lemma arity_Exists [simp]: "arity(Exists(p)) = Arith.pred(arity(p))"
by (simp add: Exists_def)

lemma arity_sats_iff [rule_format]:
  "\<lbrakk>p \<in> formula; extra \<in> list(A)\<rbrakk>
   \<Longrightarrow> \<forall>env \<in> list(A).
           arity(p) \<le> length(env) \<longrightarrow>
           sats(A, p, env @ extra) \<longleftrightarrow> sats(A, p, env)"
apply (induct_tac p)
apply (simp_all add: Arith.pred_def nth_append Un_least_lt_iff nat_imp_quasinat
                split: split_nat_case, auto)
done

lemma arity_sats1_iff:
  "\<lbrakk>arity(p) \<le> succ(length(env)); p \<in> formula; x \<in> A; env \<in> list(A);
      extra \<in> list(A)\<rbrakk>
   \<Longrightarrow> sats(A, p, Cons(x, env @ extra)) \<longleftrightarrow> sats(A, p, Cons(x, env))"
apply (insert arity_sats_iff [of p extra A "Cons(x,env)"])
apply simp
done

subsection\<open>Renaming Some de Bruijn Variables\<close>

definition
  incr_var :: "[i,i]\<Rightarrow>i" where
  "incr_var(x,nq) \<equiv> if x<nq then x else succ(x)"

lemma incr_var_lt: "x<nq \<Longrightarrow> incr_var(x,nq) = x"
by (simp add: incr_var_def)

lemma incr_var_le: "nq\<le>x \<Longrightarrow> incr_var(x,nq) = succ(x)"
apply (simp add: incr_var_def)
apply (blast dest: lt_trans1)
done

consts   incr_bv :: "i\<Rightarrow>i"
primrec
  "incr_bv(Member(x,y)) =
      (\<lambda>nq \<in> nat. Member (incr_var(x,nq), incr_var(y,nq)))"

  "incr_bv(Equal(x,y)) =
      (\<lambda>nq \<in> nat. Equal (incr_var(x,nq), incr_var(y,nq)))"

  "incr_bv(Nand(p,q)) =
      (\<lambda>nq \<in> nat. Nand (incr_bv(p)`nq, incr_bv(q)`nq))"

  "incr_bv(Forall(p)) =
      (\<lambda>nq \<in> nat. Forall (incr_bv(p) ` succ(nq)))"

lemma [TC]: "x \<in> nat \<Longrightarrow> incr_var(x,nq) \<in> nat"
by (simp add: incr_var_def)

lemma incr_bv_type [TC]: "p \<in> formula \<Longrightarrow> incr_bv(p) \<in> nat -> formula"
by (induct_tac p, simp_all)

text\<open>Obviously, \<^term>\<open>DPow\<close> is closed under complements and finite
intersections and unions.  Needs an inductive lemma to allow two lists of
parameters to be combined.\<close>

lemma sats_incr_bv_iff [rule_format]:
  "\<lbrakk>p \<in> formula; env \<in> list(A); x \<in> A\<rbrakk>
   \<Longrightarrow> \<forall>bvs \<in> list(A).
           sats(A, incr_bv(p) ` length(bvs), bvs @ Cons(x,env)) \<longleftrightarrow>
           sats(A, p, bvs@env)"
apply (induct_tac p)
apply (simp_all add: incr_var_def nth_append succ_lt_iff length_type)
apply (auto simp add: diff_succ not_lt_iff_le)
done

(*the following two lemmas prevent huge case splits in arity_incr_bv_lemma*)
lemma incr_var_lemma:
     "\<lbrakk>x \<in> nat; y \<in> nat; nq \<le> x\<rbrakk>
      \<Longrightarrow> succ(x) \<union> incr_var(y,nq) = succ(x \<union> y)"
apply (simp add: incr_var_def Ord_Un_if, auto)
  apply (blast intro: leI)
 apply (simp add: not_lt_iff_le)
 apply (blast intro: le_anti_sym)
apply (blast dest: lt_trans2)
done

lemma incr_And_lemma:
     "y < x \<Longrightarrow> y \<union> succ(x) = succ(x \<union> y)"
apply (simp add: Ord_Un_if lt_Ord lt_Ord2 succ_lt_iff)
apply (blast dest: lt_asym)
done

lemma arity_incr_bv_lemma [rule_format]:
  "p \<in> formula
   \<Longrightarrow> \<forall>n \<in> nat. arity (incr_bv(p) ` n) =
                 (if n < arity(p) then succ(arity(p)) else arity(p))"
apply (induct_tac p)
apply (simp_all add: imp_disj not_lt_iff_le Un_least_lt_iff lt_Un_iff le_Un_iff
                     succ_Un_distrib [symmetric] incr_var_lt incr_var_le
                     Un_commute incr_var_lemma Arith.pred_def nat_imp_quasinat
            split: split_nat_case)
 txt\<open>the Forall case reduces to linear arithmetic\<close>
 prefer 2
 apply clarify
 apply (blast dest: lt_trans1)
txt\<open>left with the And case\<close>
apply safe
 apply (blast intro: incr_And_lemma lt_trans1)
apply (subst incr_And_lemma)
 apply (blast intro: lt_trans1)
apply (simp add: Un_commute)
done

subsection\<open>Renaming all but the First de Bruijn Variable\<close>

definition
  incr_bv1 :: "i \<Rightarrow> i" where
  "incr_bv1(p) \<equiv> incr_bv(p)`1"

lemma incr_bv1_type [TC]: "p \<in> formula \<Longrightarrow> incr_bv1(p) \<in> formula"
by (simp add: incr_bv1_def)

(*For renaming all but the bound variable at level 0*)
lemma sats_incr_bv1_iff:
  "\<lbrakk>p \<in> formula; env \<in> list(A); x \<in> A; y \<in> A\<rbrakk>
   \<Longrightarrow> sats(A, incr_bv1(p), Cons(x, Cons(y, env))) \<longleftrightarrow>
       sats(A, p, Cons(x,env))"
apply (insert sats_incr_bv_iff [of p env A y "Cons(x,Nil)"])
apply (simp add: incr_bv1_def)
done

lemma formula_add_params1 [rule_format]:
  "\<lbrakk>p \<in> formula; n \<in> nat; x \<in> A\<rbrakk>
   \<Longrightarrow> \<forall>bvs \<in> list(A). \<forall>env \<in> list(A).
          length(bvs) = n \<longrightarrow>
          sats(A, iterates(incr_bv1, n, p), Cons(x, bvs@env)) \<longleftrightarrow>
          sats(A, p, Cons(x,env))"
apply (induct_tac n, simp, clarify)
apply (erule list.cases)
apply (simp_all add: sats_incr_bv1_iff)
done

lemma arity_incr_bv1_eq:
  "p \<in> formula
   \<Longrightarrow> arity(incr_bv1(p)) =
        (if 1 < arity(p) then succ(arity(p)) else arity(p))"
apply (insert arity_incr_bv_lemma [of p 1])
apply (simp add: incr_bv1_def)
done

lemma arity_iterates_incr_bv1_eq:
  "\<lbrakk>p \<in> formula; n \<in> nat\<rbrakk>
   \<Longrightarrow> arity(incr_bv1^n(p)) =
         (if 1 < arity(p) then n #+ arity(p) else arity(p))"
apply (induct_tac n)
apply (simp_all add: arity_incr_bv1_eq)
apply (simp add: not_lt_iff_le)
apply (blast intro: le_trans add_le_self2 arity_type)
done

subsection\<open>Definable Powerset\<close>

text\<open>The definable powerset operation: Kunen's definition VI 1.1, page 165.\<close>
definition
  DPow :: "i \<Rightarrow> i" where
  "DPow(A) \<equiv> {X \<in> Pow(A).
               \<exists>env \<in> list(A). \<exists>p \<in> formula.
                 arity(p) \<le> succ(length(env)) \<and>
                 X = {x\<in>A. sats(A, p, Cons(x,env))}}"

lemma DPowI:
  "\<lbrakk>env \<in> list(A);  p \<in> formula;  arity(p) \<le> succ(length(env))\<rbrakk>
   \<Longrightarrow> {x\<in>A. sats(A, p, Cons(x,env))} \<in> DPow(A)"
by (simp add: DPow_def, blast)

text\<open>With this rule we can specify \<^term>\<open>p\<close> later.\<close>
lemma DPowI2 [rule_format]:
  "\<lbrakk>\<forall>x\<in>A. P(x) \<longleftrightarrow> sats(A, p, Cons(x,env));
     env \<in> list(A);  p \<in> formula;  arity(p) \<le> succ(length(env))\<rbrakk>
   \<Longrightarrow> {x\<in>A. P(x)} \<in> DPow(A)"
by (simp add: DPow_def, blast)

lemma DPowD:
  "X \<in> DPow(A)
   \<Longrightarrow> X \<subseteq> A \<and>
       (\<exists>env \<in> list(A).
        \<exists>p \<in> formula. arity(p) \<le> succ(length(env)) \<and>
                      X = {x\<in>A. sats(A, p, Cons(x,env))})"
by (simp add: DPow_def)

lemmas DPow_imp_subset = DPowD [THEN conjunct1]

(*Kunen's Lemma VI 1.2*)
lemma "\<lbrakk>p \<in> formula; env \<in> list(A); arity(p) \<le> succ(length(env))\<rbrakk>
       \<Longrightarrow> {x\<in>A. sats(A, p, Cons(x,env))} \<in> DPow(A)"
by (blast intro: DPowI)

lemma DPow_subset_Pow: "DPow(A) \<subseteq> Pow(A)"
by (simp add: DPow_def, blast)

lemma empty_in_DPow: "0 \<in> DPow(A)"
apply (simp add: DPow_def)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="Neg(Equal(0,0))" in bexI)
  apply (auto simp add: Un_least_lt_iff)
done

lemma Compl_in_DPow: "X \<in> DPow(A) \<Longrightarrow> (A-X) \<in> DPow(A)"
apply (simp add: DPow_def, clarify, auto)
apply (rule bexI)
 apply (rule_tac x="Neg(p)" in bexI)
  apply auto
done

lemma Int_in_DPow: "\<lbrakk>X \<in> DPow(A); Y \<in> DPow(A)\<rbrakk> \<Longrightarrow> X \<inter> Y \<in> DPow(A)"
apply (simp add: DPow_def, auto)
apply (rename_tac envp p envq q)
apply (rule_tac x="envp@envq" in bexI)
 apply (rule_tac x="And(p, iterates(incr_bv1,length(envp),q))" in bexI)
  apply typecheck
apply (rule conjI)
(*finally check the arity!*)
 apply (simp add: arity_iterates_incr_bv1_eq Un_least_lt_iff)
 apply (force intro: add_le_self le_trans)
apply (simp add: arity_sats1_iff formula_add_params1, blast)
done

lemma Un_in_DPow: "\<lbrakk>X \<in> DPow(A); Y \<in> DPow(A)\<rbrakk> \<Longrightarrow> X \<union> Y \<in> DPow(A)"
apply (subgoal_tac "X \<union> Y = A - ((A-X) \<inter> (A-Y))")
apply (simp add: Int_in_DPow Compl_in_DPow)
apply (simp add: DPow_def, blast)
done

lemma singleton_in_DPow: "a \<in> A \<Longrightarrow> {a} \<in> DPow(A)"
apply (simp add: DPow_def)
apply (rule_tac x="Cons(a,Nil)" in bexI)
 apply (rule_tac x="Equal(0,1)" in bexI)
  apply typecheck
apply (force simp add: succ_Un_distrib [symmetric])
done

lemma cons_in_DPow: "\<lbrakk>a \<in> A; X \<in> DPow(A)\<rbrakk> \<Longrightarrow> cons(a,X) \<in> DPow(A)"
apply (rule cons_eq [THEN subst])
apply (blast intro: singleton_in_DPow Un_in_DPow)
done

(*Part of Lemma 1.3*)
lemma Fin_into_DPow: "X \<in> Fin(A) \<Longrightarrow> X \<in> DPow(A)"
apply (erule Fin.induct)
 apply (rule empty_in_DPow)
apply (blast intro: cons_in_DPow)
done

text\<open>\<^term>\<open>DPow\<close> is not monotonic.  For example, let \<^term>\<open>A\<close> be some
non-constructible set of natural numbers, and let \<^term>\<open>B\<close> be \<^term>\<open>nat\<close>.
Then \<^term>\<open>A<=B\<close> and obviously \<^term>\<open>A \<in> DPow(A)\<close> but \<^term>\<open>A \<notin>
DPow(B)\<close>.\<close>

(*This may be true but the proof looks difficult, requiring relativization
lemma DPow_insert: "DPow (cons(a,A)) = DPow(A) \<union> {cons(a,X) . X \<in> DPow(A)}"
apply (rule equalityI, safe)
oops
*)

lemma Finite_Pow_subset_Pow: "Finite(A) \<Longrightarrow> Pow(A) \<subseteq> DPow(A)"
by (blast intro: Fin_into_DPow Finite_into_Fin Fin_subset)

lemma Finite_DPow_eq_Pow: "Finite(A) \<Longrightarrow> DPow(A) = Pow(A)"
apply (rule equalityI)
apply (rule DPow_subset_Pow)
apply (erule Finite_Pow_subset_Pow)
done

subsection\<open>Internalized Formulas for the Ordinals\<close>

text\<open>The \<open>sats\<close> theorems below differ from the usual form in that they
include an element of absoluteness.  That is, they relate internalized
formulas to real concepts such as the subset relation, rather than to the
relativized concepts defined in theory \<open>Relative\<close>.  This lets us prove
the theorem as \<open>Ords_in_DPow\<close> without first having to instantiate the
locale \<open>M_trivial\<close>.  Note that the present theory does not even take
\<open>Relative\<close> as a parent.\<close>

subsubsection\<open>The subset relation\<close>

definition
  subset_fm :: "[i,i]\<Rightarrow>i" where
  "subset_fm(x,y) \<equiv> Forall(Implies(Member(0,succ(x)), Member(0,succ(y))))"

lemma subset_type [TC]: "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> subset_fm(x,y) \<in> formula"
by (simp add: subset_fm_def)

lemma arity_subset_fm [simp]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> arity(subset_fm(x,y)) = succ(x) \<union> succ(y)"
by (simp add: subset_fm_def succ_Un_distrib [symmetric])

lemma sats_subset_fm [simp]:
   "\<lbrakk>x < length(env); y \<in> nat; env \<in> list(A); Transset(A)\<rbrakk>
    \<Longrightarrow> sats(A, subset_fm(x,y), env) \<longleftrightarrow> nth(x,env) \<subseteq> nth(y,env)"
apply (frule lt_length_in_nat, assumption)
apply (simp add: subset_fm_def Transset_def)
apply (blast intro: nth_type)
done

subsubsection\<open>Transitive sets\<close>

definition
  transset_fm :: "i\<Rightarrow>i" where
  "transset_fm(x) \<equiv> Forall(Implies(Member(0,succ(x)), subset_fm(0,succ(x))))"

lemma transset_type [TC]: "x \<in> nat \<Longrightarrow> transset_fm(x) \<in> formula"
by (simp add: transset_fm_def)

lemma arity_transset_fm [simp]:
     "x \<in> nat \<Longrightarrow> arity(transset_fm(x)) = succ(x)"
by (simp add: transset_fm_def succ_Un_distrib [symmetric])

lemma sats_transset_fm [simp]:
   "\<lbrakk>x < length(env); env \<in> list(A); Transset(A)\<rbrakk>
    \<Longrightarrow> sats(A, transset_fm(x), env) \<longleftrightarrow> Transset(nth(x,env))"
apply (frule lt_nat_in_nat, erule length_type)
apply (simp add: transset_fm_def Transset_def)
apply (blast intro: nth_type)
done

subsubsection\<open>Ordinals\<close>

definition
  ordinal_fm :: "i\<Rightarrow>i" where
  "ordinal_fm(x) \<equiv>
    And(transset_fm(x), Forall(Implies(Member(0,succ(x)), transset_fm(0))))"

lemma ordinal_type [TC]: "x \<in> nat \<Longrightarrow> ordinal_fm(x) \<in> formula"
by (simp add: ordinal_fm_def)

lemma arity_ordinal_fm [simp]:
     "x \<in> nat \<Longrightarrow> arity(ordinal_fm(x)) = succ(x)"
by (simp add: ordinal_fm_def succ_Un_distrib [symmetric])

lemma sats_ordinal_fm:
   "\<lbrakk>x < length(env); env \<in> list(A); Transset(A)\<rbrakk>
    \<Longrightarrow> sats(A, ordinal_fm(x), env) \<longleftrightarrow> Ord(nth(x,env))"
apply (frule lt_nat_in_nat, erule length_type)
apply (simp add: ordinal_fm_def Ord_def Transset_def)
apply (blast intro: nth_type)
done

text\<open>The subset consisting of the ordinals is definable.  Essential lemma for
\<open>Ord_in_Lset\<close>.  This result is the objective of the present subsection.\<close>
theorem Ords_in_DPow: "Transset(A) \<Longrightarrow> {x \<in> A. Ord(x)} \<in> DPow(A)"
apply (simp add: DPow_def Collect_subset)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="ordinal_fm(0)" in bexI)
apply (simp_all add: sats_ordinal_fm)
done

subsection\<open>Constant Lset: Levels of the Constructible Universe\<close>

definition
  Lset :: "i\<Rightarrow>i" where
  "Lset(i) \<equiv> transrec(i, \<lambda>x f. \<Union>y\<in>x. DPow(f`y))"

definition
  L :: "i\<Rightarrow>o" where \<comment> \<open>Kunen's definition VI 1.5, page 167\<close>
  "L(x) \<equiv> \<exists>i. Ord(i) \<and> x \<in> Lset(i)"

text\<open>NOT SUITABLE FOR REWRITING -- RECURSIVE!\<close>
lemma Lset: "Lset(i) = (\<Union>j\<in>i. DPow(Lset(j)))"
by (subst Lset_def [THEN def_transrec], simp)

lemma LsetI: "\<lbrakk>y\<in>x; A \<in> DPow(Lset(y))\<rbrakk> \<Longrightarrow> A \<in> Lset(x)"
by (subst Lset, blast)

lemma LsetD: "A \<in> Lset(x) \<Longrightarrow> \<exists>y\<in>x. A \<in> DPow(Lset(y))"
apply (insert Lset [of x])
apply (blast intro: elim: equalityE)
done

subsubsection\<open>Transitivity\<close>

lemma elem_subset_in_DPow: "\<lbrakk>X \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> X \<in> DPow(A)"
apply (simp add: Transset_def DPow_def)
apply (rule_tac x="[X]" in bexI)
 apply (rule_tac x="Member(0,1)" in bexI)
  apply (auto simp add: Un_least_lt_iff)
done

lemma Transset_subset_DPow: "Transset(A) \<Longrightarrow> A \<subseteq> DPow(A)"
apply clarify
apply (simp add: Transset_def)
apply (blast intro: elem_subset_in_DPow)
done

lemma Transset_DPow: "Transset(A) \<Longrightarrow> Transset(DPow(A))"
apply (simp add: Transset_def)
apply (blast intro: elem_subset_in_DPow dest: DPowD)
done

text\<open>Kunen's VI 1.6 (a)\<close>
lemma Transset_Lset: "Transset(Lset(i))"
apply (rule_tac a=i in eps_induct)
apply (subst Lset)
apply (blast intro!: Transset_Union_family Transset_Un Transset_DPow)
done

lemma mem_Lset_imp_subset_Lset: "a \<in> Lset(i) \<Longrightarrow> a \<subseteq> Lset(i)"
apply (insert Transset_Lset)
apply (simp add: Transset_def)
done

subsubsection\<open>Monotonicity\<close>

text\<open>Kunen's VI 1.6 (b)\<close>
lemma Lset_mono [rule_format]:
     "\<forall>j. i<=j \<longrightarrow> Lset(i) \<subseteq> Lset(j)"
proof (induct i rule: eps_induct, intro allI impI)
  fix x j
  assume "\<forall>y\<in>x. \<forall>j. y \<subseteq> j \<longrightarrow> Lset(y) \<subseteq> Lset(j)"
     and "x \<subseteq> j"
  thus "Lset(x) \<subseteq> Lset(j)"
    by (force simp add: Lset [of x] Lset [of j])
qed

text\<open>This version lets us remove the premise \<^term>\<open>Ord(i)\<close> sometimes.\<close>
lemma Lset_mono_mem [rule_format]:
     "\<forall>j. i \<in> j \<longrightarrow> Lset(i) \<subseteq> Lset(j)"
proof (induct i rule: eps_induct, intro allI impI)
  fix x j
  assume "\<forall>y\<in>x. \<forall>j. y \<in> j \<longrightarrow> Lset(y) \<subseteq> Lset(j)"
     and "x \<in> j"
  thus "Lset(x) \<subseteq> Lset(j)"
    by (force simp add: Lset [of j]
              intro!: bexI intro: elem_subset_in_DPow dest: LsetD DPowD)
qed

text\<open>Useful with Reflection to bump up the ordinal\<close>
lemma subset_Lset_ltD: "\<lbrakk>A \<subseteq> Lset(i); i < j\<rbrakk> \<Longrightarrow> A \<subseteq> Lset(j)"
by (blast dest: ltD [THEN Lset_mono_mem])

subsubsection\<open>0, successor and limit equations for Lset\<close>

lemma Lset_0 [simp]: "Lset(0) = 0"
by (subst Lset, blast)

lemma Lset_succ_subset1: "DPow(Lset(i)) \<subseteq> Lset(succ(i))"
by (subst Lset, rule succI1 [THEN RepFunI, THEN Union_upper])

lemma Lset_succ_subset2: "Lset(succ(i)) \<subseteq> DPow(Lset(i))"
apply (subst Lset, rule UN_least)
apply (erule succE)
 apply blast
apply clarify
apply (rule elem_subset_in_DPow)
 apply (subst Lset)
 apply blast
apply (blast intro: dest: DPowD Lset_mono_mem)
done

lemma Lset_succ: "Lset(succ(i)) = DPow(Lset(i))"
by (intro equalityI Lset_succ_subset1 Lset_succ_subset2)

lemma Lset_Union [simp]: "Lset(\<Union>(X)) = (\<Union>y\<in>X. Lset(y))"
apply (subst Lset)
apply (rule equalityI)
 txt\<open>first inclusion\<close>
 apply (rule UN_least)
 apply (erule UnionE)
 apply (rule subset_trans)
  apply (erule_tac [2] UN_upper, subst Lset, erule UN_upper)
txt\<open>opposite inclusion\<close>
apply (rule UN_least)
apply (subst Lset, blast)
done

subsubsection\<open>Lset applied to Limit ordinals\<close>

lemma Limit_Lset_eq:
    "Limit(i) \<Longrightarrow> Lset(i) = (\<Union>y\<in>i. Lset(y))"
by (simp add: Lset_Union [symmetric] Limit_Union_eq)

lemma lt_LsetI: "\<lbrakk>a \<in> Lset(j);  j<i\<rbrakk> \<Longrightarrow> a \<in> Lset(i)"
by (blast dest: Lset_mono [OF le_imp_subset [OF leI]])

lemma Limit_LsetE:
    "\<lbrakk>a \<in> Lset(i);  \<not>R \<Longrightarrow> Limit(i);
        \<And>x. \<lbrakk>x<i;  a \<in> Lset(x)\<rbrakk> \<Longrightarrow> R
\<rbrakk> \<Longrightarrow> R"
apply (rule classical)
apply (rule Limit_Lset_eq [THEN equalityD1, THEN subsetD, THEN UN_E])
  prefer 2 apply assumption
 apply blast
apply (blast intro: ltI  Limit_is_Ord)
done

subsubsection\<open>Basic closure properties\<close>

lemma zero_in_Lset: "y \<in> x \<Longrightarrow> 0 \<in> Lset(x)"
by (subst Lset, blast intro: empty_in_DPow)

lemma notin_Lset: "x \<notin> Lset(x)"
apply (rule_tac a=x in eps_induct)
apply (subst Lset)
apply (blast dest: DPowD)
done

subsection\<open>Constructible Ordinals: Kunen's VI 1.9 (b)\<close>

lemma Ords_of_Lset_eq: "Ord(i) \<Longrightarrow> {x\<in>Lset(i). Ord(x)} = i"
apply (erule trans_induct3)
  apply (simp_all add: Lset_succ Limit_Lset_eq Limit_Union_eq)
txt\<open>The successor case remains.\<close>
apply (rule equalityI)
txt\<open>First inclusion\<close>
 apply clarify
 apply (erule Ord_linear_lt, assumption)
   apply (blast dest: DPow_imp_subset ltD notE [OF notin_Lset])
  apply blast
 apply (blast dest: ltD)
txt\<open>Opposite inclusion, \<^term>\<open>succ(x) \<subseteq> DPow(Lset(x)) \<inter> ON\<close>\<close>
apply auto
txt\<open>Key case:\<close>
  apply (erule subst, rule Ords_in_DPow [OF Transset_Lset])
 apply (blast intro: elem_subset_in_DPow dest: OrdmemD elim: equalityE)
apply (blast intro: Ord_in_Ord)
done

lemma Ord_subset_Lset: "Ord(i) \<Longrightarrow> i \<subseteq> Lset(i)"
by (subst Ords_of_Lset_eq [symmetric], assumption, fast)

lemma Ord_in_Lset: "Ord(i) \<Longrightarrow> i \<in> Lset(succ(i))"
apply (simp add: Lset_succ)
apply (subst Ords_of_Lset_eq [symmetric], assumption,
       rule Ords_in_DPow [OF Transset_Lset])
done

lemma Ord_in_L: "Ord(i) \<Longrightarrow> L(i)"
by (simp add: L_def, blast intro: Ord_in_Lset)

subsubsection\<open>Unions\<close>

lemma Union_in_Lset:
     "X \<in> Lset(i) \<Longrightarrow> \<Union>(X) \<in> Lset(succ(i))"
apply (insert Transset_Lset)
apply (rule LsetI [OF succI1])
apply (simp add: Transset_def DPow_def)
apply (intro conjI, blast)
txt\<open>Now to create the formula \<^term>\<open>\<exists>y. y \<in> X \<and> x \<in> y\<close>\<close>
apply (rule_tac x="Cons(X,Nil)" in bexI)
 apply (rule_tac x="Exists(And(Member(0,2), Member(1,0)))" in bexI)
  apply typecheck
apply (simp add: succ_Un_distrib [symmetric], blast)
done

theorem Union_in_L: "L(X) \<Longrightarrow> L(\<Union>(X))"
by (simp add: L_def, blast dest: Union_in_Lset)

subsubsection\<open>Finite sets and ordered pairs\<close>

lemma singleton_in_Lset: "a \<in> Lset(i) \<Longrightarrow> {a} \<in> Lset(succ(i))"
by (simp add: Lset_succ singleton_in_DPow)

lemma doubleton_in_Lset:
     "\<lbrakk>a \<in> Lset(i);  b \<in> Lset(i)\<rbrakk> \<Longrightarrow> {a,b} \<in> Lset(succ(i))"
by (simp add: Lset_succ empty_in_DPow cons_in_DPow)

lemma Pair_in_Lset:
    "\<lbrakk>a \<in> Lset(i);  b \<in> Lset(i); Ord(i)\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> Lset(succ(succ(i)))"
  unfolding Pair_def
apply (blast intro: doubleton_in_Lset)
done

lemmas Lset_UnI1 = Un_upper1 [THEN Lset_mono [THEN subsetD]]
lemmas Lset_UnI2 = Un_upper2 [THEN Lset_mono [THEN subsetD]]

text\<open>Hard work is finding a single \<^term>\<open>j \<in> i\<close> such that \<^term>\<open>{a,b} \<subseteq> Lset(j)\<close>\<close>
lemma doubleton_in_LLimit:
    "\<lbrakk>a \<in> Lset(i);  b \<in> Lset(i);  Limit(i)\<rbrakk> \<Longrightarrow> {a,b} \<in> Lset(i)"
apply (erule Limit_LsetE, assumption)
apply (erule Limit_LsetE, assumption)
apply (blast intro: lt_LsetI [OF doubleton_in_Lset]
                    Lset_UnI1 Lset_UnI2 Limit_has_succ Un_least_lt)
done

theorem doubleton_in_L: "\<lbrakk>L(a); L(b)\<rbrakk> \<Longrightarrow> L({a, b})"
apply (simp add: L_def, clarify)
apply (drule Ord2_imp_greater_Limit, assumption)
apply (blast intro: lt_LsetI doubleton_in_LLimit Limit_is_Ord)
done

lemma Pair_in_LLimit:
    "\<lbrakk>a \<in> Lset(i);  b \<in> Lset(i);  Limit(i)\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> Lset(i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_LsetE, assumption)
apply (erule Limit_LsetE, assumption)
txt\<open>Infer that \<^term>\<open>succ(succ(x \<union> xa)) < i\<close>\<close>
apply (blast intro: lt_Ord lt_LsetI [OF Pair_in_Lset]
                    Lset_UnI1 Lset_UnI2 Limit_has_succ Un_least_lt)
done

text\<open>The rank function for the constructible universe\<close>
definition
  lrank :: "i\<Rightarrow>i" where \<comment> \<open>Kunen's definition VI 1.7\<close>
  "lrank(x) \<equiv> \<mu> i. x \<in> Lset(succ(i))"

lemma L_I: "\<lbrakk>x \<in> Lset(i); Ord(i)\<rbrakk> \<Longrightarrow> L(x)"
by (simp add: L_def, blast)

lemma L_D: "L(x) \<Longrightarrow> \<exists>i. Ord(i) \<and> x \<in> Lset(i)"
by (simp add: L_def)

lemma Ord_lrank [simp]: "Ord(lrank(a))"
by (simp add: lrank_def)

lemma Lset_lrank_lt [rule_format]: "Ord(i) \<Longrightarrow> x \<in> Lset(i) \<longrightarrow> lrank(x) < i"
apply (erule trans_induct3)
  apply simp
 apply (simp only: lrank_def)
 apply (blast intro: Least_le)
apply (simp_all add: Limit_Lset_eq)
apply (blast intro: ltI Limit_is_Ord lt_trans)
done

text\<open>Kunen's VI 1.8.  The proof is much harder than the text would
suggest.  For a start, it needs the previous lemma, which is proved by
induction.\<close>
lemma Lset_iff_lrank_lt: "Ord(i) \<Longrightarrow> x \<in> Lset(i) \<longleftrightarrow> L(x) \<and> lrank(x) < i"
apply (simp add: L_def, auto)
 apply (blast intro: Lset_lrank_lt)
   unfolding lrank_def
apply (drule succI1 [THEN Lset_mono_mem, THEN subsetD])
apply (drule_tac P="\<lambda>i. x \<in> Lset(succ(i))" in LeastI, assumption)
apply (blast intro!: le_imp_subset Lset_mono [THEN subsetD])
done

lemma Lset_succ_lrank_iff [simp]: "x \<in> Lset(succ(lrank(x))) \<longleftrightarrow> L(x)"
by (simp add: Lset_iff_lrank_lt)

text\<open>Kunen's VI 1.9 (a)\<close>
lemma lrank_of_Ord: "Ord(i) \<Longrightarrow> lrank(i) = i"
  unfolding lrank_def
apply (rule Least_equality)
  apply (erule Ord_in_Lset)
 apply assumption
apply (insert notin_Lset [of i])
apply (blast intro!: le_imp_subset Lset_mono [THEN subsetD])
done

text\<open>This is lrank(lrank(a)) = lrank(a)\<close>
declare Ord_lrank [THEN lrank_of_Ord, simp]

text\<open>Kunen's VI 1.10\<close>
lemma Lset_in_Lset_succ: "Lset(i) \<in> Lset(succ(i))"
apply (simp add: Lset_succ DPow_def)
apply (rule_tac x=Nil in bexI)
 apply (rule_tac x="Equal(0,0)" in bexI)
apply auto
done

lemma lrank_Lset: "Ord(i) \<Longrightarrow> lrank(Lset(i)) = i"
  unfolding lrank_def
apply (rule Least_equality)
  apply (rule Lset_in_Lset_succ)
 apply assumption
apply clarify
apply (subgoal_tac "Lset(succ(ia)) \<subseteq> Lset(i)")
 apply (blast dest: mem_irrefl)
apply (blast intro!: le_imp_subset Lset_mono)
done

text\<open>Kunen's VI 1.11\<close>
lemma Lset_subset_Vset: "Ord(i) \<Longrightarrow> Lset(i) \<subseteq> Vset(i)"
apply (erule trans_induct)
apply (subst Lset)
apply (subst Vset)
apply (rule UN_mono [OF subset_refl])
apply (rule subset_trans [OF DPow_subset_Pow])
apply (rule Pow_mono, blast)
done

text\<open>Kunen's VI 1.12\<close>
lemma Lset_subset_Vset': "i \<in> nat \<Longrightarrow> Lset(i) = Vset(i)"
apply (erule nat_induct)
 apply (simp add: Vfrom_0)
apply (simp add: Lset_succ Vset_succ Finite_Vset Finite_DPow_eq_Pow)
done

text\<open>Every set of constructible sets is included in some \<^term>\<open>Lset\<close>\<close>
lemma subset_Lset:
     "(\<forall>x\<in>A. L(x)) \<Longrightarrow> \<exists>i. Ord(i) \<and> A \<subseteq> Lset(i)"
by (rule_tac x = "\<Union>x\<in>A. succ(lrank(x))" in exI, force)

lemma subset_LsetE:
     "\<lbrakk>\<forall>x\<in>A. L(x);
        \<And>i. \<lbrakk>Ord(i); A \<subseteq> Lset(i)\<rbrakk> \<Longrightarrow> P\<rbrakk>
      \<Longrightarrow> P"
by (blast dest: subset_Lset)

subsubsection\<open>For L to satisfy the Powerset axiom\<close>

lemma LPow_env_typing:
    "\<lbrakk>y \<in> Lset(i); Ord(i); y \<subseteq> X\<rbrakk>
     \<Longrightarrow> \<exists>z \<in> Pow(X). y \<in> Lset(succ(lrank(z)))"
by (auto intro: L_I iff: Lset_succ_lrank_iff)

lemma LPow_in_Lset:
     "\<lbrakk>X \<in> Lset(i); Ord(i)\<rbrakk> \<Longrightarrow> \<exists>j. Ord(j) \<and> {y \<in> Pow(X). L(y)} \<in> Lset(j)"
apply (rule_tac x="succ(\<Union>y \<in> Pow(X). succ(lrank(y)))" in exI)
apply simp
apply (rule LsetI [OF succI1])
apply (simp add: DPow_def)
apply (intro conjI, clarify)
 apply (rule_tac a=x in UN_I, simp+)
txt\<open>Now to create the formula \<^term>\<open>y \<subseteq> X\<close>\<close>
apply (rule_tac x="Cons(X,Nil)" in bexI)
 apply (rule_tac x="subset_fm(0,1)" in bexI)
  apply typecheck
 apply (rule conjI)
apply (simp add: succ_Un_distrib [symmetric])
apply (rule equality_iffI)
apply (simp add: Transset_UN [OF Transset_Lset] LPow_env_typing)
apply (auto intro: L_I iff: Lset_succ_lrank_iff)
done

theorem LPow_in_L: "L(X) \<Longrightarrow> L({y \<in> Pow(X). L(y)})"
by (blast intro: L_I dest: L_D LPow_in_Lset)

subsection\<open>Eliminating \<^term>\<open>arity\<close> from the Definition of \<^term>\<open>Lset\<close>\<close>

lemma nth_zero_eq_0: "n \<in> nat \<Longrightarrow> nth(n,[0]) = 0"
by (induct_tac n, auto)

lemma sats_app_0_iff [rule_format]:
  "\<lbrakk>p \<in> formula; 0 \<in> A\<rbrakk>
   \<Longrightarrow> \<forall>env \<in> list(A). sats(A,p, env@[0]) \<longleftrightarrow> sats(A,p,env)"
apply (induct_tac p)
apply (simp_all del: app_Cons add: app_Cons [symmetric]
                add: nth_zero_eq_0 nth_append not_lt_iff_le nth_eq_0)
done

lemma sats_app_zeroes_iff:
  "\<lbrakk>p \<in> formula; 0 \<in> A; env \<in> list(A); n \<in> nat\<rbrakk>
   \<Longrightarrow> sats(A,p,env @ repeat(0,n)) \<longleftrightarrow> sats(A,p,env)"
apply (induct_tac n, simp)
apply (simp del: repeat.simps
            add: repeat_succ_app sats_app_0_iff app_assoc [symmetric])
done

lemma exists_bigger_env:
  "\<lbrakk>p \<in> formula; 0 \<in> A; env \<in> list(A)\<rbrakk>
   \<Longrightarrow> \<exists>env' \<in> list(A). arity(p) \<le> succ(length(env')) \<and>
              (\<forall>a\<in>A. sats(A,p,Cons(a,env')) \<longleftrightarrow> sats(A,p,Cons(a,env)))"
apply (rule_tac x="env @ repeat(0,arity(p))" in bexI)
apply (simp del: app_Cons add: app_Cons [symmetric]
            add: length_repeat sats_app_zeroes_iff, typecheck)
done

text\<open>A simpler version of \<^term>\<open>DPow\<close>: no arity check!\<close>
definition
  DPow' :: "i \<Rightarrow> i" where
  "DPow'(A) \<equiv> {X \<in> Pow(A).
                \<exists>env \<in> list(A). \<exists>p \<in> formula.
                    X = {x\<in>A. sats(A, p, Cons(x,env))}}"

lemma DPow_subset_DPow': "DPow(A) \<subseteq> DPow'(A)"
by (simp add: DPow_def DPow'_def, blast)

lemma DPow'_0: "DPow'(0) = {0}"
by (auto simp add: DPow'_def)

lemma DPow'_subset_DPow: "0 \<in> A \<Longrightarrow> DPow'(A) \<subseteq> DPow(A)"
apply (auto simp add: DPow'_def DPow_def)
apply (frule exists_bigger_env, assumption+, force)
done

lemma DPow_eq_DPow': "Transset(A) \<Longrightarrow> DPow(A) = DPow'(A)"
apply (drule Transset_0_disj)
apply (erule disjE)
 apply (simp add: DPow'_0 Finite_DPow_eq_Pow)
apply (rule equalityI)
 apply (rule DPow_subset_DPow')
apply (erule DPow'_subset_DPow)
done

text\<open>And thus we can relativize \<^term>\<open>Lset\<close> without bothering with
      \<^term>\<open>arity\<close> and \<^term>\<open>length\<close>\<close>
lemma Lset_eq_transrec_DPow': "Lset(i) = transrec(i, \<lambda>x f. \<Union>y\<in>x. DPow'(f`y))"
apply (rule_tac a=i in eps_induct)
apply (subst Lset)
apply (subst transrec)
apply (simp only: DPow_eq_DPow' [OF Transset_Lset], simp)
done

text\<open>With this rule we can specify \<^term>\<open>p\<close> later and don't worry about
      arities at all!\<close>
lemma DPow_LsetI [rule_format]:
  "\<lbrakk>\<forall>x\<in>Lset(i). P(x) \<longleftrightarrow> sats(Lset(i), p, Cons(x,env));
     env \<in> list(Lset(i));  p \<in> formula\<rbrakk>
   \<Longrightarrow> {x\<in>Lset(i). P(x)} \<in> DPow(Lset(i))"
by (simp add: DPow_eq_DPow' [OF Transset_Lset] DPow'_def, blast)

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_weird_nat_add3_assoc3
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((add3 x1 (add3 x2 x3 x4) x5) = (add3 x1 x2 (add3 x3 x4 x5)))"
  oops

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Pre-Conway Algebra *}

theory Conway
  imports "../DRA_Base" Test_Dioids
begin

text {*
  We define a weak regular algebra with serves as a common basis for Kleene algebra and demonic reginement algebra.
  It is closely related to an axiomatisation given by Conway~\cite{Conway71}.
*}

class dagger_op =
  fixes dagger :: "'a \<Rightarrow> 'a" ("_\<^sup>\<dagger>" [101] 100)

class near_regalg_base_zerol = near_dioid_one_zerol + dagger_op +
  assumes dagger_denest: "(x + y)\<^sup>\<dagger> = (x\<^sup>\<dagger>\<cdot>y)\<^sup>\<dagger>\<cdot>x\<^sup>\<dagger>"
  and dagger_prod_unfold: "(x \<cdot>y)\<^sup>\<dagger> = 1 + x \<cdot>(y \<cdot>x)\<^sup>\<dagger>\<cdot>y"

begin

lemma dagger_unfoldl: "1 + x \<cdot> x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (metis dagger_prod_unfold mult_1_left mult_1_right)

text {* Nitpick refutes the next lemma. *}

lemma dagger_unfoldl_distl: "y\<cdot>x\<^sup>\<dagger> = y + y\<cdot>x\<cdot>x\<^sup>\<dagger>"
  (* nitpick *) oops

lemma dagger_unfoldl_distr: "x\<^sup>\<dagger>\<cdot>y = y + x\<cdot>x\<^sup>\<dagger>\<cdot>y"
  by (metis distrib_right' mult_1_left dagger_unfoldl)

lemma dagger_unfoldr: "1 + x\<^sup>\<dagger> \<cdot> x = x\<^sup>\<dagger>"
  by (metis dagger_prod_unfold mult_1_right mult_1_left)

text {* Nitpick refutes the next lemma. *}

lemma dagger_unfoldr_distl: "y\<cdot>x\<^sup>\<dagger> = y + y\<cdot>x\<^sup>\<dagger>\<cdot>x"
  (* nitpick *) oops

lemma dagger_unfoldr_distr: "x\<^sup>\<dagger>\<cdot>y = y + x\<^sup>\<dagger>\<cdot>x\<cdot>y"
  by (metis dagger_unfoldr distrib_right' mult_1_left mult.assoc)

lemma dagger_annil[simp]: "(x\<cdot>0)\<^sup>\<dagger> = 1 + x\<cdot>0"
  by (metis annil dagger_unfoldl mult.assoc)

lemma zero_dagger[simp]: "0\<^sup>\<dagger> = 1"
  by (metis add_0_right annil dagger_annil)

text {* Nitpick refutes the next lemma. *}

lemma dagger_denest2: "(x + y)\<^sup>\<dagger> = x\<^sup>\<dagger>\<cdot>(y\<cdot>x\<^sup>\<dagger>)\<^sup>\<dagger>"
  (* (* nitpick *) *) oops

end

class near_conway_sim_right_zerol = near_regalg_base_zerol + plus_ord +
  assumes dagger_simr: "z\<cdot>x \<le> y\<cdot>z \<Longrightarrow> z\<cdot>x\<^sup>\<dagger> \<le> y\<^sup>\<dagger>\<cdot>z"
begin

lemma dagger_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<dagger> \<le> y\<^sup>\<dagger>"
  by (metis dagger_simr mult_1_left mult_1_right)

lemma dagger_slide_var: "x\<cdot>(y\<cdot>x)\<^sup>\<dagger> \<le> (x\<cdot>y)\<^sup>\<dagger>\<cdot>x"
  by (metis eq_refl dagger_simr mult.assoc)

text {* Nitpick refutes the next lemma. *}

lemma dagger_slide: "x\<cdot>(y\<cdot>x)\<^sup>\<dagger> = (x\<cdot>y)\<^sup>\<dagger>\<cdot>x"
  (* nitpick *) oops

text {*
  We say that $y$ preserves $x$ if $x \cdot y \cdot x = x \cdot y$ and $!x \cdot y \cdot !x = !x \cdot y$. This definition is taken
  from Solin~\cite{Solin11}. It is useful for program transformation.
*}

lemma preservation: "x\<cdot>y\<cdot>x = x\<cdot>y \<Longrightarrow> x\<cdot>y\<^sup>\<dagger> \<le> (x\<cdot>y + z)\<^sup>\<dagger>\<cdot>x"
  by (metis add_ub1 dagger_simr mult_isor)

end

class near_conway_sim_right_zerol_tests = near_conway_sim_right_zerol + near_dioid_test_zerol_dist
begin

lemma test_preserve1_var: "\<lbrakk>test p; p\<cdot>x\<cdot>p = p\<cdot>x\<rbrakk> \<Longrightarrow> p\<cdot>(p\<cdot>x + !p\<cdot>y)\<^sup>\<dagger> \<le> (p\<cdot>x)\<^sup>\<dagger>\<cdot>p"
  by (metis eq_refl test_eq2 dagger_simr)

text {* The next lemma could neither be proved nor refuted by nitpick. *}

lemma test_preserve2_var: "\<lbrakk>test p; p\<cdot>x\<cdot>p = p\<cdot>x\<rbrakk> \<Longrightarrow> p\<cdot>(p\<cdot>x + !p\<cdot>y)\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  oops (* couldn't proof neither (* nitpick *) *)

end

class pre_conway = near_conway_sim_right_zerol + pre_dioid_test_zerol
begin

subclass near_conway_sim_right_zerol_tests
  by (unfold_locales)

lemma dagger_slide: "x\<cdot>(y\<cdot>x)\<^sup>\<dagger> = (x\<cdot>y)\<^sup>\<dagger>\<cdot>x"
  by (metis add.commute dagger_prod_unfold add_lub_var mult_1_right mult.assoc subdistl dagger_slide_var dagger_unfoldl_distr antisym)

lemma dagger_denest2: "(x + y)\<^sup>\<dagger> = x\<^sup>\<dagger>\<cdot>(y\<cdot>x\<^sup>\<dagger>)\<^sup>\<dagger>"
  by (metis dagger_denest dagger_slide)

lemma test_preserve: "\<lbrakk>test p; p\<cdot>x\<cdot>p = p\<cdot>x\<rbrakk> \<Longrightarrow> p\<cdot>x\<^sup>\<dagger> = (p\<cdot>x)\<^sup>\<dagger>\<cdot>p"
proof (rule antisym, metis add_0_right dagger_slide mult.assoc preservation)
  assume "test p" "p\<cdot>x\<cdot>p = p\<cdot>x"
  hence "x\<cdot>p \<le> x"
    by (metis test_restrictr)
  hence "p\<cdot>(x\<cdot>p)\<^sup>\<dagger> \<le> p\<cdot>x\<^sup>\<dagger>"
    by (metis dagger_iso mult_isol)
  thus "(p \<cdot> x)\<^sup>\<dagger> \<cdot> p \<le> p \<cdot> x\<^sup>\<dagger>"
    by (metis dagger_slide)
qed

lemma test_dumb_var: "\<lbrakk>test p; p\<cdot>x\<cdot>p = p\<cdot>x\<rbrakk> \<Longrightarrow> p\<cdot>(p\<cdot>x + !p\<cdot>y)\<cdot>p = p\<cdot>(p\<cdot>x + !p\<cdot>y)"
proof -
  assume assms: "test p" "p\<cdot>x\<cdot>p = p\<cdot>x"
  hence "p\<cdot>(p\<cdot>x + !p\<cdot>y)\<cdot>p = p\<cdot>x"
    by (metis mult.assoc weak_distrib_left_var test_mult_idem_var annil test_comp_mult add_zeror)
  moreover have "p\<cdot>(p\<cdot>x + !p\<cdot>y) = p\<cdot>x"
    by (metis assms mult.assoc weak_distrib_left_var test_mult_idem_var annil test_comp_mult add_zeror)
  ultimately show ?thesis
    by metis
qed

lemma test_preserve2: "\<lbrakk>test p; p\<cdot>x\<cdot>p = p\<cdot>x\<rbrakk> \<Longrightarrow> p\<cdot>(p\<cdot>x + !p\<cdot>y)\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  by (metis test_preserve test_preserve1 test_restrictl)

end

end


(*
  File:     Power_Sum_Polynomials_Library.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Auxiliary material\<close>
theory Power_Sum_Polynomials_Library
imports
  "Polynomial_Factorization.Fundamental_Theorem_Algebra_Factorized"
  "Symmetric_Polynomials.Symmetric_Polynomials"
  "HOL-Computational_Algebra.Computational_Algebra"
begin

subsection \<open>Miscellaneous\<close>

lemma atLeastAtMost_nat_numeral:
  "atLeastAtMost m (numeral k :: nat) =
     (if m \<le> numeral k then insert (numeral k) (atLeastAtMost m (pred_numeral k))
                 else {})"
  by (simp add: numeral_eq_Suc atLeastAtMostSuc_conv)

lemma sum_in_Rats [intro]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<rat>) \<Longrightarrow> sum f A \<in> \<rat>"
  by (induction A rule: infinite_finite_induct) auto

(* TODO Move *)
lemma (in monoid_mult) prod_list_distinct_conv_prod_set:
  "distinct xs \<Longrightarrow> prod_list (map f xs) = prod f (set xs)"
  by (induct xs) simp_all

lemma (in monoid_mult) interv_prod_list_conv_prod_set_nat:
  "prod_list (map f [m..<n]) = prod f (set [m..<n])"
  by (simp add: prod_list_distinct_conv_prod_set)

lemma (in monoid_mult) prod_list_prod_nth:
  "prod_list xs = (\<Prod>i = 0..< length xs. xs ! i)"
  using interv_prod_list_conv_prod_set_nat [of "(!) xs" 0 "length xs"] by (simp add: map_nth)

lemma gcd_poly_code_aux_reduce:
  "gcd_poly_code_aux p 0 = normalize p"
  "q \<noteq> 0 \<Longrightarrow> gcd_poly_code_aux p q = gcd_poly_code_aux q (primitive_part (pseudo_mod p q))"
  by (subst gcd_poly_code_aux.simps; simp)+

lemma coprime_pderiv_imp_squarefree:
  assumes "coprime p (pderiv p)"
  shows   "squarefree p"
proof (rule squarefreeI)
  fix d assume d: "d ^ 2 dvd p"
  then obtain q where q: "p = d ^ 2 * q"
    by (elim dvdE)
  hence "d dvd p" "d dvd pderiv p"
    by (auto simp: pderiv_mult pderiv_power_Suc numeral_2_eq_2)
  with assms show "is_unit d"
    using not_coprimeI by blast
qed

lemma squarefree_field_poly_iff:
  fixes p :: "'a :: {field_char_0,euclidean_ring_gcd,semiring_gcd_mult_normalize} poly"
  assumes [simp]: "p \<noteq> 0"
  shows "squarefree p \<longleftrightarrow> coprime p (pderiv p)"
proof
  assume "squarefree p"
  show "coprime p (pderiv p)"
  proof (rule coprimeI_primes)
    fix d assume d: "d dvd p" "d dvd pderiv p" "prime d"
    from d(1) obtain q where q: "p = d * q"
      by (elim dvdE)
    from d(2) and q have "d dvd q * pderiv d"
      by (simp add: pderiv_mult dvd_add_right_iff)
    with \<open>prime d\<close> have "d dvd q \<or> d dvd pderiv d"
      using prime_dvd_mult_iff by blast
    thus False
    proof
      assume "d dvd q"
      hence "d ^ 2 dvd p"
        by (auto simp: q power2_eq_square)
      with \<open>squarefree p\<close> show False
        using d(3) not_prime_unit squarefreeD by blast
    next
      assume "d dvd pderiv d"
      hence "Polynomial.degree d = 0" by simp
      moreover have "d \<noteq> 0" using d by auto
      ultimately show False
        using d(3) is_unit_iff_degree not_prime_unit by blast
    qed
  qed auto
qed (use coprime_pderiv_imp_squarefree[of p] in auto)

lemma coprime_pderiv_imp_rsquarefree:
  assumes "coprime (p :: 'a :: field_char_0 poly) (pderiv p)"
  shows   "rsquarefree p"
  unfolding rsquarefree_roots
proof safe
  fix x assume "poly p x = 0" "poly (pderiv p) x = 0"
  hence "[:-x, 1:] dvd p" "[:-x, 1:] dvd pderiv p"
    by (auto simp: poly_eq_0_iff_dvd)
  with assms have "is_unit [:-x, 1:]"
    using not_coprimeI by blast
  thus False by auto
qed

lemma poly_of_nat [simp]: "poly (of_nat n) x = of_nat n"
  by (induction n) auto

lemma poly_of_int [simp]: "poly (of_int n) x = of_int n"
  by (cases n) auto

lemma order_eq_0_iff: "p \<noteq> 0 \<Longrightarrow> order x p = 0 \<longleftrightarrow> poly p x \<noteq> 0"
  by (auto simp: order_root)

lemma order_pos_iff: "p \<noteq> 0 \<Longrightarrow> order x p > 0 \<longleftrightarrow> poly p x = 0"
  by (auto simp: order_root)

lemma order_prod:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0"
  shows   "order x (\<Prod>y\<in>A. f y) = (\<Sum>y\<in>A. order x (f y))"
  using assms by (induction A rule: infinite_finite_induct) (auto simp: order_mult)

lemma order_prod_mset:
  assumes "0 \<notin># A"
  shows   "order x (prod_mset A) = sum_mset (image_mset (order x) A)"
  using assms by (induction A) (auto simp: order_mult)

lemma order_prod_list:
  assumes "0 \<notin> set xs"
  shows   "order x (prod_list xs) = sum_list (map (order x) xs)"
  using assms by (induction xs) (auto simp: order_mult)

lemma order_power: "p \<noteq> 0 \<Longrightarrow> order x (p ^ n) = n * order x p"
  by (induction n) (auto simp: order_mult)

lemma smult_0_right [simp]: "MPoly_Type.smult p 0 = 0"
  by (transfer, transfer) auto

lemma mult_smult_right [simp]:
  fixes c :: "'a :: comm_semiring_0"
  shows "p * MPoly_Type.smult c q = MPoly_Type.smult c (p * q)"
  by (simp add: smult_conv_mult mult_ac)

lemma mapping_single_eq_iff [simp]:
  "Poly_Mapping.single a b = Poly_Mapping.single c d \<longleftrightarrow> b = 0 \<and> d = 0 \<or> a = c \<and> b = d"
  by transfer (unfold fun_eq_iff when_def, metis)

lemma monom_of_set_plus_monom_of_set:
  assumes "A \<inter> B = {}" "finite A" "finite B"
  shows   "monom_of_set A + monom_of_set B = monom_of_set (A \<union> B)"
  using assms by transfer (auto simp: fun_eq_iff)

lemma mpoly_monom_0_eq_Const: "monom 0 c = Const c"
  by (intro mpoly_eqI) (auto simp: coeff_monom when_def mpoly_coeff_Const)

lemma mpoly_Const_0 [simp]: "Const 0 = 0"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const mpoly_coeff_0)

lemma mpoly_Const_1 [simp]: "Const 1 = 1"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const mpoly_coeff_1)

lemma mpoly_Const_uminus: "Const (-a) = -Const a"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const)

lemma mpoly_Const_add: "Const (a + b) = Const a + Const b"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const)

lemma mpoly_Const_mult: "Const (a * b) = Const a * Const b"
  unfolding mpoly_monom_0_eq_Const [symmetric] mult_monom by simp

lemma mpoly_Const_power: "Const (a ^ n) = Const a ^ n"
  by (induction n) (auto simp: mpoly_Const_mult)

lemma of_nat_mpoly_eq: "of_nat n = Const (of_nat n)"
proof (induction n)
  case 0
  have "0 = (Const 0 :: 'a mpoly)"
    by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const)
  thus ?case
    by simp
next
  case (Suc n)
  have "1 + Const (of_nat n) = Const (1 + of_nat n)"
    by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const mpoly_coeff_1)
  thus ?case
    using Suc by auto
qed

lemma insertion_of_nat [simp]: "insertion f (of_nat n) = of_nat n"
  by (simp add: of_nat_mpoly_eq)

lemma insertion_monom_of_set [simp]:
  "insertion f (monom (monom_of_set X) c) = c * (\<Prod>i\<in>X. f i)"
proof (cases "finite X")
  case [simp]: True
  have "insertion f (monom (monom_of_set X) c) = c * (\<Prod>a. f a ^ (if a \<in> X then 1 else 0))"
    by (auto simp: lookup_monom_of_set)
  also have "(\<Prod>a. f a ^ (if a \<in> X then 1 else 0)) = (\<Prod>i\<in>X. f i ^ (if i \<in> X then 1 else 0))"
    by (intro Prod_any.expand_superset) auto
  also have "\<dots> = (\<Prod>i\<in>X. f i)"
    by (intro prod.cong) auto
  finally show ?thesis .
qed (auto simp: lookup_monom_of_set)

(* TODO: Move! Version in AFP is too weak! *)
lemma symmetric_mpoly_symmetric_sum:
  assumes "\<And>\<pi>. \<pi> permutes A \<Longrightarrow> g \<pi> permutes X"
  assumes "\<And>x \<pi>. x \<in> X \<Longrightarrow> \<pi> permutes A \<Longrightarrow> mpoly_map_vars \<pi> (f x) = f (g \<pi> x)"
  shows "symmetric_mpoly A (\<Sum>x\<in>X. f x)"
  unfolding symmetric_mpoly_def
proof safe
  fix \<pi> assume \<pi>: "\<pi> permutes A"
  have "mpoly_map_vars \<pi> (sum f X) = (\<Sum>x\<in>X. mpoly_map_vars \<pi> (f x))"
    by simp
  also have "\<dots> = (\<Sum>x\<in>X. f (g \<pi> x))"
    by (intro sum.cong assms \<pi> refl)
  also have "\<dots> = (\<Sum>x\<in>g \<pi>`X. f x)"
    using assms(1)[OF \<pi>] by (subst sum.reindex) (auto simp: permutes_inj_on)
  also have "g \<pi> ` X = X"
    using assms(1)[OF \<pi>] by (simp add: permutes_image)
  finally show "mpoly_map_vars \<pi> (sum f X) = sum f X" .
qed

lemma sym_mpoly_0 [simp]:
  assumes "finite A"
  shows   "sym_mpoly A 0 = 1"
  using assms by (transfer, transfer) (auto simp: fun_eq_iff when_def)

lemma sym_mpoly_eq_0 [simp]:
  assumes "k > card A"
  shows   "sym_mpoly A k = 0"
proof (transfer fixing: A k, transfer fixing: A k, intro ext)
  fix mon
  have "\<not>(finite A \<and> (\<exists>Y\<subseteq>A. card Y = k \<and> mon = monom_of_set Y))"
  proof safe
    fix Y assume Y: "finite A" "Y \<subseteq> A" "k = card Y" "mon = monom_of_set Y"
    hence "card Y \<le> card A" by (intro card_mono) auto
    with Y and assms show False by simp
  qed
  thus "(if finite A \<and> (\<exists>Y\<subseteq>A. card Y = k \<and> mon = monom_of_set Y) then 1 else 0) = 0"
    by auto
qed

lemma coeff_sym_mpoly_monom_of_set_eq_0:
  assumes "finite X" "Y \<subseteq> X" "card Y \<noteq> k"
  shows   "MPoly_Type.coeff (sym_mpoly X k) (monom_of_set Y) = 0"
  using assms finite_subset[of _ X] by (auto simp: coeff_sym_mpoly)

lemma coeff_sym_mpoly_monom_of_set_eq_0':
  assumes "finite X" "\<not>Y \<subseteq> X" "finite Y"
  shows   "MPoly_Type.coeff (sym_mpoly X k) (monom_of_set Y) = 0"
  using assms finite_subset[of _ X] by (auto simp: coeff_sym_mpoly)

subsection \<open>The set of roots of a univariate polynomial\<close>

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"
  show "(\<lambda>x. if p = 0 then 0 else order x p) \<in> multiset"
    by (cases "p = 0") (auto simp: multiset_def order_pos_iff poly_roots_finite)
qed

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

lemma poly_roots_1 [simp]: "poly_roots 1 = {#}"
  by transfer auto

lemma count_poly_roots [simp]:
  assumes "p \<noteq> 0"
  shows   "count (poly_roots p) x = order x p"
  using assms by transfer auto

lemma in_poly_roots_iff [simp]: "p \<noteq> 0 \<Longrightarrow> x \<in># poly_roots p \<longleftrightarrow> poly p x = 0"
  by (subst count_greater_zero_iff [symmetric], subst count_poly_roots) (auto simp: order_pos_iff)

lemma set_mset_poly_roots: "p \<noteq> 0 \<Longrightarrow> set_mset (poly_roots p) = {x. poly p x = 0}"
  using in_poly_roots_iff[of p] by blast

lemma count_poly_roots': "count (poly_roots p) x = (if p = 0 then 0 else order x p)"
  by transfer' auto

lemma poly_roots_const [simp]: "poly_roots [:c:] = {#}"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_eq_0_iff)

lemma poly_roots_linear [simp]: "poly_roots [:-x, 1:] = {#x#}"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_eq_0_iff)

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

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

lemma poly_roots_mult: "p \<noteq> 0 \<Longrightarrow> q \<noteq> 0 \<Longrightarrow> poly_roots (p * q) = poly_roots p + poly_roots q"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_mult)

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_prod_mset:
  assumes "0 \<notin># A"
  shows   "poly_roots (prod_mset A) = sum_mset (image_mset poly_roots A)"
  using assms by (induction A) (auto simp: poly_roots_mult)

lemma poly_roots_prod_list:
  assumes "0 \<notin> set xs"
  shows   "poly_roots (prod_list xs) = sum_list (map poly_roots xs)"
  using assms by (induction xs) (auto simp: poly_roots_mult)

lemma poly_roots_power: "p \<noteq> 0 \<Longrightarrow> poly_roots (p ^ n) = repeat_mset n (poly_roots p)"
  by (induction n) (auto simp: poly_roots_mult)

lemma rsquarefree_poly_roots_eq:
  assumes "rsquarefree p"
  shows   "poly_roots p = mset_set {x. poly p x = 0}"
proof (rule multiset_eqI)
  fix x :: 'a
  from assms show "count (poly_roots p) x = count (mset_set {x. poly p x = 0}) x"
    by (cases "poly p x = 0") (auto simp: poly_roots_finite order_eq_0_iff rsquarefree_def)
qed

lemma rsquarefree_imp_distinct_roots:
  assumes "rsquarefree p" and "mset xs = poly_roots p"
  shows   "distinct xs"
proof (cases "p = 0")
  case [simp]: False
  have *: "mset xs = mset_set {x. poly p x = 0}"
    using assms by (simp add: rsquarefree_poly_roots_eq)
  hence "set_mset (mset xs) = set_mset (mset_set {x. poly p x = 0})"
    by (simp only: )
  hence [simp]: "set xs = {x. poly p x = 0}"
    by (simp add: poly_roots_finite)
  from * show ?thesis
    by (subst distinct_count_atmost_1) (auto simp: poly_roots_finite)
qed (use assms in auto)

lemma poly_roots_factorization:
  fixes p c A
  assumes [simp]: "c \<noteq> 0"
  defines "p \<equiv> Polynomial.smult c (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) A))"
  shows   "poly_roots p = A"
proof -
  have "poly_roots p = poly_roots (\<Prod>x\<in>#A. [:-x, 1:])"
    by (auto simp: p_def)
  also have "\<dots> = A"
    by (subst poly_roots_prod_mset) (auto simp: image_mset.compositionality o_def)
  finally show ?thesis .
qed

lemma fundamental_theorem_algebra_factorized':
  fixes p :: "complex poly"
  shows "p = Polynomial.smult (Polynomial.lead_coeff p)
               (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) (poly_roots p)))"
proof (cases "p = 0")
  case [simp]: False
  obtain xs where
    xs: "Polynomial.smult (Polynomial.lead_coeff p) (\<Prod>x\<leftarrow>xs. [:-x, 1:]) = p"
        "length xs = Polynomial.degree p"
    using fundamental_theorem_algebra_factorized[of p] by auto
  define A where "A = mset xs"

  note xs(1)
  also have "(\<Prod>x\<leftarrow>xs. [:-x, 1:]) = prod_mset (image_mset (\<lambda>x. [:-x, 1:]) A)"
    unfolding A_def by (induction xs) auto
  finally have *: "Polynomial.smult (Polynomial.lead_coeff p) (\<Prod>x\<in>#A. [:- x, 1:]) = p" .
  also have "A = poly_roots p"
    using poly_roots_factorization[of "Polynomial.lead_coeff p" A]
    by (subst * [symmetric]) auto
  finally show ?thesis ..
qed auto

lemma poly_roots_eq_imp_eq:
  fixes p q :: "complex poly"
  assumes "Polynomial.lead_coeff p = Polynomial.lead_coeff q"
  assumes "poly_roots p = poly_roots q"
  shows   "p = q"
proof (cases "p = 0 \<or> q = 0")
  case False
  hence [simp]: "p \<noteq> 0" "q \<noteq> 0"
    by auto
  have "p = Polynomial.smult (Polynomial.lead_coeff p)
               (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) (poly_roots p)))"
    by (rule fundamental_theorem_algebra_factorized')
  also have "\<dots> = Polynomial.smult (Polynomial.lead_coeff q)
                   (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) (poly_roots q)))"
    by (simp add: assms)
  also have "\<dots> = q"
    by (rule fundamental_theorem_algebra_factorized' [symmetric])
  finally show ?thesis .
qed (use assms in auto)

lemma Sum_any_zeroI': "(\<And>x. P x \<Longrightarrow> f x = 0) \<Longrightarrow> Sum_any (\<lambda>x. f x when P x) = 0"
  by (auto simp: Sum_any.expand_set)

(* TODO: This was not really needed here, but it is important nonetheless.
   It should go in the Symmetric_Polynomials entry. *)
lemma sym_mpoly_insert:
  assumes "finite X" "x \<notin> X"
  shows   "(sym_mpoly (insert x X) (Suc k) :: 'a :: semiring_1 mpoly) =
             monom (monom_of_set {x}) 1 * sym_mpoly X k + sym_mpoly X (Suc k)" (is "?lhs = ?A + ?B")
proof (rule mpoly_eqI)
  fix mon
  show "coeff ?lhs mon = coeff (?A + ?B) mon"
  proof (cases "\<forall>i. lookup mon i \<le> 1 \<and> (i \<notin> insert x X \<longrightarrow> lookup mon i = 0)")
    case False
    then obtain i where i: "lookup mon i > 1 \<or> i \<notin> insert x X \<and> lookup mon i > 0"
      by (auto simp: not_le)

    have "coeff ?A mon = prod_fun (coeff (monom (monom_of_set {x}) 1))
                                  (coeff (sym_mpoly X k)) mon"
      by (simp add: coeff_mpoly_times)
    also have "\<dots> = (\<Sum>l. \<Sum>q. coeff (monom (monom_of_set {x}) 1) l * coeff (sym_mpoly X k) q
                         when mon = l + q)"
        unfolding prod_fun_def
        by (intro Sum_any.cong, subst Sum_any_right_distrib, force)
           (auto simp: Sum_any_right_distrib when_def intro!: Sum_any.cong)
    also have "\<dots> = 0"
    proof (rule Sum_any_zeroI, rule Sum_any_zeroI')
      fix ma mb assume *: "mon = ma + mb"
      show "coeff (monom (monom_of_set {x}) (1::'a)) ma * coeff (sym_mpoly X k) mb = 0"
      proof (cases "i = x")
        case [simp]: True
        show ?thesis
        proof (cases "lookup mb i > 0")
          case True
          hence "coeff (sym_mpoly X k) mb = 0" using \<open>x \<notin> X\<close>
            by (auto simp: coeff_sym_mpoly lookup_monom_of_set split: if_splits)
          thus ?thesis
            using mult_not_zero by blast
        next
          case False
          hence "coeff (monom (monom_of_set {x}) 1) ma = 0"
            using i by (auto simp: coeff_monom when_def * lookup_add)
          thus ?thesis
            using mult_not_zero by blast
        qed
      next
        case [simp]: False
        show ?thesis
        proof (cases "lookup ma i > 0")
          case False
          hence "lookup mb i = lookup mon i"
            using * by (auto simp: lookup_add)
          hence "coeff (sym_mpoly X k) mb = 0" using i
            by (auto simp: coeff_sym_mpoly lookup_monom_of_set split: if_splits)
          thus ?thesis
            using mult_not_zero by blast
        next
          case True
          hence "coeff (monom (monom_of_set {x}) 1) ma = 0"
            using i by (auto simp: coeff_monom when_def * lookup_add)
          thus ?thesis
            using mult_not_zero by blast
        qed
      qed
    qed
    finally have "coeff ?A mon = 0" .
    moreover from False have "coeff ?lhs mon = 0"
      by (subst coeff_sym_mpoly) (auto simp: lookup_monom_of_set split: if_splits)
    moreover from False have "coeff (sym_mpoly X (Suc k)) mon = 0"
      by (subst coeff_sym_mpoly) (auto simp: lookup_monom_of_set split: if_splits)
    ultimately show ?thesis
      by auto
  next
    case True
    define A where "A = keys mon"
    have A: "A \<subseteq> insert x X"
      using True by (auto simp: A_def)
    have [simp]: "mon = monom_of_set A"
      unfolding A_def using True by transfer (force simp: fun_eq_iff le_Suc_eq)
    have "finite A"
      using finite_subset A assms by blast
    show ?thesis
    proof (cases "x \<in> A")
      case False
      have "coeff ?A mon = prod_fun (coeff (monom (monom_of_set {x}) 1))
                                    (coeff (sym_mpoly X k)) (monom_of_set A)"
        by (simp add: coeff_mpoly_times)
      also have "\<dots> = (\<Sum>l. \<Sum>q. coeff (monom (monom_of_set {x}) 1) l * coeff (sym_mpoly X k) q
                         when monom_of_set A = l + q)"
        unfolding prod_fun_def
        by (intro Sum_any.cong, subst Sum_any_right_distrib, force)
           (auto simp: Sum_any_right_distrib when_def intro!: Sum_any.cong)
      also have "\<dots> = 0"
      proof (rule Sum_any_zeroI, rule Sum_any_zeroI')
        fix ma mb assume *: "monom_of_set A = ma + mb"
        hence "keys ma \<subseteq> A"
          using \<open>finite A\<close> by transfer (auto simp: fun_eq_iff split: if_splits)
        thus "coeff (monom (monom_of_set {x}) (1::'a)) ma * coeff (sym_mpoly X k) mb = 0"
          using \<open>x \<notin> A\<close> by (auto simp: coeff_monom when_def)
      qed
      finally show ?thesis
        using False A assms finite_subset[of _ "insert x X"] finite_subset[of _ X]
        by (auto simp: coeff_sym_mpoly)
    next
      case True
      have "mon = monom_of_set {x} + monom_of_set (A - {x})"
        using \<open>x \<in> A\<close> \<open>finite A\<close> by (auto simp: monom_of_set_plus_monom_of_set)
      also have "coeff ?A \<dots> = coeff (sym_mpoly X k) (monom_of_set (A - {x}))"
        by (subst coeff_monom_mult) auto
      also have "\<dots> = (if card A = Suc k then 1 else 0)"
      proof (cases "card A = Suc k")
        case True
        thus ?thesis
          using assms \<open>finite A\<close> \<open>x \<in> A\<close> A
          by (subst coeff_sym_mpoly_monom_of_set) auto
      next
        case False
        thus ?thesis
          using assms \<open>x \<in> A\<close> A \<open>finite A\<close> card_Suc_Diff1[of A x]
          by (subst coeff_sym_mpoly_monom_of_set_eq_0) auto
      qed
      moreover have "coeff ?B (monom_of_set A) = 0"
        using assms \<open>x \<in> A\<close> \<open>finite A\<close>
        by (subst coeff_sym_mpoly_monom_of_set_eq_0') auto
      moreover have "coeff ?lhs (monom_of_set A) = (if card A = Suc k then 1 else 0)"
        using assms A \<open>finite A\<close> finite_subset[of _ "insert x X"] by (auto simp: coeff_sym_mpoly)
      ultimately show ?thesis by simp
    qed
  qed
qed

end