theory StateTransformers
  imports "../Algebra/PartialQuantales"
begin

no_notation plus (infixl "+" 65)
no_notation pmult (infixl "*" 80)
no_notation pmult_one ("1")
notation pmult (infixl "\<oplus>" 80)
notation times (infixl "*" 70)
notation sup (infixl "+" 65)
notation inf (infixl "\<sqinter>" 70)
notation one_class.one ("1")

text{*
  State transformers are functions from state to predicates, abstractly, from commutative
  partial monoid to quantales
*}

text {*
  If the domain is a partial semigroup and the image is a quantale, it forms a quantale
*}

instantiation "fun" :: (partial_semigroup, quantale_Sup) quantale_Sup
begin

definition "f * g \<equiv> \<lambda>x. \<Squnion> {f y * g z | y z. x = y \<oplus> z \<and> y ## z}"

lemma qmult_apply [simp, code]:
  "(f * g) x \<equiv> \<Squnion> {f y * g z | y z. x = y \<oplus> z \<and> y ## z}"
  by (simp add: times_fun_def)

lemma sup_distrib_left_fun: "(f * (g + h)) x = (f * g + f * h) x"
  by (subst qmult_apply, subst sup_apply, subst Sup.qdistl) simp

lemma sup_distrib_right_fun: "((f + g) * h) x = (f * h + g * h) x"
  by (subst qmult_apply, subst sup_apply, subst Sup.qdistr) simp

lemma qSup_distl_fun: "(f * \<Squnion>G) x = (\<Squnion>(op * f ` G)) x"
  apply (auto simp add: qSUP_distl intro!: antisym Sup_least SUP_mono)
  apply (metis (lifting, mono_tags) Sup_upper mem_Collect_eq)
  by (auto intro!: SUP_least Sup_mono) (metis SUP_upper)

lemma qSup_distr_fun: "(\<Squnion>G * f) x = (\<Squnion>((\<lambda>g. g * f) ` G)) x"
  apply (auto simp add: qSUP_distr intro!: antisym Sup_least SUP_mono)
  apply (metis (lifting, mono_tags) Sup_upper mem_Collect_eq)
  by (auto intro!: SUP_least Sup_mono) (metis SUP_upper)

lemma Sup_distl_assoc: "(f :: 'a \<Rightarrow> 'b) y * \<Squnion>{g y' * h z' |y' z' :: 'a. z = y' \<oplus> z' \<and> y' ## z'} = \<Squnion>{f y * (g y' * h z') |y' z'. z = y' \<oplus> z' \<and> y' ## z'}"
  by (auto simp only: Sup.Join_distl intro: Sup.Join_eqI2)

lemma qSup_distr_assoc: "\<Squnion>{((f :: 'a \<Rightarrow> 'b) y * g y') | y y' :: 'a. z = (y \<oplus> y') \<and> y ## y'} * h z' = \<Squnion>{(f y * g y') * h z' | y y'. z = (y \<oplus> y') \<and> y ## y'}"
  by (auto simp only: qSup_distr intro: Sup.Join_eqI2)

lemma qmult_assoc_fun: "(f * (g * h)) x = ((f * g) * h) x"
proof -
  have "(f * (g * h)) x = \<Squnion> {\<Squnion> {(f y * g y') * h z' | y' z'. z = y' \<oplus> z' \<and> y' ## z'} | y z. x = y \<oplus> z \<and> y ## z}"
    by (simp add: Sup_distl_assoc mult.assoc)
  also have "... = \<Squnion> {(f y * g y') * h z' | y' z' y z. z = y' \<oplus> z' \<and> y' ## z' \<and> x = y \<oplus> z \<and> y ## z}"
    apply (rule antisym, rule Sup_least, safe, rule Sup_mono, auto, rule Sup_least, auto)
    apply (subgoal_tac "\<exists>ya z. y \<oplus> (y' \<oplus> z') = ya \<oplus> z \<and> ya ## z \<and> f y * g y' * h z' \<le> \<Squnion>{f ya * g y' * h z' |y' z'. z = y' \<oplus> z' \<and> y' ## z'}")
    apply (smt Sup_upper2 mem_Collect_eq)
    by (smt Sup_le_iff dual_order.refl mem_Collect_eq)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y'. y' ## z' \<and> x = y \<oplus> (y' \<oplus> z') \<and> y ## (y' \<oplus> z')}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y'. y ## y' \<and> x = (y \<oplus> y') \<oplus> z' \<and> (y \<oplus> y') ## z'}"
    by (metis (hide_lams, no_types) partial_semigroup_class.pmult_assoc partial_semigroup_class.pmult_def)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y' z. z = (y \<oplus> y') \<and> y ## y' \<and> x = z \<oplus> z' \<and> z ## z'}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion>{ \<Squnion>{(f y * g y') * h z' | y y'. z = (y \<oplus> y') \<and> y ## y'} | z z'. x = z \<oplus> z' \<and> z ## z'}"
    apply (rule antisym, rule Sup_least, auto)
    apply (subgoal_tac "\<exists>z z'a. y \<oplus> y' \<oplus> z' = z \<oplus> z'a \<and> z ## z'a \<and> f y * g y' * h z' \<le> \<Squnion>{f y * g y' * h z'a |y y'. z = y \<oplus> y' \<and> y ## y'}")
    apply (smt Sup_upper2 mem_Collect_eq)
    apply (smt Sup_le_iff dual_order.refl mem_Collect_eq)
    by (rule Sup_least, safe, rule Sup_mono, auto)
  finally show ?thesis
    by (simp add: qSup_distr_assoc)
qed

instance
  apply default
  apply (rule ext, rule qmult_assoc_fun[symmetric])
  apply (rule ext, rule qSup_distr_fun)
  by (metis (lifting, mono_tags) qSup_distl_fun eq_iff le_funI)+

end

text {* Unit is also lifted *}

instantiation "fun" :: (partial_monoid, quantale_Sup_unital) quantale_Sup_unital
begin

definition
  "1 \<equiv> \<lambda>x. if x = 1' then 1 else \<bottom>"

lemma qunitl_fun[simp]: "(1 * f) x = f x"
  by (auto simp: pmult_onel one_fun_def intro!: Sup_eqI)

lemma qunitr_fun[simp]: "(f * 1) x = f x"
  by (auto simp: pmult_oner one_fun_def intro!: Sup_eqI)

instance
  by default  (auto intro: qunitr_fun qunitl_fun)

end

text {* Commutativity is also lifted *}

instance "fun" :: (partial_ab_semigroup, comm_quantale_Sup) comm_quantale_Sup
proof (default, simp_all add: mult.assoc, rule ext)
  fix f g :: "'a :: partial_ab_semigroup \<Rightarrow> 'b :: comm_quantale_Sup"
  fix x :: "'a :: partial_ab_semigroup"
  have "(f * g) x = \<Squnion> {f y * g z | y z. x = y \<oplus> z \<and> y ## z}" by simp
  also have "... = \<Squnion> {g z * f y | z y. x = z \<oplus> y \<and> z ## y}"
    apply (auto intro!: Sup.Join_eqI2)
    by (metis mult.commute pmult_comm pmult_comm_def)+
  finally show "(f * g) x = (g * f) x" by simp
qed

instance "fun" :: (partial_comm_monoid, comm_quantale_Sup_unital) comm_quantale_Sup_unital
  by default auto

text {* Distributivity is also lifted *}

instance "fun" :: (partial_semigroup, distrib_quantale_Sup) distrib_quantale_Sup ..

instance "fun" :: (partial_comm_monoid, distrib_comm_quantale_Sup_unital) distrib_comm_quantale_Sup_unital ..

end


theory Compiler imports BigStep_sseefried Star
begin

subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro: star.step exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the execution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = if f then size cb2 else (size cb2::int)+n;
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end


theory Montanari_Contrasim_Set_Game
imports
  Simple_Game
  Montanari_Weak_Relations
  Montanari_Weak_Transition_Systems
begin

subsection \<open>The Contrasimulation Preorder Set Game\<close>

datatype ('s, 'a) c_set_game_node =
  AttackerNode 's "'s set" |
  DefenderSimNode 'a 's "'s set" |
  DefenderSwapNode 's "'s set"

fun (in lts_tau) c_set_game_moves ::
  \<open>('s, 'a) c_set_game_node \<Rightarrow> ('s, 'a) c_set_game_node \<Rightarrow> bool\<close> where

  simulation_challenge:
   \<open>c_set_game_moves (AttackerNode p Q) (DefenderSimNode a p1 Q0) =
     (p \<Rightarrow>a p1 \<and> Q = Q0 \<and> \<not> tau a)\<close> |

  simulation_answer:
    \<open>c_set_game_moves (DefenderSimNode a p1 Q) (AttackerNode p10 Q1) =
      (p1 = p10 \<and> Q1 = succs a Q \<and> Q1 \<noteq> {})\<close> |

  swap_challenge:
    \<open>c_set_game_moves (AttackerNode p Q) (DefenderSwapNode p1 Q0) =
     (p \<Rightarrow>^\<tau> p1 \<and> Q = Q0)\<close> |

  swap_answer:
    \<open>c_set_game_moves (DefenderSwapNode p1 Q) (AttackerNode q1 P1) =
      (q1 \<in> succs \<tau> Q \<and> P1 = {p1})\<close> |

  c_set_game_moves_no_step:
    \<open>c_set_game_moves _ _ = False\<close>

fun c_set_game_defender_node :: \<open>('s, 'a) c_set_game_node \<Rightarrow> bool\<close> where
  \<open>c_set_game_defender_node (AttackerNode _ _) = False\<close> |
  \<open>c_set_game_defender_node (DefenderSimNode _ _ _) = True\<close> |
  \<open>c_set_game_defender_node (DefenderSwapNode _ _) = True\<close>

subsection \<open>Contrasimulation Implies Winning Strategy (Completeness)\<close>

locale c_set_game =
  lts_tau trans \<tau> +
  simple_game c_set_game_moves c_set_game_defender_node initial
for
  trans :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close> and
  \<tau> :: \<open>'a\<close> and
  initial :: \<open>('s, 'a) c_set_game_node\<close>
begin

fun strategy_from_ZR_C :: \<open>('s \<Rightarrow> ('s set) \<Rightarrow> bool) \<Rightarrow> ('s, 'a) c_set_game_node strategy\<close>
  where

  \<open>strategy_from_ZR_C R ((DefenderSwapNode p1 Q)#play) =
    (AttackerNode (SOME q1 . (\<exists>q. (q \<in> Q \<and> q  \<Rightarrow>^\<tau> q1)) \<and> R q1 {p1}) {p1})\<close> |

  \<open>strategy_from_ZR_C R ((DefenderSimNode a p1 Q)#play) =
    (AttackerNode p1 (SOME Q1 . Q1 = succs a Q \<and> R p1 Q1 \<and> Q1 \<noteq> {}))\<close> |

  \<open>strategy_from_ZR_C _ _ = undefined\<close>

lemma set_defender_pred_is_attacker:
  assumes
    \<open>c_set_game_defender_node n0\<close>
    \<open>(n0#play) \<in> plays\<close>
    \<open>initial = AttackerNode p0 Q0\<close>
  shows \<open>\<exists>p Q. (hd play) = AttackerNode p Q \<and> c_set_game_moves (hd play) n0\<close>
proof -
  have \<open>n0 \<noteq> initial\<close> using assms (1, 3) by auto
  hence mov: \<open>c_set_game_moves (hd play) n0\<close> using assms(2)
    by (metis list.inject list.sel(1) plays.cases)
  from assms(1) have def_cases: \<open>\<exists>p1 Q. ((\<exists>a. n0 = DefenderSimNode a p1 Q) \<or> n0 = DefenderSwapNode p1 Q)\<close>
    using c_set_game_defender_node.elims(2) by blast
  then obtain p1 Q where pQ_def: \<open>(\<exists>a. n0 = DefenderSimNode a p1 Q) \<or> n0 = DefenderSwapNode p1 Q\<close>
    by auto
  hence \<open>\<exists>p. (hd play) = AttackerNode p Q\<close>
  proof (rule disjE)
    assume \<open>\<exists>a. n0 = DefenderSimNode a p1 Q\<close>
    then obtain a where a_def: \<open>n0 = DefenderSimNode a p1 Q\<close> ..
    thus ?thesis using  c_set_game_moves.elims(2)[OF mov] c_set_game_node.distinct(5) by auto
  next
    assume \<open>n0 = DefenderSwapNode p1 Q\<close>
    thus ?thesis using c_set_game_moves.elims(2)[OF mov] c_set_game_node.distinct(5) by auto
  qed
  thus ?thesis using mov by auto
qed

lemma second_elem_in_play_set :
  assumes
    \<open>(n0#play) \<in> plays\<close>
    \<open>initial = AttackerNode p0 Q0\<close>
    \<open>c_set_game_defender_node n0\<close>
  shows \<open>hd play \<in> set (n0 # play)\<close>
proof -
  from assms(2, 3) have \<open>n0 \<noteq> initial\<close>by auto
  hence \<open>play \<in> plays\<close> using assms(1) plays.cases no_empty_plays by blast
  hence play_split: \<open>\<exists>x xs. play = x#xs\<close> using no_empty_plays
    using plays.cases by blast
  then obtain x where x_def: \<open>\<exists>xs. play = x#xs\<close> ..
  have x_in_set: \<open>x \<in> set (n0#play)\<close> using x_def by auto
  have x_head: \<open>x = hd play\<close> using x_def by auto
  from x_in_set x_head show \<open>hd play \<in> set (n0 # play)\<close> by auto
qed

lemma def_sim_or_swap_before_atkNode:
  assumes
    \<open>c_set_game_moves n0 n1\<close>
    \<open>n1 = AttackerNode p Q\<close>
  shows
    \<open>(\<exists>Qpred a. n0 = (DefenderSimNode a p Qpred)) \<or> (\<exists>q Ppred. n0 = (DefenderSwapNode q Ppred) \<and> Q = {q})\<close>
proof (cases n0 rule: c_set_game_node.exhaust)
  case (AttackerNode s T)
  hence \<open>c_set_game_moves (AttackerNode s T) (AttackerNode p Q)\<close> using assms by auto
  hence \<open>False\<close> by simp
  then show ?thesis by auto
next
  case (DefenderSimNode a s T)
  then show ?thesis using assms by auto
next
  case (DefenderSwapNode s T)
  hence \<open>c_set_game_moves (DefenderSwapNode s T) (AttackerNode p Q)\<close> using assms by auto
  then show ?thesis using DefenderSwapNode by auto
qed

lemma set_game_all_f_consistent_atk_pos_in_ZR:
  assumes
    \<open>contrasim C\<close>
    \<open>C p0 q0\<close>
    \<open>initial = AttackerNode p0 {q0}\<close>
    \<open>play \<in> plays_for_strategy (strategy_from_ZR_C (ZR (set_type C)))\<close>
  shows \<open>n = AttackerNode p Q \<Longrightarrow> n \<in> set play \<Longrightarrow> ZR (set_type C) p Q \<close>
proof (induct arbitrary: n p Q rule: plays_for_strategy.induct[OF assms(4)])
  case init: 1
  hence \<open>n = initial\<close> by auto
  hence \<open>p = p0 \<and> Q = {q0}\<close> using assms(3) init.prems(1) by auto
  thus  \<open>ZR (set_type C) p Q\<close> using assms R_is_in_ZR set_type_def by simp
next
  case p0moved: (2 n0 play)
  hence \<open>(n = strategy_from_ZR_C (ZR (set_type C)) (n0 # play)) \<or> (n \<in> set (n0#play))\<close> by auto
  thus ?case
  proof(rule disjE)
    assume \<open>n \<in> set (n0#play)\<close>
    thus ?thesis using p0moved.prems p0moved.hyps(1,2) by blast
  next
    assume strat: \<open>n = strategy_from_ZR_C (ZR (set_type C)) (n0 # play)\<close>
    hence \<open>(\<exists>a Qpred. n0 = DefenderSimNode a p Qpred) \<or> (\<exists>q Ppred. n0 = DefenderSwapNode q Ppred \<and> Q = {q})\<close>
      using def_sim_or_swap_before_atkNode[OF p0moved.hyps(4), of \<open>p\<close> \<open>Q\<close>] p0moved.prems(1) by blast
    thus ?case
    proof (rule disjE)
      assume \<open>\<exists>a Qpred. n0 = DefenderSimNode a p Qpred\<close>
      then obtain a Qpred where n0_def: \<open>n0 = DefenderSimNode a p Qpred\<close> by auto
      hence \<open>strategy_from_ZR_C (ZR (set_type C)) (n0#play)
          = AttackerNode p (SOME Q1. Q1 = succs a Qpred \<and> (ZR (set_type C)) p Q1 \<and> Q1 \<noteq> {})\<close>
        using strategy_from_ZR_C.simps(2) by auto
      hence Q_def: \<open>Q = (SOME Q1. Q1 = succs a Qpred \<and> (ZR (set_type C)) p Q1  \<and> Q1 \<noteq> {})\<close>
        using strat by (simp add: p0moved.prems(1))
      have \<open>\<exists>ppred. hd play = (AttackerNode ppred Qpred) \<and> c_set_game_moves (hd play) n0\<close>
        using set_defender_pred_is_attacker strategy_plays_subset[OF p0moved.hyps(1)]
          assms(3, 4) n0_def by force
      then obtain ppred where ppred_def: \<open>hd play = (AttackerNode ppred Qpred)\<close>
          and \<open>c_set_game_moves (hd play) n0\<close> by auto
      hence \<open>ppred \<Rightarrow>a p\<close> \<open>a \<noteq> \<tau>\<close> using n0_def by auto
      hence \<open>hd play \<in> set (n0 # play)\<close>
        using second_elem_in_play_set strategy_plays_subset[OF p0moved.hyps(1)] assms(3) n0_def
        by (simp add: assms(4))
      hence \<open>ZR (set_type C) ppred Qpred\<close> using p0moved.hyps(2) ppred_def by blast
      hence \<open>succs a Qpred \<noteq> {} \<and> ZR (set_type C) p (succs a Qpred)\<close>
       using \<open>ppred \<Rightarrow>a p\<close> assms(1,2,4) ZR_C_guarantees_action_succ \<open>a \<noteq> \<tau>\<close> by auto
      hence \<open>\<exists>Q. Q = (succs a Qpred) \<and> ZR (set_type C) p Q\<close> by auto
      from someI_ex[OF this] show \<open>ZR (set_type C) p Q\<close>
        unfolding Q_def
        using n0_def p0moved.hyps(4) by auto
    next
      assume \<open>(\<exists>q Ppred. n0 = DefenderSwapNode q Ppred \<and> Q = {q})\<close>
      then obtain q Ppred where n0_def: \<open>n0 = DefenderSwapNode q Ppred\<close> and Q_def: \<open>Q = {q}\<close>
        by auto
      hence \<open>strategy_from_ZR_C (ZR (set_type C)) (n0#play)
         = AttackerNode (SOME p1. (\<exists>p. p \<in> Ppred \<and> p \<Rightarrow>^\<tau> p1) \<and> (ZR (set_type C)) p1 {q}) {q}\<close>
        using strategy_from_ZR_C.simps(1) by auto
      hence p_def: \<open>p = (SOME p1. (\<exists>p. p \<in> Ppred \<and> p \<Rightarrow>^\<tau> p1) \<and> (ZR (set_type C)) p1 {q})\<close>
        using strat p0moved.prems by auto
      have \<open>\<exists>qpred. hd play = (AttackerNode qpred Ppred) \<and> c_set_game_moves (hd play) n0\<close>
        using set_defender_pred_is_attacker strategy_plays_subset[OF p0moved.hyps(1)]
          assms(3, 4) n0_def
        by force
      then obtain qpred where qpred_def: \<open>hd play = (AttackerNode qpred Ppred)\<close>
        and qpred_move: \<open>c_set_game_moves (hd play) n0\<close> by auto
      hence p1: \<open>player1_position (hd play)\<close> by (simp add: player1_position_def)
      have qpred_q_move: \<open>qpred \<Rightarrow>^\<tau> q\<close> using qpred_def qpred_move n0_def by simp
      have \<open>hd play \<in> set (n0 # play)\<close>
        using second_elem_in_play_set strategy_plays_subset[OF p0moved.hyps(1)] assms(3) n0_def
        by (simp add: assms(4))
      hence \<open>ZR (set_type C) qpred Ppred\<close> using p0moved.hyps(2) qpred_def by blast
      hence \<open>\<exists>p. p \<in> succs \<tau> Ppred \<and> ZR (set_type C) p {q}\<close>
        using qpred_q_move assms(1,2) ZR_C_guarantees_tau_succ by blast
      hence \<open>\<exists>p. (\<exists>p0. p0 \<in> Ppred \<and> p0 \<Rightarrow>^\<tau>  p) \<and> ZR (set_type C) p {q}\<close>
        using succs_def[of \<open>\<tau>\<close> \<open>Ppred\<close>] by blast
      from someI_ex[OF this] p_def have \<open>ZR (set_type C) p {q}\<close> by simp
      thus \<open>ZR (set_type C) p Q\<close> using Q_def by blast
    qed
  qed
next
  case p1moved: (3 n1 play n1')
  hence \<open>(n = n1') \<or> (n \<in> set (n1#play))\<close> by auto
  thus ?case
  proof (rule disjE)
    assume \<open>n \<in> set (n1#play)\<close>
    thus ?case using p1moved.prems p1moved.hyps(1,2) by blast
  next
    assume A1: \<open>n = n1'\<close>
    hence \<open>c_set_game_defender_node n1'\<close>
      using def_sim_or_swap_before_atkNode p1moved.hyps(3, 4) p1moved.prems(1)
        player1_position_def by fastforce
    hence \<open>False\<close> using A1 p1moved.prems(1) by auto
    thus ?case by auto
  qed
qed

lemma set_contrasim_game_complete:
  assumes
    \<open>contrasim C\<close>
    \<open>C p0 q0\<close>
    \<open>initial = AttackerNode p0 {q0}\<close>
  shows \<open>player0_winning_strategy (strategy_from_ZR_C (ZR (set_type C)))\<close>
  unfolding player0_winning_strategy_def
proof (safe)
  fix play
  assume A1: \<open>play \<in> (plays_for_strategy (strategy_from_ZR_C (ZR (set_type C))))\<close>
  thus \<open>player1_wins play \<Longrightarrow> False\<close>
    unfolding player1_wins_def
  proof -
    assume A: \<open>c_set_game_defender_node (hd play) \<and> (\<nexists>p'. c_set_game_moves (hd play) p')\<close>
    have player0_has_succ_node: \<open>c_set_game_defender_node (hd play) \<Longrightarrow> \<exists>p'. c_set_game_moves (hd play) p'\<close>
    proof (induct rule: simple_game.plays_for_strategy.induct[OF A1])
      case init: 1
      have \<open>\<not>c_set_game_defender_node (hd [initial])\<close> by (simp add: assms)
      hence \<open>False\<close> using init.prems by simp
      then show ?case ..
    next
      case p0moved: (2 n0 play)
      from p0moved.hyps have \<open>c_set_game_defender_node n0\<close> by simp
      hence \<open>(\<exists>a p1 q. n0 = (DefenderSimNode a p1 q)) \<or> (\<exists>q P. n0 = DefenderSwapNode q P)\<close>
        by (meson c_set_game_defender_node.elims(2))
      hence \<open>\<not>c_set_game_defender_node (strategy_from_ZR_C (ZR (set_type C)) (n0#play))\<close>
        using p0moved.hyps(4)
          c_set_game_moves.elims(2)[of \<open>n0\<close> \<open>strategy_from_ZR_C (ZR (set_type C)) (n0#play)\<close>]
        by force
      hence \<open>\<not>c_set_game_defender_node (hd (strategy_from_ZR_C (ZR (set_type C)) (n0 # play) # n0 # play))\<close>
        by simp
      hence \<open>False\<close> using p0moved.prems ..
      then show ?case ..
    next
      case p1moved: (3 n1 play n1')
      hence \<open>\<not>c_set_game_defender_node n1\<close> using p1moved.hyps and player1_position_def by simp
      then obtain p Q where n1_def: \<open>n1 = AttackerNode p Q\<close>
        using c_set_game_defender_node.elims(3) by auto
      hence ZR: \<open>ZR (set_type C) p Q\<close>
        using set_game_all_f_consistent_atk_pos_in_ZR[OF assms(1-3), of \<open>n1#play\<close>, OF p1moved.hyps(1)]
        by auto
      have \<open>(\<exists>a p1. n1' = DefenderSimNode a p1 Q) \<or> (\<exists>p1. n1' = DefenderSwapNode p1 Q)\<close>
        using p1moved.prems n1_def p1moved.hyps(4)
        by (metis c_set_game_defender_node.elims(2) list.sel(1) local.simulation_challenge local.swap_challenge)
      thus ?case
      proof (rule disjE)
        assume A: \<open>\<exists>a p1. n1' = DefenderSimNode a p1 Q\<close>
        then obtain a p1 where n1'_def : \<open>n1' = DefenderSimNode a p1 Q\<close> by auto
        have move: \<open>c_set_game_moves (AttackerNode p Q) (DefenderSimNode a p1 Q)\<close>
          using p1moved.hyps n1_def n1'_def by auto
        hence \<open>p \<Rightarrow>a p1\<close> by auto
        hence \<open>p \<Rightarrow>^a p1\<close> using weak_step_impl_weak_tau by blast
        hence \<open>succs a Q \<noteq> {} \<and> ZR (set_type C) p1 (succs a Q)\<close>
          using ZR_C_guarantees_action_succ move
          by (metis ZR assms(1) simulation_challenge tau_tau)
        then obtain Q1 where \<open>Q1 = succs a Q \<and> ZR (set_type C) p1 Q1 \<and> Q1 \<noteq> {}\<close> by blast
        hence \<open>c_set_game_moves n1' (AttackerNode p1 Q1)\<close>
          using A n1'_def by auto
        thus \<open>\<exists>a. c_set_game_moves (hd (n1' # n1 # play)) a\<close> by auto
      next
        assume  \<open>\<exists>p1. n1' = DefenderSwapNode p1 Q\<close>
        then obtain p1 where n1'_def: \<open>n1' = DefenderSwapNode p1 Q\<close> ..
        hence \<open>c_set_game_moves (AttackerNode p Q) (DefenderSwapNode p1 Q)\<close>
          using p1moved.hyps(4) n1_def by auto
        hence p_succ: \<open>p \<Rightarrow>^\<tau> p1\<close> by auto
        hence \<open>\<exists>q'. q' \<in> succs \<tau> Q \<and> ZR (set_type C) q' {p1}\<close>
          using ZR ZR_C_guarantees_tau_succ assms(1) by auto
        hence \<open>\<exists>q1. q1 \<in> succs \<tau> Q \<and> ZR (set_type C) q1 {p1}\<close> by auto
        hence \<open>\<exists>q1 P1. c_set_game_moves n1' (AttackerNode q1 P1)\<close> using n1'_def  by auto
        thus \<open>\<exists>a. c_set_game_moves (hd (n1' # n1 # play)) a\<close> by auto
      qed
    qed
    hence \<open>False\<close> using A by auto
    thus ?thesis by auto
  qed
qed

lemma strategy_from_set_contrasim_sound :
  assumes
    \<open>contrasim C\<close>
    \<open>C p0 q0\<close>
    \<open>initial = AttackerNode p0 {q0}\<close>
  shows
    \<open>sound_strategy (strategy_from_ZR_C (ZR (set_type C)))\<close>
  unfolding sound_strategy_def
proof (safe)
  fix n0 play
  assume A:
    \<open>n0 # play \<in> plays_for_strategy (strategy_from_ZR_C (ZR (set_type C)))\<close>
    \<open>c_set_game_defender_node n0\<close>
  hence \<open>(\<exists>a p' Q. n0 = DefenderSimNode a p' Q) \<or> (\<exists>p' Q. n0 = DefenderSwapNode p' Q)\<close>
    by (meson c_set_game_defender_node.elims(2))
  thus \<open>c_set_game_moves n0 (strategy_from_ZR_C (ZR (set_type C)) (n0 # play))\<close>
  proof(rule disjE)
    assume \<open>\<exists>a p' Q. n0 = DefenderSimNode a p' Q\<close>
    then obtain a p' Q where n0_def: \<open>n0 = DefenderSimNode a p' Q\<close> by auto
    then obtain p where p_def: \<open>hd play = AttackerNode p Q\<close> using A
      by (metis assms(3) set_defender_pred_is_attacker simulation_challenge strategy_plays_subset)
    hence \<open>c_set_game_moves (AttackerNode p Q) (DefenderSimNode a p' Q)\<close>
      by (metis A n0_def assms(3) set_defender_pred_is_attacker strategy_plays_subset)
    hence \<open>p \<Rightarrow>a p'\<close> \<open>\<not> tau a\<close> by auto
    hence \<open>ZR (set_type C) p Q\<close>
      using set_game_all_f_consistent_atk_pos_in_ZR[OF assms] A p_def
        assms(3) second_elem_in_play_set strategy_plays_subset
      by fastforce
    hence  \<open>succs a Q \<noteq> {} \<and> ZR (set_type C) p' (succs a Q)\<close>
      using ZR_C_guarantees_action_succ \<open>\<not> tau a\<close> \<open>p \<Rightarrow>a p'\<close> assms(1) tau_tau by blast
    hence Q1_ex: \<open>\<exists>Q'. Q' = succs a Q \<and> ZR (set_type C) p' Q' \<and> Q' \<noteq> {}\<close> by auto
    from n0_def have st: \<open>strategy_from_ZR_C (ZR (set_type C)) (n0#play) =
    (AttackerNode p' (SOME Q1 . Q1 = succs a Q \<and> (ZR (set_type C)) p' Q1 \<and> Q1 \<noteq> {}))\<close> by auto
    then obtain Q1 where
      \<open>AttackerNode p' (SOME Q1 . Q1 = succs a Q \<and> (ZR (set_type C)) p' Q1  \<and> Q1 \<noteq> {}) = AttackerNode p' Q1\<close>
      by blast
    hence Q1_def: \<open>Q1 = (SOME Q1 . Q1 = succs a Q \<and> (ZR (set_type C)) p' Q1 \<and> Q1 \<noteq> {})\<close>
      by auto
    have next_is_atk: \<open>strategy_from_ZR_C (ZR (set_type C)) (n0#play) = (AttackerNode p' Q1)\<close>
      using st Q1_def by auto
    with someI_ex[OF Q1_ex] Q1_def have mov_cond: \<open>Q1 = succs a Q \<and> ZR (set_type C) p' Q1 \<and> Q1 \<noteq> {}\<close>
      by blast
    have \<open>c_set_game_moves n0 (AttackerNode p' Q1)\<close> using n0_def mov_cond by auto
    thus ?thesis using next_is_atk by auto
  next
    assume \<open>\<exists>p' Q. n0 = DefenderSwapNode p' Q\<close>
    then obtain p' Q where n0_def: \<open>n0 = DefenderSwapNode p' Q\<close> by auto
    then obtain p where  p_def: \<open>hd play = AttackerNode p Q\<close> using A
      by (metis assms(3) set_defender_pred_is_attacker swap_challenge strategy_plays_subset)
    hence \<open>c_set_game_moves (AttackerNode p Q) (DefenderSwapNode p' Q)\<close>
      by (metis A n0_def assms(3) set_defender_pred_is_attacker strategy_plays_subset)
    hence \<open>p \<Rightarrow>^\<tau> p'\<close> by auto
    hence \<open>ZR (set_type C) p Q\<close>
      using set_game_all_f_consistent_atk_pos_in_ZR[OF assms] A p_def
        assms(3) second_elem_in_play_set strategy_plays_subset
      by fastforce
    hence  \<open>\<exists>q'. q' \<in> succs \<tau> Q \<and> ZR (set_type C) q' {p'}\<close>
      using ZR_C_guarantees_tau_succ \<open>p \<Rightarrow>^\<tau> p'\<close> assms(1) by auto
    hence q1_ex: \<open>\<exists>q1. (\<exists>q.(q \<in> Q \<and> q  \<Rightarrow>^\<tau> q1)) \<and> ZR (set_type C) q1 {p'}\<close> using succs_def by auto
    hence strat: \<open>strategy_from_ZR_C (ZR (set_type C)) (n0#play) =
    AttackerNode (SOME q1 . (\<exists>q. (q \<in> Q \<and> q  \<Rightarrow>^\<tau> q1)) \<and> (ZR (set_type C)) q1 {p'}) {p'}\<close>
      using n0_def by auto
    then obtain q1 where
      \<open>AttackerNode (SOME q1 . (\<exists>q. (q \<in> Q \<and> q  \<Rightarrow>^\<tau> q1)) \<and> (ZR (set_type C)) q1 {p'}) {p'}
      = AttackerNode q1 {p'}\<close> by blast
    hence q1_def: \<open>q1 = (SOME q1 . (\<exists>q. (q \<in> Q \<and> q  \<Rightarrow>^\<tau> q1)) \<and> (ZR (set_type C)) q1 {p'})\<close>
      by auto
    with someI_ex[OF q1_ex] have X: \<open>\<exists>q. (q \<in> Q \<and> q  \<Rightarrow>^\<tau> q1) \<and> ZR (set_type C) q1 {p'}\<close>
      by blast
    hence \<open>q1 \<in> succs \<tau> Q \<and> {p'} = {p'}\<close>using succs_def by auto
    thus ?thesis  using n0_def strat q1_def by auto
  qed
qed

subsection \<open>Winning Strategy Implies Contrasimulation (Soundness)\<close>

lemma move_DefSim_to_AtkNode :
  assumes
    \<open>c_set_game_moves (DefenderSimNode a p Q) n0\<close>
  shows \<open>n0 = AttackerNode p (succs a Q)\<close>
proof -
  have \<open>\<exists>p1 Q1. n0 = AttackerNode p1 Q1\<close>
    by (metis assms c_set_game_defender_node.elims(2) c_set_game_defender_node.elims(3) local.c_set_game_moves_no_step(1) local.c_set_game_moves_no_step(6))
  then obtain p1 Q1 where n0_def: \<open>n0 = AttackerNode p1 Q1\<close> by auto
  hence \<open>p = p1\<close> using assms local.simulation_answer by blast
  from n0_def have \<open>Q1 = succs a Q\<close>
    using assms local.simulation_answer by blast
  thus ?thesis using \<open>p = p1\<close> n0_def by auto
qed

lemma defSimNode_with_prefix_in_play:
  assumes
    \<open>A \<noteq> []\<close>
    \<open>p \<Rightarrow>$A p1\<close>
    \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
    \<open>player0_winning_strategy f\<close>
    \<open>sound_strategy f\<close>
    \<open>play \<in> plays_for_strategy f\<close>
    \<open>hd play = AttackerNode p {q}\<close>
  shows \<open>\<exists>play. ((DefenderSimNode (last A) p1 (succs_seq_rec (rev (butlast A)) {q}))#play)
      \<in> plays_for_strategy f\<close>
proof -
  have  \<open>\<not>player1_wins play\<close> using assms(4, 6) player0_winning_strategy_def by auto
  hence \<open>(c_set_game_defender_node (hd play) \<and> (\<nexists>p'. c_set_game_moves (hd play) p')) \<Longrightarrow> False\<close>
    using player1_wins_def by auto
  hence Def_not_stuck: \<open>c_set_game_defender_node (hd play) \<Longrightarrow> (\<exists>p'. c_set_game_moves (hd play) p')\<close>
    by auto
  show ?thesis using assms(1-3)
  proof (induct arbitrary: p1 rule: rev_nonempty_induct[OF assms(1)])
    case single: (1 a)
    hence \<open>\<not>tau a\<close> using \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> by (simp add: tau_def)
    hence \<open>p \<Rightarrow>$[a] p1\<close> using single by auto
    hence p_step: \<open>p \<Rightarrow>^a p1\<close> by blast
    hence \<open>p \<Rightarrow>a p1\<close> using Cons \<open>\<not>tau a\<close> by auto
    hence \<open>\<exists>n0. n0  = DefenderSimNode a p1 {q} \<and> c_set_game_moves (AttackerNode p {q}) n0\<close>
      using assms(4) \<open>\<not> tau a\<close> by simp
    hence \<open>((DefenderSimNode a p1 {q})#play) \<in> plays_for_strategy f\<close> using assms(6,7)
      by (metis c_set_game_defender_node.simps(1) list.collapse no_empty_plays
            player1_position_def plays_for_strategy.p1move strategy_plays_subset)
    then show ?case  by auto
  next
    case snoc: (2 a as)
    hence \<open>\<not>tau a\<close> using \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> by (simp add: tau_def)
    then obtain a2 as2 where as_def: \<open>as = as2@[a2]\<close> using list_rev_split[OF snoc.hyps(1)] by auto
    have \<open>\<exists>p'. p \<Rightarrow>$ as  p' \<and> p' \<Rightarrow>$[a]  p1\<close> using rev_seq_split[OF snoc.prems(2)] by blast
    hence \<open>\<exists>p'. p \<Rightarrow>$ as  p' \<and> p' \<Rightarrow>^a  p1\<close> by blast
    hence \<open>\<exists>p'. p \<Rightarrow>$ as  p' \<and> p' \<Rightarrow>a  p1\<close> using  \<open>\<not>tau a\<close> by simp
    then obtain p' where p'_def: \<open>p \<Rightarrow>$ as  p'\<close> and p'_step: \<open>p' \<Rightarrow>a  p1\<close> by auto
    then obtain play
      where play_def: \<open>DefenderSimNode (last as) p' (succs_seq_rec (rev (butlast as)) {q}) # play
                \<in> plays_for_strategy f\<close> using snoc by auto
    hence \<open>DefenderSimNode a2 p' (succs_seq_rec (rev as2) {q}) # play
                \<in> plays_for_strategy f\<close> using as_def by auto
    then obtain n0 where n0_def: \<open>n0 = DefenderSimNode a2 p' (succs_seq_rec (rev as2) {q})\<close>
          and n0_in_play: \<open>n0#play \<in> plays_for_strategy f\<close> by auto
    hence \<open>\<exists>n1. c_set_game_moves (DefenderSimNode a2 p' (succs_seq_rec (rev as2) {q})) n1\<close>
      using Def_not_stuck by (meson assms(5) c_set_game_defender_node.simps(2) sound_strategy_def)
    then obtain n1
      where n1_def: \<open>c_set_game_moves (DefenderSimNode a2 p' (succs_seq_rec (rev as2) {q})) n1\<close>
      by auto
    hence n1_atk: \<open>n1 = AttackerNode p' (succs a2 ((succs_seq_rec (rev as2) {q})))\<close>
      using move_DefSim_to_AtkNode[OF n1_def] by auto
    have n1_in_play: \<open>n1#n0#play \<in> plays_for_strategy f\<close> using n1_def n0_in_play n0_def
      by (metis assms(5) move_DefSim_to_AtkNode c_set_game_defender_node.simps(2)
          plays_for_strategy.simps sound_strategy_def)
    then obtain n0'
      where n0'_def : \<open>n0' = DefenderSimNode a p1 (succs a2 ((succs_seq_rec (rev as2) {q})))\<close>
      and n0'_mov: \<open>c_set_game_moves n1 n0'\<close> using p'_step n1_atk by (simp add: \<open>\<not> tau a\<close>)
    hence in_play: \<open>n0'#n1#n0#play \<in> plays_for_strategy f\<close> using n1_in_play
      by (simp add: n1_atk player1_position_def plays_for_strategy.p1move)
    hence simnode: \<open>n0' = DefenderSimNode a p1 (succs a2 ((succs_seq_rec(rev as2) {q})))\<close>
      using n0'_def n0'_mov by auto
    hence \<open>n0' = DefenderSimNode a p1 (succs_seq_rec (rev (as2@[a2])) {q})\<close> using simnode by auto
    hence \<open>n0' = DefenderSimNode a p1 (succs_seq_rec (rev (as)) {q})\<close> using as_def by auto
    then show ?case using in_play by auto
  qed
qed

lemma set_contrasim_game_sound:
  assumes
    \<open>player0_winning_strategy f\<close>
    \<open>sound_strategy f\<close>
  defines
    \<open>C == \<lambda> p q . (\<exists> play \<in> plays_for_strategy f . hd play = AttackerNode p {q} \<and> (hd play = initial \<or> (\<exists>P. hd (tl play) = DefenderSwapNode q P)))\<close>
  shows
    \<open>contrasim C\<close>  unfolding contrasim_def
proof (safe)
  fix p q p1 A
  assume \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> \<open>p \<Rightarrow>$A p1\<close> and \<open>C p q\<close>
  hence \<open>p \<Rightarrow>$(taufree A) p1\<close> by (simp add: weak_step_over_tau)
  hence \<open>(\<exists> play \<in> plays_for_strategy f . hd play = AttackerNode p {q} \<and> (hd play = initial \<or> (\<exists>P. hd (tl play) = DefenderSwapNode q P)))\<close>
    using C_def \<open>p \<Rightarrow>$A p1\<close> and \<open>C p q\<close>  by auto
  from this obtain play where play_def: \<open>play \<in> plays_for_strategy f\<close>
    and play_hd: \<open>hd play = AttackerNode p {q}\<close>
    and \<open>hd play = initial \<or> (\<exists>P. hd (tl play) = DefenderSwapNode q P)\<close>
    by auto
  hence \<open>\<not>player1_wins play\<close> using assms(1) player0_winning_strategy_def by auto
  hence \<open>(c_set_game_defender_node (hd play) \<and> (\<nexists>p'. c_set_game_moves (hd play) p')) \<Longrightarrow> False\<close>
    using player1_wins_def by auto
  hence Def_not_stuck: \<open>c_set_game_defender_node (hd play) \<Longrightarrow> (\<exists>p'. c_set_game_moves (hd play) p')\<close> by auto
  from \<open>p \<Rightarrow>$A p1\<close> \<open>p \<Rightarrow>$(taufree A) p1\<close> \<open>C p q\<close> show \<open>\<exists>q'. q \<Rightarrow>$ A q' \<and> C q' p1\<close>
  proof (cases A rule: rev_cases)
    case Nil
    hence \<open>p \<Rightarrow>^\<tau> p1\<close> using \<open>p \<Rightarrow>$A p1\<close> by auto
    hence \<open>\<exists>n0. n0 = DefenderSwapNode p1 {q} \<and> c_set_game_moves (AttackerNode p {q}) n0\<close> by simp
    from this obtain n0 where n0_def: \<open>n0 = DefenderSwapNode p1 {q}\<close>
      and n0_move: \<open>c_set_game_moves (AttackerNode p {q}) n0\<close> by auto
    have \<open>play = (hd play)#(tl play)\<close>
      by (metis hd_Cons_tl no_empty_plays play_def strategy_plays_subset)
    hence \<open>n0#play \<in> plays_for_strategy f\<close> using n0_def n0_move play_def play_hd
      by (metis c_set_game_defender_node.simps(1) play_def
          player1_position_def plays_for_strategy.p1move)
    hence \<open>\<exists>n1'. c_set_game_moves n0 n1' \<and> n1'#n0#play \<in> plays_for_strategy f\<close>
      using assms(2) n0_def sound_strategy_def
      by (meson c_set_game_defender_node.simps(3) plays_for_strategy.p0move)
    then obtain n1' where n1'_mov: \<open>c_set_game_moves n0 n1'\<close>
      and in_play: \<open>n1'#n0#play \<in> plays_for_strategy f\<close> by auto
    hence \<open>\<exists>q1. n1' = AttackerNode q1 {p1} \<and> (q1 \<in> succs \<tau> {q})\<close>
      by (metis c_set_game_defender_node.elims(2, 3) c_set_game_moves_no_step(3, 4) swap_answer n0_def)
    then obtain q1 where q1_def: \<open>n1' = AttackerNode q1 {p1}\<close>
      and q_succ: \<open>q1 \<in> succs \<tau> {q}\<close> by auto
    hence q_tau: \<open>q \<Rightarrow>^\<tau> q1\<close> using succs_def by auto
    from in_play q1_def n0_def have \<open>C q1 p1\<close> unfolding C_def by force
    then show ?thesis using q_tau Nil by auto
  next
    case (snoc as a)
    hence \<open>A \<noteq> []\<close> by auto
    hence \<open>\<not>tau a\<close> using \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> snoc  by (simp add: tau_def)
    have gotoA: \<open>\<exists>play. ((DefenderSimNode (last A) p1 (succs_seq_rec (rev (butlast A)) {q}))#play)
      \<in> plays_for_strategy f\<close>
      using defSimNode_with_prefix_in_play \<open>p \<Rightarrow>$A p1\<close>
        \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> \<open>A \<noteq> []\<close> assms(1,2) play_def play_hd by auto
    then obtain Q where Q_def: \<open>Q = succs_seq_rec (rev (butlast A)) {q}\<close> by auto
    hence Q_all: \<open>\<forall>q' \<in> Q.  q \<Rightarrow>$(butlast A) q'\<close> using in_s_implies_word_reachable by auto
    then obtain n0 where n0_def: \<open>n0 = DefenderSimNode a p1 (succs_seq_rec (rev as) {q})\<close> by auto
    then obtain A_play
      where A_play_def: \<open>n0#A_play \<in> plays_for_strategy f\<close>
      using gotoA snoc by auto
    then obtain n1 where n1_move: \<open>c_set_game_moves n0 n1\<close>
      using n0_def by (meson assms(2) c_set_game_defender_node.simps(2) sound_strategy_def)
    hence \<open>n1 = AttackerNode p1 (succs a (succs_seq_rec (rev as) {q}))\<close>
      using move_DefSim_to_AtkNode n0_def by blast
    hence \<open>n1 = AttackerNode p1 (succs_seq_rec (a#(rev as)) {q})\<close>
      using succs_seq_rec.simps(2) by auto
    hence \<open>n1 = AttackerNode p1 (succs_seq_rec (rev (as@[a])) {q})\<close> by auto
    hence n1_def: \<open>n1 = AttackerNode p1 (succs_seq_rec (rev A) {q})\<close> using snoc by auto
    hence n1_in_play: \<open>n1#n0#A_play \<in> plays_for_strategy f\<close>
      using n0_def A_play_def n1_move assms(2) move_DefSim_to_AtkNode
        plays_for_strategy.p0move sound_strategy_def
      by fastforce
    from n1_def obtain n0' where n0'_move: \<open>c_set_game_moves n1 n0'\<close>
      and n0'_def: \<open>n0' = DefenderSwapNode p1 (succs_seq_rec (rev A) {q})\<close>
      using steps.refl local.swap_challenge tau_tau by blast
    hence n0'_in_play: \<open>n0'#n1#n0#A_play \<in> plays_for_strategy f\<close>
      using n1_in_play by (simp add: n1_def player1_position_def plays_for_strategy.p1move)
    then obtain n1' where n1'_move: \<open>c_set_game_moves n0' n1'\<close>
      and in_strat: \<open>n1' = f(n0'#n1#n0#A_play)\<close>
      using Def_not_stuck n0'_def  assms(2) sound_strategy_def by auto
    then obtain q1 where q1_def: \<open>q1 \<in> succs \<tau> (succs_seq_rec (rev A) {q})\<close>
      and n1'_def: \<open>n1'  = AttackerNode q1 {p1}\<close> using n0'_def
      by (metis c_set_game_defender_node.cases c_set_game_moves_no_step(3, 7) swap_answer)
    hence \<open>q1 \<in> {q1. \<exists>q0 \<in> (succs_seq_rec (rev A) {q}). q0 \<Rightarrow>^\<tau> q1}\<close> using succs_def by auto
    also have \<open>... = {q1. \<exists>q0 \<in> (succs_seq_rec (rev A) {q}). q \<Rightarrow>$A q0 \<and> q0 \<Rightarrow>^\<tau> q1}\<close>
      using in_s_implies_word_reachable by auto
    also have \<open>... \<subseteq> {q1. \<exists>q0 \<in> (succs_seq_rec (rev A) {q}). q \<Rightarrow>$A q1}\<close>
      using word_tau_concat by auto
    also have \<open>... \<subseteq> {q1. q \<Rightarrow>$A q1}\<close> by auto
    finally have \<open>q1 \<in> {q1. q \<Rightarrow>$A q1}\<close> .
    hence q_goal: \<open>q \<Rightarrow>$A q1\<close> by auto
    from n1'_move in_strat have move_f: \<open>c_set_game_moves n0' (f(n0'#n1#n0#A_play))\<close> by auto
    hence  \<open>n1'#n0'#n1#n0#A_play \<in> plays_for_strategy f\<close>
      using in_strat plays_for_strategy.p0move[OF n0'_in_play _ move_f] n0'_def by auto
    hence \<open>C q1 p1\<close> unfolding C_def using n1'_def n0'_def by force
    thus ?thesis using q_goal by auto
  qed
qed

theorem winning_strategy_in_set_game_iff_contrasim:
  assumes
    \<open>initial = AttackerNode p {q}\<close>
  shows
    \<open>(\<exists> f . player0_winning_strategy f \<and> sound_strategy f) = (\<exists> C. contrasim C \<and> C p q)\<close>
proof
  assume
    \<open>(\<exists>f. player0_winning_strategy f \<and> sound_strategy f)\<close>
  then obtain f where
    \<open>contrasim
      (\<lambda>p q. \<exists>play\<in>plays_for_strategy f.
                 hd play = AttackerNode p {q} \<and>
                 (hd play = initial \<or> (\<exists>P. hd (tl play) = DefenderSwapNode q P)))\<close>
    using set_contrasim_game_sound by blast
  moreover have \<open>(\<lambda>p q. \<exists>play\<in>plays_for_strategy f.
                 hd play = AttackerNode p {q} \<and>
                 (hd play = initial \<or> (\<exists>P. hd (tl play) = DefenderSwapNode q P))) p q\<close>
     using assms plays_for_strategy.init[of f] by (meson list.sel(1))
  ultimately show \<open>\<exists> C. contrasim C \<and> C p q\<close> by blast
next
  assume
    \<open>\<exists> C. contrasim C \<and> C p q\<close>
  thus \<open>(\<exists>f. player0_winning_strategy f \<and> sound_strategy f)\<close>
    using set_contrasim_game_complete[OF _ _ assms]
         strategy_from_set_contrasim_sound[OF _ _ assms] by blast
qed

end
end


theory Bipartite_Matching_LP
  imports
    More_Graph
    Jordan_Normal_Form.Matrix
begin

definition one_vec :: "nat \<Rightarrow> 'a :: one vec" ("1\<^sub>v") where
  "1\<^sub>v n \<equiv> vec n (\<lambda>i. 1)"

lemma one_carrier_vec[simp]: "1\<^sub>v n \<in> carrier_vec n"
  unfolding one_vec_def carrier_vec_def by simp

lemma index_one_vec[simp]: "i < n \<Longrightarrow> 1\<^sub>v n $ i = 1" "dim_vec (1\<^sub>v n) = n"
  unfolding one_vec_def by simp_all

lemma to_nat_on_from_nat_into_less:
  assumes "finite A"
  assumes "i < card A"
  shows "to_nat_on A (from_nat_into A i) = i"
  using assms
  by (auto intro!: to_nat_on_from_nat_into dest!: to_nat_on_finite simp: bij_betw_def)

lemma to_nat_on_less_card:
  assumes "finite A"
  assumes "a \<in> A"
  shows "to_nat_on A a < card A"
  using assms
  by (auto dest: to_nat_on_finite bij_betwE)

text \<open>A version of the weak duality theorem which does not require equality
in the dual constraints, but non-negativity of the primal variables.\<close>
lemma weak_duality_theorem_nonneg_primal:
  fixes A :: "'a :: linordered_comm_semiring_strict mat"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and x: "x \<in> carrier_vec nc"
    and Axb: "A *\<^sub>v x \<le> b"
    and x0: "x \<ge> 0\<^sub>v nc"
    and y0: "y \<ge> 0\<^sub>v nr"
    and yA: "A\<^sup>T *\<^sub>v y \<ge> c"
  shows "c \<bullet> x \<le> b \<bullet> y"
proof -
  from y0 have y: "y \<in> carrier_vec nr" unfolding less_eq_vec_def by auto
  have "c \<bullet> x \<le> (A\<^sup>T *\<^sub>v y) \<bullet> x"
    unfolding scalar_prod_def
    using A c x yA x0
    by (auto intro!: sum_mono mult_right_mono simp: less_eq_vec_def)
  also have "\<dots> = y \<bullet> (A *\<^sub>v x)" using x y A by (metis transpose_vec_mult_scalar)
  also have "\<dots> \<le> y \<bullet> b"
    unfolding scalar_prod_def using A b Axb y0
    by (auto intro!: sum_mono mult_left_mono simp: less_eq_vec_def)
  also have "\<dots> = b \<bullet> y" using y b by (metis comm_scalar_prod)
  finally show ?thesis .
qed

locale bipartite_matching_lp =
  fixes L :: "'a set" and R :: "'a set"
  fixes G :: "'a graph"

  assumes finite_L[intro,simp]: "finite L" and finite_R[intro,simp]: "finite R"
  assumes bipartite_graph: "bipartite G L R"
  assumes parts_minimal: "Vs G = L \<union> R"
begin

sublocale graph_abs G
  using bipartite_graph finite_L finite_R
  by (intro finite_parts_bipartite_graph_abs)

lemmas finite_graph[intro,simp] = finite_E
lemmas finite_vs[intro] = graph[THEN conjunct2]

lemma parts_disjoint[intro,simp]: "L \<inter> R = {}"
  using bipartite_graph
  by (auto dest: bipartite_disjointD)

lemma bipartite_FalseD[dest]:  "x \<in> L \<Longrightarrow> x \<in> R \<Longrightarrow> False"
  using bipartite_graph
  by (auto dest: bipartite_disjointD)

lemma left_neighborE:
  assumes "i \<in> L"
  obtains j where "j \<in> R" "{i,j} \<in> G"
proof -
  assume *: "(\<And>j. j \<in> R \<Longrightarrow> {i, j} \<in> G \<Longrightarrow> thesis)"
  from \<open>i \<in> L\<close> parts_minimal have "i \<in> Vs G" by blast

  then obtain e where "e \<in> G" "i \<in> e"
    by (auto elim: vs_member_elim)

  with \<open>i \<in> L\<close> bipartite_graph obtain j where "e = {i,j}" "j \<in> R"
    by (auto elim: bipartite_edgeE)

  with \<open>e \<in> G\<close> show "thesis"
    by (auto intro!: *)
qed

definition "n \<equiv> card (Vs G)"
abbreviation "m \<equiv> card G"

definition Vs_enum :: "'a \<Rightarrow> nat" where
  "Vs_enum x \<equiv> if x \<in> L then to_nat_on L x else to_nat_on R x + card L"

definition Vs_enum_inv :: "nat \<Rightarrow> 'a" where
  "Vs_enum_inv i \<equiv> if i < card L then from_nat_into L i else from_nat_into R (i - card L)"

abbreviation G_enum :: "'a set \<Rightarrow> nat" where
  "G_enum \<equiv> to_nat_on G"

definition incidence_matrix :: "real mat" where
  "incidence_matrix \<equiv> mat n m (\<lambda>(i,j). of_bool (Vs_enum_inv i \<in> from_nat_into G j))"

definition primal_sol :: "'a graph \<Rightarrow> real vec" where
  "primal_sol M \<equiv> vec m (\<lambda>i. of_bool (from_nat_into G i \<in> M))"

lemma incidence_matrix_carrier_mat[intro]: "incidence_matrix \<in> carrier_mat n m"
  unfolding incidence_matrix_def by simp

lemma dim_primal_sol[simp]: "dim_vec (primal_sol M) = m"
  by (simp add: primal_sol_def)

lemma primal_sol_carrier_vec[intro]: "primal_sol M \<in> carrier_vec m"
  unfolding carrier_vec_def by simp

lemma primal_sol_nonneg[intro]: "primal_sol M \<ge> 0\<^sub>v m"
  unfolding primal_sol_def less_eq_vec_def
  by simp

lemma primal_sol_empty[simp]: "primal_sol {} = 0\<^sub>v m"
  unfolding primal_sol_def by auto

lemma n_sum: "n = card L + card R"
  using parts_minimal
  by (auto simp: card_Un_disjoint n_def)

lemma geq_L_less_n_less_R: "card L \<le> i \<Longrightarrow> i < n \<Longrightarrow> i - card L < card R"
  by (auto simp: n_sum)

lemma geq_L_less_n_less_R': "\<not> i < card L \<Longrightarrow> i < n \<Longrightarrow> i - card L < card R"
  by (auto intro: geq_L_less_n_less_R)

lemma Vs_cases:
  assumes "x \<in> Vs G"
  obtains "x \<in> L \<and> x \<notin> R" | "x \<in> R \<and> x \<notin> L"
  using assms parts_minimal
  by auto

lemma i_cases:
  assumes "i < n"
  obtains "i < card L" | "card L \<le> i" "i < card L + card R"
  using assms
  by (auto simp: n_sum) linarith

lemma
  shows L_inv_enum[simp]: "l \<in> L \<Longrightarrow> from_nat_into L (to_nat_on L l) = l"
    and L_enum_inv[simp]: "i < card L \<Longrightarrow> to_nat_on L (from_nat_into L i) = i"
    and R_inv_enum[simp]: "r \<in> R \<Longrightarrow> from_nat_into R (to_nat_on R r) = r"
    and R_enum_inv[simp]: "j < card R \<Longrightarrow> to_nat_on R (from_nat_into R j) = j"
  by (auto simp: countable_finite intro: to_nat_on_from_nat_into_less)

lemma
  shows L_enum_less_card: "l \<in> L \<Longrightarrow> to_nat_on L l < card L"
    and R_enum_less_card: "r \<in> R \<Longrightarrow> to_nat_on R r < card R"
  by (auto intro: to_nat_on_less_card)

lemma
  shows L_enum_less_n: "l \<in> L \<Longrightarrow> to_nat_on L l < n"
    and R_enum_less_n: "r \<in> R \<Longrightarrow> to_nat_on R r + card L < n"
  by (auto simp: n_sum dest: L_enum_less_card R_enum_less_card)

lemma
  shows Vs_enum_L: "l \<in> L \<Longrightarrow> Vs_enum l = to_nat_on L l"
    and Vs_enum_inv_from_nat_into_L: "i < card L \<Longrightarrow> Vs_enum_inv i = from_nat_into L i"
  unfolding Vs_enum_def Vs_enum_inv_def
  by auto

lemma
  shows Vs_enum_R: "r \<in> R \<Longrightarrow> Vs_enum r = to_nat_on R r + card L"
    and "card L \<le> i \<Longrightarrow> Vs_enum_inv i = from_nat_into R (i - card L)"
  unfolding Vs_enum_def Vs_enum_inv_def
  by auto

lemma Vs_enum_less_n: "x \<in> Vs G \<Longrightarrow> Vs_enum x < n"
  by (auto elim!: Vs_cases simp: Vs_enum_L Vs_enum_R intro: L_enum_less_n R_enum_less_n)

lemma
  shows Vs_enum_less_n_L: "i \<in> L \<Longrightarrow> Vs_enum i < n"
    and Vs_enum_less_n_R: "j \<in> R \<Longrightarrow> Vs_enum j < n"
  by (auto simp: parts_minimal intro: Vs_enum_less_n)

lemma Vs_enum_less_card_L: "l \<in> L \<Longrightarrow> Vs_enum l < card L"
  by (auto simp: Vs_enum_L intro: L_enum_less_card)

lemma Vs_enum_geq_card_L: "r \<in> R \<Longrightarrow> card L \<le> Vs_enum r"
  by (auto simp: Vs_enum_R)

lemma
  shows Vs_inv_enum[simp]: "x \<in> Vs G \<Longrightarrow> Vs_enum_inv (Vs_enum x) = x"
    and Vs_enum_inv[simp]: "i < n \<Longrightarrow> Vs_enum (Vs_enum_inv i) = i"
  by (auto elim!: Vs_cases simp: Vs_enum_inv_def Vs_enum_def n_sum dest: L_enum_less_card intro!: from_nat_into)

lemma
  shows Vs_inv_enum_L[simp]: "i \<in> L \<Longrightarrow> Vs_enum_inv (Vs_enum i) = i"
    and Vs_inv_enum_R[simp]: "j \<in> R \<Longrightarrow> Vs_enum_inv (Vs_enum j) = j"
  by (simp_all add: parts_minimal)

lemma Vs_enum_inv_leftE:
  assumes "i < card L"
  obtains j where "j \<in> L" "Vs_enum_inv i = j"
  using assms
  by (metis Vs_enum_inv_def card.empty from_nat_into not_less_zero)

lemma Vs_enum_inv_rightE:
  assumes "i < n"
  assumes "\<not> i < card L"
  obtains j where "j \<in> R" "Vs_enum_inv i = j"
  using assms
  by (metis Vs_enum_inv_def add.right_neutral card.empty from_nat_into n_sum)

lemma G_enum_less_m: "e \<in> G \<Longrightarrow> G_enum e < m"
  using finite_E
  by (auto intro: to_nat_on_less_card)

lemma G_not_empty_if:
  assumes "i < m"
  shows "G \<noteq> {}"
  using assms
  by fastforce

lemma from_nat_into_G_E_aux:
  assumes "i < m"
  obtains e where "e \<in> G" "from_nat_into G i = e"
  using assms
  by (metis G_not_empty_if from_nat_into)

lemma from_nat_into_G_E:
  assumes "i < m"
  obtains l r where "{l,r} \<in> G" "from_nat_into G i = {l,r}" "l \<in> L" "r \<in> R"
  using assms bipartite_graph
  by (metis bipartite_edgeE from_nat_into_G_E_aux)

lemma Vs_enum_neqI: "v \<in> Vs G \<Longrightarrow> v' \<in> Vs G \<Longrightarrow> v \<noteq> v' \<Longrightarrow> Vs_enum v \<noteq> Vs_enum v'"
  by (metis Vs_inv_enum)

lemma G_enum_neqI: "e \<in> G \<Longrightarrow> e' \<in> G \<Longrightarrow> e \<noteq> e' \<Longrightarrow> G_enum e \<noteq> G_enum e'"
  by (simp add: countable_finite)

lemma the_lE:
  assumes "e \<in> G"
  obtains "(THE l. l \<in> L \<and> l \<in> e) \<in> L" "(THE l. l \<in> L \<and> l \<in> e) \<in> e"
proof
  from assms bipartite_graph obtain l r where "e = {l,r}" "l \<in> L" "r \<in> R"
    by (auto elim: bipartite_edgeE)

  then have "(THE l. l \<in> L \<and> l \<in> e) = l"
    by auto

  with \<open>e = {l,r}\<close> \<open>l \<in> L\<close> show "(THE l. l \<in> L \<and> l \<in> e) \<in> L" "(THE l. l \<in> L \<and> l \<in> e) \<in> e"
    by auto
qed

lemma the_l_subsetE:
  assumes "M \<subseteq> G"
  assumes "e \<in> M"
  obtains "(THE l. l \<in> L \<and> l \<in> e) \<in> L" "(THE l. l \<in> L \<and> l \<in> e) \<in> e"
  using assms
  by (auto elim: the_lE)

lemma the_l_subset_in_LI:
  assumes "M \<subseteq> G"
  assumes "e \<in> M"
  shows "(THE l. l \<in> L \<and> l \<in> e) \<in> L"
  using assms
  by (auto elim: the_l_subsetE)

lemma index_set_Int_is_doubleton:
  assumes "i \<in> L" "j \<in> R"
  shows "{0..<n} \<inter> {k. Vs_enum_inv k = i \<or> Vs_enum_inv k = j} = {Vs_enum i, Vs_enum j}"
  using assms
  by (auto intro: Vs_enum_less_n_L Vs_enum_less_n_R)

lemma primal_dot_One_card: "M \<subseteq> G \<Longrightarrow> 1\<^sub>v m \<bullet> primal_sol M = card M"
  by (auto simp: scalar_prod_def primal_sol_def countable_finite in_mono
           intro!: bij_betw_same_card[where f = "from_nat_into G"] bij_betwI[where g = G_enum]
                   to_nat_on_less_card to_nat_on_from_nat_into_less)

lemma matching_feasible:
  assumes "matching M"
  shows "incidence_matrix *\<^sub>v primal_sol M \<le> 1\<^sub>v n"
  unfolding incidence_matrix_def primal_sol_def less_eq_vec_def mult_mat_vec_def scalar_prod_def
proof (intro conjI allI impI, simp_all, rule ccontr, simp add: not_le)
  fix i
  assume "i < n"
  let ?indices = "{0..<m} \<inter> {e. from_nat_into G e \<in> M} \<inter> {e. local.Vs_enum_inv i \<in> from_nat_into G e}"
  assume "1 < real (card ?indices)"

  then have gt_1: "1 < card ?indices"
    by simp

  then obtain ei1 where ei1: "ei1 \<in> ?indices"
    by (metis card_eq_0_iff ex_in_conv not_less0)

  with gt_1 have "0 < card (?indices - {ei1})"
    by auto

  then obtain ei2 where ei2: "ei2 \<in> ?indices" "ei1 \<noteq> ei2"
    by (metis Diff_eq_empty_iff card_0_eq card_ge_0_finite insertCI not_gr_zero subsetI)

  with ei1 have "from_nat_into G ei1 \<in> M" "from_nat_into G ei2 \<in> M"
    "Vs_enum_inv i \<in> from_nat_into G ei1" "Vs_enum_inv i \<in> from_nat_into G ei2"
    by auto

  with \<open>matching M\<close> have "from_nat_into G ei1 = from_nat_into G ei2"
    by (auto dest: matching_unique_match)

  with ei1 ei2 \<open>ei1 \<noteq> ei2\<close> show False
    by (auto dest!: to_nat_on_from_nat_into_less[OF finite_E])
qed

lemma feasible_matching:
  assumes "M \<subseteq> G"
  assumes "incidence_matrix *\<^sub>v primal_sol M \<le> 1\<^sub>v n"
  shows "matching M"
proof (use assms in \<open>simp add: incidence_matrix_def primal_sol_def mult_mat_vec_def scalar_prod_def less_eq_vec_def\<close>, intro ccontr[where P = "matching M"])
  assume "M \<subseteq> G"
  let ?indices = "\<lambda>i. {0..<m} \<inter> {i. from_nat_into G i \<in> M} \<inter> {x. Vs_enum_inv i \<in> from_nat_into G x}"
  assume at_most_One: "\<forall>i<n. real (card (?indices i)) \<le> 1"
  assume "\<not>matching M"

  then obtain e1 e2 where "e1 \<in> M" "e2 \<in> M" "e1 \<noteq> e2" "e1 \<inter> e2 \<noteq> {}"
    unfolding matching_def
    by blast

  then obtain v where "v \<in> e1" "v \<in> e2"
    by blast

  with \<open>M \<subseteq> G\<close> \<open>e1 \<in> M\<close> have "v \<in> Vs G"
    by (auto intro: vs_member_intro)

  then have v_le_n: "Vs_enum v < n"
    by (auto intro: Vs_enum_less_n)

  from \<open>e1 \<in> M\<close> \<open>M \<subseteq> G\<close> \<open>v \<in> Vs G\<close> \<open>v \<in> e1\<close> have e1_in_indices: "G_enum e1 \<in> ?indices (Vs_enum v)"
    by (auto intro: G_enum_less_m simp: countable_finite[OF finite_E])

  from \<open>e2 \<in> M\<close> \<open>M \<subseteq> G\<close> \<open>v \<in> Vs G\<close> \<open>v \<in> e2\<close> have e2_in_indices: "G_enum e2 \<in> ?indices (Vs_enum v)"
    by (auto intro: G_enum_less_m simp: countable_finite[OF finite_E])

  from \<open>e1 \<in> M\<close> \<open>e2 \<in> M\<close> \<open>M \<subseteq> G\<close> \<open>e1 \<noteq> e2\<close> have "G_enum e1 \<noteq> G_enum e2"
    by (intro G_enum_neqI) auto

  with e1_in_indices have "0 < card (?indices (Vs_enum v) - {G_enum e2})"
    by (auto simp: card_gt_0_iff)

  with e2_in_indices have "1 < card (?indices (Vs_enum v))"
    by simp

  also from at_most_One v_le_n have "\<dots> \<le> 1"
    by auto

  finally have "1 < 1" ..

  then show False
    by fast
qed

lemma matching_iff_feasible:
  assumes "M \<subseteq> G"
  shows "matching M \<longleftrightarrow> incidence_matrix *\<^sub>v primal_sol M \<le> 1\<^sub>v n"
  using assms
  by (auto intro: feasible_matching matching_feasible)

lemma card_matching_bound_by_feasible_dual:
  fixes y :: "real vec"
  assumes "M \<subseteq> G"
  assumes "matching M"

  assumes "incidence_matrix\<^sup>T *\<^sub>v y \<ge> 1\<^sub>v m"
  assumes "y \<ge> 0\<^sub>v n"

  shows "card M \<le> 1\<^sub>v n \<bullet> y"
proof -
  from \<open>M \<subseteq> G\<close> have "card M = 1\<^sub>v m \<bullet> primal_sol M"
    by (auto simp: primal_dot_One_card)

  also from assms have "\<dots> \<le> 1\<^sub>v n \<bullet> y"
    by (auto intro: weak_duality_theorem_nonneg_primal[where A = incidence_matrix] matching_feasible)

  finally show ?thesis .
qed

lemma max_card_matching_bound_by_feasible_dual:
  fixes y :: "real vec"
  assumes "max_card_matching G M"

  assumes "incidence_matrix\<^sup>T *\<^sub>v y \<ge> 1\<^sub>v m"
  assumes "y \<ge> 0\<^sub>v n"

  shows "card M \<le> 1\<^sub>v n \<bullet> y"
  using assms
  by (auto intro: card_matching_bound_by_feasible_dual dest: max_card_matchingD)

end

end


theory list_weird_concat_fmap_bind
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

function weirdconcat :: "('a list) list => 'a list" where
"weirdconcat (Nil2) = Nil2"
| "weirdconcat (Cons2 (Nil2) xss) = weirdconcat xss"
| "weirdconcat (Cons2 (Cons2 z xs) xss) =
     Cons2 z (weirdconcat (Cons2 xs xss))"
by pat_completeness auto

fun fmap :: "('a => 'b) => 'a list => 'b list" where
"fmap x (Nil2) = Nil2"
| "fmap x (Cons2 z xs) = Cons2 (x z) (fmap x xs)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun bind :: "'a list => ('a => 'b list) => 'b list" where
"bind (Nil2) y = Nil2"
| "bind (Cons2 z xs) y = append (y z) (bind xs y)"

(*hipster weirdconcat fmap append bind *)

(*hipster append bind *)

(*hipster append bind fmap*)

lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes fmap.simps append.simps bind.simps)

lemma lemma_aa [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes fmap.simps append.simps bind.simps)

lemma lemma_ab [thy_expl]: "append (fmap x2 y2) (fmap x2 z2) = fmap x2 (append y2 z2)"
by (hipster_induct_schemes fmap.simps append.simps bind.simps)

lemma lemma_ac [thy_expl]: "append (bind x1 y1) (bind z1 y1) = bind (append x1 z1) y1"
by (hipster_induct_schemes fmap.simps append.simps bind.simps)

(*hipster weirdconcat append bind fmap \<Longrightarrow> No code equations for weirdconcat *)
thm weirdconcat.psimps

theorem x0 :
  "!! (f :: ('a => 'b list)) (xs :: 'a list) .
     (weirdconcat (fmap f xs)) = (bind xs f)"
(*proof -
fix f xs
show "(weirdconcat (fmap f xs)) = (bind xs f)"
     apply(induction xs f rule: bind.induct)
     apply(simp_all add: weirdconcat.psimps)
     sledgehammer*)
     (*apply(metis (full_types) thy_expl weirdconcat.psimps fmap.simps bind.simps)*)
(*by (hipster_induct_schemes fmap.simps append.simps bind.simps list.exhaust weirdconcat.psimps)   Unification loop! *)

  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
    Authors:    Jose Divasón
                Sebastiaan Joosten
                René Thiemann
                Akihisa Yamada
    License:    BSD
*)

section \<open>Missing lemmas\<close>

text \<open>This theory contains many results that are important but not specific for our development.
      They could be moved to the stardard library and some other AFP entries.\<close>

theory Missing_Lemmas
  imports
    Berlekamp_Zassenhaus.Sublist_Iteration (* for thm upt_append *)
    Berlekamp_Zassenhaus.Square_Free_Int_To_Square_Free_GFp (* for thm large_mod_0 *)
    Algebraic_Numbers.Resultant
    Jordan_Normal_Form.Conjugate
    Jordan_Normal_Form.Missing_VectorSpace
    Jordan_Normal_Form.VS_Connect
    Berlekamp_Zassenhaus.Finite_Field_Factorization_Record_Based (* for transfer rules for thm vec_of_list_Nil *)
    Berlekamp_Zassenhaus.Berlekamp_Hensel (* for unique_factorization_m_factor *)
begin

no_notation test_bit (infixl "!!" 100)

hide_const(open) module.smult up_ring.monom up_ring.coeff

(**** Could be merged to HOL/Rings.thy ****)

lemma (in zero_less_one) zero_le_one [simp]: "0 \<le> 1" by (rule less_imp_le, simp)
subclass (in zero_less_one) zero_neq_one by (unfold_locales, simp add: less_imp_neq)

class ordered_semiring_1 = Rings.ordered_semiring_0 + monoid_mult + zero_less_one
begin

subclass semiring_1..

lemma of_nat_ge_zero[intro!]: "of_nat n \<ge> 0"
  using add_right_mono[of _ _ 1] by (induct n, auto)

(* Following lemmas are moved from @{class ordered_idom}. *)
lemma zero_le_power [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
  by (induct n) simp_all

lemma power_mono: "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
  by (induct n) (auto intro: mult_mono order_trans [of 0 a b])

lemma one_le_power [simp]: "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
  using power_mono [of 1 a n] by simp

lemma power_le_one: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ n \<le> 1"
  using power_mono [of a 1 n] by simp

lemma power_gt1_lemma:
  assumes gt1: "1 < a"
  shows "1 < a * a ^ n"
proof -
  from gt1 have "0 \<le> a"
    by (fact order_trans [OF zero_le_one less_imp_le])
  from gt1 have "1 * 1 < a * 1" by simp
  also from gt1 have "\<dots> \<le> a * a ^ n"
    by (simp only: mult_mono \<open>0 \<le> a\<close> one_le_power order_less_imp_le zero_le_one order_refl)
  finally show ?thesis by simp
qed

lemma power_gt1: "1 < a \<Longrightarrow> 1 < a ^ Suc n"
  by (simp add: power_gt1_lemma)

lemma one_less_power [simp]: "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
  by (cases n) (simp_all add: power_gt1_lemma)

lemma power_decreasing: "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ N \<le> a ^ n"
proof (induction N)
  case (Suc N)
  then have "a * a^N \<le> 1 * a^n" if "n \<le> N"
    using that by (intro mult_mono) auto
  then show ?case
    using Suc by (auto simp add: le_Suc_eq)
qed (auto)

lemma power_increasing: "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
proof (induction N)
  case (Suc N)
  then have "1 * a^n \<le> a * a^N" if "n \<le> N"
    using that by (intro mult_mono) (auto simp add: order_trans[OF zero_le_one])
  then show ?case
    using Suc by (auto simp add: le_Suc_eq)
qed (auto)

lemma power_Suc_le_self: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ Suc n \<le> a"
  using power_decreasing [of 1 "Suc n" a] by simp

end

subclass (in ordered_idom) ordered_semiring_1 by unfold_locales auto

(**** End of lemmas that could be moved to HOL/Rings.thy ****)

(* missing lemma on logarithms *)
lemma log_prod: assumes "0 < a" "a \<noteq> 1" "\<And> x. x \<in> X \<Longrightarrow> 0 < f x"
  shows "log a (prod f X) = sum (log a o f) X"
  using assms(3)
proof (induct X rule: infinite_finite_induct)
  case (insert x F)
  have "log a (prod f (insert x F)) = log a (f x * prod f F)" using insert by simp
  also have "\<dots> = log a (f x) + log a (prod f F)"
    by (rule log_mult[OF assms(1-2) insert(4) prod_pos], insert insert, auto)
  finally show ?case using insert by auto
qed auto

(* TODO: Jordan_Normal_Form/Missing_Ring.ordered_idom should be redefined *)
subclass (in ordered_idom) zero_less_one by (unfold_locales, auto)
hide_fact Missing_Ring.zero_less_one

(**** The following lemmas could be part of the standard library ****)

instance real :: ordered_semiring_strict by (intro_classes, auto)
instance real :: linordered_idom..

(*This is a generalisation of thm less_1_mult*)
lemma less_1_mult':
  fixes a::"'a::linordered_semidom"
  shows "1 < a \<Longrightarrow> 1 \<le> b \<Longrightarrow> 1 < a * b"
  by (metis le_less less_1_mult mult.right_neutral)

lemma upt_minus_eq_append: "i\<le>j \<Longrightarrow> i\<le>j-k \<Longrightarrow> [i..<j] = [i..<j-k] @ [j-k..<j]"
proof (induct k)
  case (Suc k)
  have hyp: "[i..<j] = [i..<j - k] @ [j - k..<j]" using Suc.hyps Suc.prems by auto
  then show ?case
    by (metis Suc.prems(2) append.simps(1) diff_Suc_less nat_less_le neq0_conv upt_append upt_rec zero_diff)
qed auto

lemma list_trisect: "x < length lst \<Longrightarrow> [0..<length lst] = [0..<x]@x#[Suc x..<length lst]"
  by (induct lst, force, rename_tac a lst, case_tac "x = length lst", auto)

lemma id_imp_bij_betw:
  assumes f: "f : A \<rightarrow> A"
      and ff: "\<And>a. a \<in> A \<Longrightarrow> f (f a) = a"
  shows "bij_betw f A A"
  by (intro bij_betwI[OF f f], simp_all add: ff)

lemma range_subsetI:
  assumes "\<And>x. f x = g (h x)" shows "range f \<subseteq> range g"
  using assms by auto

lemma Gcd_uminus:
  fixes A::"int set"
  assumes "finite A"
  shows "Gcd A = Gcd (uminus ` A)"
  using assms
  by (induct A, auto)

lemma aux_abs_int: fixes c :: int
  assumes "c \<noteq> 0"
  shows "\<bar>x\<bar> \<le> \<bar>x * c\<bar>"
proof -
  have "abs x = abs x * 1" by simp
  also have "\<dots> \<le> abs x * abs c"
    by (rule mult_left_mono, insert assms, auto)
  finally show ?thesis unfolding abs_mult by auto
qed

lemma mod_0_abs_less_imp_0:
  fixes a::int
  assumes a1: "[a = 0] (mod m)"
  and a2: "abs(a)<m"
  shows "a = 0"
proof -
  have "m\<ge>0" using assms by auto
  thus ?thesis
    using assms unfolding cong_def
    using int_mod_pos_eq large_mod_0 zless_imp_add1_zle
      by (metis abs_of_nonneg le_less not_less zabs_less_one_iff zmod_trival_iff)
qed

(* an intro version of sum_list_0 *)
lemma sum_list_zero:
  assumes "set xs \<subseteq> {0}" shows "sum_list xs = 0"
  using assms by (induct xs, auto)

(* About @{const max} *)
lemma max_idem [simp]: shows "max a a = a" by (simp add: max_def)

lemma hom_max:
  assumes "a \<le> b \<longleftrightarrow> f a \<le> f b"
  shows "f (max a b) = max (f a) (f b)" using assms by (auto simp: max_def)

lemma le_max_self:
  fixes a b :: "'a :: preorder"
  assumes "a \<le> b \<or> b \<le> a" shows "a \<le> max a b" and "b \<le> max a b"
  using assms by (auto simp: max_def)

lemma le_max:
  fixes a b :: "'a :: preorder"
  assumes "c \<le> a \<or> c \<le> b" and "a \<le> b \<or> b \<le> a" shows "c \<le> max a b"
  using assms(1) le_max_self[OF assms(2)] by (auto dest: order_trans)

fun max_list where
  "max_list [] = (THE x. False)" (* more convenient than "undefined" *)
| "max_list [x] = x"
| "max_list (x # y # xs) = max x (max_list (y # xs))"

declare max_list.simps(1) [simp del]
declare max_list.simps(2-3)[code]

lemma max_list_Cons: "max_list (x#xs) = (if xs = [] then x else max x (max_list xs))"
  by (cases xs, auto)

lemma max_list_mem: "xs \<noteq> [] \<Longrightarrow> max_list xs \<in> set xs"
  by (induct xs, auto simp: max_list_Cons max_def)

lemma mem_set_imp_le_max_list:
  fixes xs :: "'a :: preorder list"
  assumes "\<And>a b. a \<in> set xs \<Longrightarrow> b \<in> set xs \<Longrightarrow> a \<le> b \<or> b \<le> a"
      and "a \<in> set xs"
  shows "a \<le> max_list xs"
proof (insert assms, induct xs arbitrary:a)
  case Nil
  with assms show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "xs = []")
    case False
    have "x \<le> max_list xs \<or> max_list xs \<le> x"
      apply (rule Cons(2)) using max_list_mem[of xs] False by auto
    note 1 = le_max_self[OF this]
    from Cons have "a = x \<or> a \<in> set xs" by auto
    then show ?thesis
    proof (elim disjE)
      assume a: "a = x"
      show ?thesis by (unfold a max_list_Cons, auto simp: False intro!: 1)
    next
      assume "a \<in> set xs"
      then have "a \<le> max_list xs" by (intro Cons, auto)
      with 1 have "a \<le> max x (max_list xs)" by (auto dest: order_trans)
      then show ?thesis by (unfold max_list_Cons, auto simp: False)
    qed
  qed (insert Cons, auto)
qed

lemma le_max_list:
  fixes xs :: "'a :: preorder list"
  assumes ord: "\<And>a b. a \<in> set xs \<Longrightarrow> b \<in> set xs \<Longrightarrow> a \<le> b \<or> b \<le> a"
      and ab: "a \<le> b"
      and b: "b \<in> set xs"
  shows "a \<le> max_list xs"
proof-
  note ab
  also have "b \<le> max_list xs"
    by (rule mem_set_imp_le_max_list, fact ord, fact b)
  finally show ?thesis.
qed

lemma max_list_le:
  fixes xs :: "'a :: preorder list"
  assumes a: "\<And>x. x \<in> set xs \<Longrightarrow> x \<le> a"
      and xs: "xs \<noteq> []"
  shows "max_list xs \<le> a"
  using max_list_mem[OF xs] a by auto

lemma max_list_as_Greatest:
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> x \<le> y \<or> y \<le> x"
  shows "max_list xs = (GREATEST a. a \<in> set xs)"
proof (cases "xs = []")
  case True
  then show ?thesis by (unfold Greatest_def, auto simp: max_list.simps(1))
next
  case False
  from assms have 1: "x \<in> set xs \<Longrightarrow> x \<le> max_list xs" for x
    by (auto intro: le_max_list)
  have 2: "max_list xs \<in> set xs" by (fact max_list_mem[OF False])
  have "\<exists>!x. x \<in> set xs \<and> (\<forall>y. y \<in> set xs \<longrightarrow> y \<le> x)" (is "\<exists>!x. ?P x")
  proof (intro ex1I)
    from 1 2
    show "?P (max_list xs)" by auto
  next
    fix x assume 3: "?P x"
    with 1 have "x \<le> max_list xs" by auto
    moreover from 2 3 have "max_list xs \<le> x" by auto
    ultimately show "x = max_list xs" by auto
  qed
  note 3 = theI_unique[OF this,symmetric]
  from 1 2 show ?thesis
    by (unfold Greatest_def Cons 3, auto)
qed

lemma hom_max_list_commute:
  assumes "xs \<noteq> []"
      and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> h (max x y) = max (h x) (h y)"
  shows "h (max_list xs) = max_list (map h xs)"
  by (insert assms, induct xs, auto simp: max_list_Cons max_list_mem)

(*Efficient rev [i..<j]*)
primrec rev_upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_>.._])") where
rev_upt_0: "[0>..j] = []" |
rev_upt_Suc: "[(Suc i)>..j] = (if i \<ge> j then i # [i>..j] else [])"

definition rev_upt_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list" where
  "rev_upt_aux i j js = [i>..j] @ js"

lemma upt_aux_rec [code]:
  "rev_upt_aux i j js = (if j\<ge>i then js else rev_upt_aux i (Suc j) (j#js))"
  by (induct j, auto simp add: rev_upt_aux_def rev_upt_rec)

lemma rev_upt_code[code]: "[i>..j] = rev_upt_aux i j []"
  by(simp add: rev_upt_aux_def)

lemma upt_rev_upt:
  "rev [j>..i] = [i..<j]"
  by (induct j, auto)

lemma rev_upt_upt:
  "rev [i..<j] = [j>..i]"
  by (induct j, auto)

lemma length_rev_upt [simp]: "length [i>..j] = i - j"
  by (induct i) (auto simp add: Suc_diff_le)

lemma nth_rev_upt [simp]: "j + k < i \<Longrightarrow> [i>..j] ! k = i - 1 - k"
proof -
  assume jk_i: "j + k < i"
  have "[i>..j] = rev [j..<i]" using rev_upt_upt by simp
  also have "... ! k = [j..<i] ! (length [j..<i] - 1 - k)"
    by (rule nth_rev, insert jk_i, auto)
  also have "... = [j..<i] ! (i - j - 1 - k)" by auto
  also have "... = j + (i - j - 1 - k)" by (rule nth_upt, insert jk_i, auto)
  finally show ?thesis using jk_i by auto
qed

lemma nth_map_rev_upt:
  assumes i: "i < m-n"
  shows "(map f [m>..n]) ! i = f (m - 1 - i)"
proof -
  have "(map f [m>..n]) ! i = f ([m>..n] ! i)" by (rule nth_map, auto simp add: i)
  also have "... = f (m - 1 - i)"
  proof (rule arg_cong[of _ _ f], rule nth_rev_upt)
    show "n + i < m" using i by linarith
  qed
  finally show ?thesis .
qed

lemma coeff_mult_monom:
 "coeff (p * monom a d) i = (if d \<le> i then a * coeff p (i - d) else 0)"
  using coeff_monom_mult[of a d p] by (simp add: ac_simps)

(**** End of the lemmas which may be part of the standard library ****)

(**** The following lemmas could be moved to Algebraic_Numbers/Resultant.thy ****)
lemma vec_of_poly_0 [simp]: "vec_of_poly 0 = 0\<^sub>v 1" by (auto simp: vec_of_poly_def)

lemma vec_index_vec_of_poly [simp]: "i \<le> degree p \<Longrightarrow> vec_of_poly p $ i = coeff p (degree p - i)"
  by (simp add: vec_of_poly_def Let_def)

lemma poly_of_vec_vec: "poly_of_vec (vec n f) = Poly (rev (map f [0..<n]))"
proof (induct n arbitrary:f)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have "map f [0..<Suc n] = f 0 # map (f \<circ> Suc) [0..<n]" by (simp add: map_upt_Suc del: upt_Suc)
  also have "Poly (rev \<dots>) = Poly (rev (map (f \<circ> Suc) [0..<n])) + monom (f 0) n"
    by (simp add: Poly_snoc smult_monom)
  also have "\<dots> = poly_of_vec (vec n (f \<circ> Suc)) + monom (f 0) n"
    by (fold Suc, simp)
  also have "\<dots> = poly_of_vec (vec (Suc n) f)"
    apply (unfold poly_of_vec_def Let_def dim_vec sum.lessThan_Suc)
    by (auto simp add: Suc_diff_Suc)
  finally show ?case..
qed

lemma sum_list_map_dropWhile0:
  assumes f0: "f 0 = 0"
  shows "sum_list (map f (dropWhile ((=) 0) xs)) = sum_list (map f xs)"
  by (induct xs, auto simp add: f0)

lemma coeffs_poly_of_vec:
  "coeffs (poly_of_vec v) = rev (dropWhile ((=) 0) (list_of_vec v))"
proof-
  obtain n f where v: "v = vec n f" by transfer auto
  show ?thesis by (simp add: v poly_of_vec_vec)
qed

lemma poly_of_vec_vCons:
 "poly_of_vec (vCons a v) = monom a (dim_vec v) + poly_of_vec v" (is "?l = ?r")
  by (auto intro: poly_eqI simp: coeff_poly_of_vec vec_index_vCons)

lemma poly_of_vec_as_Poly: "poly_of_vec v = Poly (rev (list_of_vec v))"
  by (induct v, auto simp:poly_of_vec_vCons Poly_snoc ac_simps)

lemma poly_of_vec_add:
  assumes "dim_vec a = dim_vec b"
  shows "poly_of_vec (a + b) = poly_of_vec a + poly_of_vec b"
  using assms
  by (auto simp add: poly_eq_iff coeff_poly_of_vec)

(*TODO: replace the one in Resultant.thy*)
lemma degree_poly_of_vec_less:
  assumes "0 < dim_vec v" and "dim_vec v \<le> n" shows "degree (poly_of_vec v) < n"
  using degree_poly_of_vec_less assms by (auto dest: less_le_trans)

lemma (in vec_module) poly_of_vec_finsum:
  assumes "f \<in> X \<rightarrow> carrier_vec n"
  shows "poly_of_vec (finsum V f X) = (\<Sum>i\<in>X. poly_of_vec (f i))"
proof (cases "finite X")
  case False then show ?thesis by auto
next
  case True show ?thesis
  proof (insert True assms, induct X rule: finite_induct)
    case IH: (insert a X)
    have [simp]: "f x \<in> carrier_vec n" if x: "x \<in> X" for x
      using x IH.prems unfolding Pi_def by auto
    have [simp]: "f a \<in> carrier_vec n" using IH.prems unfolding Pi_def by auto
    have [simp]: "dim_vec (finsum V f X) = n" by simp
    have [simp]: "dim_vec (f a) = n" by simp
    show ?case
    proof (cases "a \<in> X")
      case True then show ?thesis by (auto simp: insert_absorb IH)
    next
      case False
      then have "(finsum V f (insert a X)) = f a + (finsum V f X)"
        by (auto intro: finsum_insert IH)
      also have "poly_of_vec ... = poly_of_vec (f a) + poly_of_vec (finsum V f X)"
        by (rule poly_of_vec_add, simp)
      also have "... = (\<Sum>i\<in>insert a X. poly_of_vec (f i))"
        using IH False by (subst sum.insert, auto)
      finally show ?thesis .
    qed
  qed auto
qed

(*This function transforms a polynomial to a vector of dimension n*)
definition "vec_of_poly_n p n =
  vec n (\<lambda>i. if i < n - degree p - 1 then 0 else coeff p (n - i - 1))"

(* TODO: make it abbreviation? *)
lemma vec_of_poly_as: "vec_of_poly_n p (Suc (degree p)) = vec_of_poly p"
  by (induct p, auto simp: vec_of_poly_def vec_of_poly_n_def)

lemma vec_of_poly_n_0 [simp]: "vec_of_poly_n p 0 = vNil"
  by (auto simp: vec_of_poly_n_def)

lemma vec_dim_vec_of_poly_n [simp]:
  "dim_vec (vec_of_poly_n p n) = n"
  "vec_of_poly_n p n \<in> carrier_vec n"
  unfolding vec_of_poly_n_def by auto

lemma dim_vec_of_poly [simp]: "dim_vec (vec_of_poly f) = degree f + 1"
  by (simp add: vec_of_poly_as[symmetric])

lemma vec_index_of_poly_n:
  assumes "i < n"
  shows "vec_of_poly_n p n $ i =
    (if i < n - Suc (degree p) then 0 else coeff p (n - i - 1))"
  using assms by (auto simp: vec_of_poly_n_def Let_def)

lemma vec_of_poly_n_pCons[simp]:
  shows "vec_of_poly_n (pCons a p) (Suc n) = vec_of_poly_n p n @\<^sub>v vec_of_list [a]" (is "?l = ?r")
proof (unfold vec_eq_iff, intro conjI allI impI)
  show "dim_vec ?l = dim_vec ?r" by auto
  show "i < dim_vec ?r \<Longrightarrow> ?l $ i = ?r $ i" for i
    by (cases "n - i", auto simp: coeff_pCons less_Suc_eq_le vec_index_of_poly_n)
qed

lemma vec_of_poly_pCons:
  shows "vec_of_poly (pCons a p) =
   (if p = 0 then vec_of_list [a] else vec_of_poly p @\<^sub>v vec_of_list [a])"
  by (cases "degree p", auto simp: vec_of_poly_as[symmetric])

lemma list_of_vec_of_poly [simp]:
  "list_of_vec (vec_of_poly p) = (if p = 0 then [0] else rev (coeffs p))"
  by (induct p, auto simp: vec_of_poly_pCons)

lemma poly_of_vec_of_poly_n:
  assumes p: "degree p<n"
  shows "poly_of_vec (vec_of_poly_n p n) = p"
proof -
  have "vec_of_poly_n p n $ (n - Suc i) = coeff p i" if i: "i < n" for i
  proof -
    have n: "n - Suc i < n" using i by auto
    have "vec_of_poly_n p n $ (n - Suc i) =
      (if n - Suc i < n - Suc (degree p) then 0 else coeff p (n - (n - Suc i) - 1))"
      using vec_index_of_poly_n[OF n, of p] .
    also have "... = coeff p i" using i n le_degree by fastforce
    finally show ?thesis .
  qed
  moreover have "coeff p i = 0" if i2: "i \<ge> n" for i
    by (rule coeff_eq_0, insert i2 p, simp)
  ultimately show ?thesis
  using assms
  unfolding poly_eq_iff
  unfolding coeff_poly_of_vec by auto
qed

lemma vec_of_poly_n0[simp]: "vec_of_poly_n 0 n = 0\<^sub>v n"
  unfolding vec_of_poly_n_def by auto

lemma vec_of_poly_n_add: "vec_of_poly_n (a + b) n = vec_of_poly_n a n + vec_of_poly_n b n"
proof (induct n arbitrary: a b)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case by (cases a, cases b, auto)
qed

lemma vec_of_poly_n_poly_of_vec:
  assumes n: "dim_vec g = n"
  shows "vec_of_poly_n (poly_of_vec g) n = g"
proof (auto simp add: poly_of_vec_def vec_of_poly_n_def assms vec_eq_iff Let_def)
  have d: "degree (\<Sum>i<n. monom (g $ (n - Suc i)) i) = degree (poly_of_vec g)"
    unfolding poly_of_vec_def Let_def n by auto
  fix i assume i1: "i < n - Suc (degree (\<Sum>i<n. monom (g $ (n - Suc i)) i))"
    and i2: "i < n"
  have i3: "i < n - Suc (degree (poly_of_vec g))"
    using i1 unfolding d by auto
  hence "dim_vec g - Suc i > degree (poly_of_vec g)"
    using n by linarith
  then show "g $ i = 0" using i1 i2 i3
    by (metis (no_types, lifting) Suc_diff_Suc coeff_poly_of_vec diff_Suc_less
        diff_diff_cancel leD le_degree less_imp_le_nat n neq0_conv)
next
  fix i assume "i < n"
  thus "coeff (\<Sum>i<n. monom (g $ (n - Suc i)) i) (n - Suc i) = g $ i"
    by (metis (no_types) Suc_diff_Suc coeff_poly_of_vec diff_diff_cancel
        diff_less_Suc less_imp_le_nat n not_less_eq poly_of_vec_def)
qed

lemma poly_of_vec_scalar_mult:
  assumes "degree b<n"
  shows "poly_of_vec (a \<cdot>\<^sub>v (vec_of_poly_n b n)) = smult a b"
  using assms
  by (auto simp add: poly_eq_iff coeff_poly_of_vec vec_of_poly_n_def coeff_eq_0)

(*TODO: replace the one in Resultant.thy*)
definition vec_of_poly_rev_shifted where
  "vec_of_poly_rev_shifted p n s j \<equiv>
   vec n (\<lambda>i. if i \<le> j \<and> j \<le> s + i then coeff p (s + i - j) else 0)"

lemma vec_of_poly_rev_shifted_dim[simp]: "dim_vec (vec_of_poly_rev_shifted p n s j) = n"
  unfolding vec_of_poly_rev_shifted_def by auto

lemma col_sylvester_sub: (* TODO: from this directly derive col_sylvester *)
  assumes j: "j < m + n"
  shows "col (sylvester_mat_sub m n p q) j =
    vec_of_poly_rev_shifted p n m j @\<^sub>v vec_of_poly_rev_shifted q m n j" (is "?l = ?r")
proof
  show "dim_vec ?l = dim_vec ?r" by simp
  fix i assume "i < dim_vec ?r" then have i: "i < m+n" by auto
  show "?l $ i = ?r $ i"
    unfolding vec_of_poly_rev_shifted_def
    apply (subst index_col) using i apply simp using j apply simp
    apply (subst sylvester_mat_sub_index) using i apply simp using j apply simp
    apply (cases "i < n") using i apply force using i
    apply (auto simp: not_less not_le intro!: coeff_eq_0)
    done
qed

lemma vec_of_poly_rev_shifted_scalar_prod:
  fixes p v
  defines "q \<equiv> poly_of_vec v"
  assumes m: "degree p \<le> m" and n: "dim_vec v = n"
  assumes j: "j < m+n"
  shows "vec_of_poly_rev_shifted p n m (n+m-Suc j) \<bullet> v = coeff (p * q) j" (is "?l = ?r")
proof -
  have id1: "\<And> i. m + i - (n + m - Suc j) = i + Suc j - n"
    using j by auto
  let ?g = "\<lambda> i. if i \<le> n + m - Suc j \<and> n - Suc j \<le> i then coeff p (i + Suc j - n) *  v $ i else 0"
  have "?thesis = ((\<Sum>i = 0..<n. ?g i) =
        (\<Sum>i\<le>j. coeff p i * (if j - i < n then v $ (n - Suc (j - i)) else 0)))" (is "_ = (?l = ?r)")
    unfolding vec_of_poly_rev_shifted_def coeff_mult m scalar_prod_def n q_def
      coeff_poly_of_vec
    by (subst sum.cong, insert id1, auto)
  also have "..."
  proof -
    have "?r = (\<Sum>i\<le>j. (if j - i < n then coeff p i * v $ (n - Suc (j - i)) else 0))" (is "_ = sum ?f _")
      by (rule sum.cong, auto)
    also have "sum ?f {..j} = sum ?f ({i. i \<le> j \<and> j - i < n} \<union> {i. i \<le> j \<and> \<not> j - i < n})"
      (is "_ = sum _ (?R1 \<union> ?R2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?f ?R1 + sum ?f ?R2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?f ?R2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?f ?R1 + 0 = sum (\<lambda> i. coeff p i * v $ (i + n - Suc j)) ?R1"
      (is "_ = sum ?F _")
      by (subst sum.cong, auto simp: ac_simps)
    also have "\<dots> = sum ?F ((?R1 \<inter> {..m}) \<union> (?R1 - {..m}))"
      (is "_ = sum _ (?R \<union> ?R')")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?F ?R + sum ?F ?R'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?F ?R' = 0"
    proof -
      {
        fix x
        assume "x > m"
        with m
        have "?F x = 0" by (subst coeff_eq_0, auto)
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have r: "?r = sum ?F ?R" by simp

    have "?l = sum ?g ({i. i < n \<and> i \<le> n + m - Suc j \<and> n - Suc j \<le> i}
      \<union> {i. i < n \<and> \<not> (i \<le> n + m - Suc j \<and> n - Suc j \<le> i)})"
      (is "_ = sum _ (?L1 \<union> ?L2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?g ?L1 + sum ?g ?L2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?g ?L2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?g ?L1 + 0 = sum (\<lambda> i. coeff p (i + Suc j - n) * v $ i) ?L1"
      (is "_ = sum ?G _")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G (?L1 \<inter> {i. i + Suc j - n \<le> m} \<union> (?L1 - {i. i + Suc j - n \<le> m}))"
      (is "_ = sum _ (?L \<union> ?L')")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G ?L + sum ?G ?L'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?G ?L' = 0"
    proof -
      {
        fix x
        assume "x + Suc j - n > m"
        with m
        have "?G x = 0" by (subst coeff_eq_0, auto)
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have l: "?l = sum ?G ?L" by simp

    let ?bij = "\<lambda> i. i + n - Suc j"
    {
      fix x
      assume x: "j < m + n" "Suc (x + j) - n \<le> m" "x < n" "n - Suc j \<le> x"
      define y where "y = x + Suc j - n"
      from x have "x + Suc j \<ge> n" by auto
      with x have xy: "x = ?bij y" unfolding y_def by auto
      from x have y: "y \<in> ?R" unfolding y_def by auto
      have "x \<in> ?bij ` ?R" unfolding xy using y by blast
    } note tedious = this
    show ?thesis unfolding l r
      by (rule sum.reindex_cong[of ?bij], insert j, auto simp: inj_on_def tedious)
  qed
  finally show ?thesis by simp
qed

lemma sylvester_sub_poly:
  fixes p q :: "'a :: comm_semiring_0 poly"
  assumes m: "degree p \<le> m"
  assumes n: "degree q \<le> n"
  assumes v: "v \<in> carrier_vec (m+n)"
  shows "poly_of_vec ((sylvester_mat_sub m n p q)\<^sup>T *\<^sub>v v) =
    poly_of_vec (vec_first v n) * p + poly_of_vec (vec_last v m) * q" (is "?l = ?r")
proof (rule poly_eqI)
  fix i
  let ?Tv = "(sylvester_mat_sub m n p q)\<^sup>T *\<^sub>v v"
  have dim: "dim_vec (vec_first v n) = n" "dim_vec (vec_last v m) = m" "dim_vec ?Tv = n + m"
    using v by auto
  have if_distrib: "\<And> x y z. (if x then y else (0 :: 'a)) * z = (if x then y * z else 0)"
    by auto
  show "coeff ?l i = coeff ?r i"
  proof (cases "i < m+n")
    case False
      hence i_mn: "i \<ge> m+n"
        and i_n: "\<And>x. x \<le> i \<and> x < n \<longleftrightarrow> x < n"
        and i_m: "\<And>x. x \<le> i \<and> x < m \<longleftrightarrow> x < m" by auto
      have "coeff ?r i =
            (\<Sum> x < n. vec_first v n $ (n - Suc x) * coeff p (i - x)) +
            (\<Sum> x < m. vec_last v m $ (m - Suc x) * coeff q (i - x))"
        (is "_ = sum ?f _ + sum ?g _")
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim if_distrib
        unfolding atMost_def
        apply(subst sum.inter_filter[symmetric],simp)
        apply(subst sum.inter_filter[symmetric],simp)
        unfolding mem_Collect_eq
        unfolding i_n i_m
        unfolding lessThan_def by simp
      also { fix x assume x: "x < n"
        have "coeff p (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x m by auto
        hence "?f x = 0" by auto
      } hence "sum ?f {..<n} = 0" by auto
      also { fix x assume x: "x < m"
        have "coeff q (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x n by auto
        hence "?g x = 0" by auto
      } hence "sum ?g {..<m} = 0" by auto
      finally have "coeff ?r i = 0" by auto
      also from False have "0 = coeff ?l i"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      finally show ?thesis by auto
    next case True
      hence "coeff ?l i = ((sylvester_mat_sub m n p q)\<^sup>T *\<^sub>v v) $ (n + m - Suc i)"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      also have "... = coeff (p * poly_of_vec (vec_first v n) + q * poly_of_vec (vec_last v m)) i"
        apply(subst index_mult_mat_vec) using True apply simp
        apply(subst row_transpose) using True apply simp
        apply(subst col_sylvester_sub)
        using True apply simp
        apply(subst vec_first_last_append[of v n m,symmetric]) using v apply(simp add: add.commute)
        apply(subst scalar_prod_append)
        apply (rule carrier_vecI,simp)+
        apply (subst vec_of_poly_rev_shifted_scalar_prod[OF m],simp) using True apply simp
        apply (subst add.commute[of n m])
        apply (subst vec_of_poly_rev_shifted_scalar_prod[OF n]) apply simp using True apply simp
        by simp
      also have "... =
        (\<Sum>x\<le>i. (if x < n then vec_first v n $ (n - Suc x) else 0) * coeff p (i - x)) +
        (\<Sum>x\<le>i. (if x < m then vec_last v m $ (m - Suc x) else 0) * coeff q (i - x))"
        unfolding coeff_poly_of_vec[of "vec_first v n",unfolded dim_vec_first,symmetric]
        unfolding coeff_poly_of_vec[of "vec_last v m",unfolded dim_vec_last,symmetric]
        unfolding coeff_mult[symmetric] by (simp add: mult.commute)
      also have "... = coeff ?r i"
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim..
      finally show ?thesis.
  qed
qed

(**** End of the lemmas which could be moved to Algebraic_Numbers/Resultant.thy ****)

(**** The following lemmas could be moved to Computational_Algebra/Polynomial.thy ****)

lemma normalize_field [simp]: "normalize (a :: 'a :: {field, semiring_gcd}) = (if a = 0 then 0 else 1)"
  using unit_factor_normalize by fastforce

lemma content_field [simp]: "content (p :: 'a :: {field,semiring_gcd} poly) = (if p = 0 then 0 else 1)"
  by (induct p, auto simp: content_def)

lemma primitive_part_field [simp]: "primitive_part (p :: 'a :: {field,semiring_gcd} poly) = p"
  by (cases "p = 0", auto intro!: primitive_part_prim)

lemma primitive_part_dvd: "primitive_part a dvd a"
  by (metis content_times_primitive_part dvd_def dvd_refl mult_smult_right)

lemma degree_abs [simp]:
  "degree \<bar>p\<bar> = degree p" by (auto simp: abs_poly_def)

lemma degree_gcd1:
  assumes a_not0: "a \<noteq> 0"
  shows "degree (gcd a b) \<le> degree a"
proof -
  let ?g = "gcd a b"
  have gcd_dvd_b: "?g dvd a" by simp
  from this obtain c where a_gc: "a = ?g * c" unfolding dvd_def by auto
  have g_not0: "?g \<noteq>0" using a_not0 a_gc by auto
  have c0: "c \<noteq> 0" using a_not0 a_gc by auto
  have "degree ?g \<le> degree (?g * c)" by (rule degree_mult_right_le[OF c0])
  also have "... = degree a" using a_gc by auto
  finally show ?thesis .
qed

lemma primitive_part_neg [simp]:
  fixes a::"'a :: {factorial_ring_gcd,factorial_semiring_multiplicative} poly"
  shows "primitive_part (-a) = - primitive_part a"
proof -
  have "primitive_part (-a) = primitive_part (smult (-1) a)" by auto
  then show ?thesis unfolding primitive_part_smult
    by (simp add: is_unit_unit_factor)
qed

lemma content_uminus[simp]:
  fixes f::"int poly"
  shows "content (-f) = content f"
proof -
  have "-f = - (smult 1 f)" by auto
  also have "... = smult (-1) f" using smult_minus_left by auto
  finally have "content (-f) = content (smult (-1) f)" by auto
  also have "... = normalize (- 1) * content f" unfolding content_smult ..
  finally show ?thesis by auto
qed

lemma pseudo_mod_monic:
  fixes f g :: "'a::{comm_ring_1,semiring_1_no_zero_divisors} poly"
  defines "r \<equiv> pseudo_mod f g"
  assumes monic_g: "monic g"
  shows "\<exists>q.  f = g * q + r" "r = 0 \<or> degree r < degree g"
proof -
  let ?cg = "coeff g (degree g)"
  let ?cge = "?cg ^ (Suc (degree f) - degree g)"
  define a where "a = ?cge"
  from r_def[unfolded pseudo_mod_def] obtain q where pdm: "pseudo_divmod f g = (q, r)"
    by (cases "pseudo_divmod f g") auto
  have g: "g \<noteq> 0" using monic_g by auto
  from pseudo_divmod[OF g pdm] have id: "smult a f = g * q + r" and "r = 0 \<or> degree r < degree g"
    by (auto simp: a_def)
  have a1: "a = 1" unfolding a_def using monic_g by auto
  hence id2: "f = g * q + r" using id by auto
  show "r = 0 \<or> degree r < degree g" by fact
  from g have "a \<noteq> 0"
    by (auto simp: a_def)
  with id2 show "\<exists>q. f = g * q + r"
    by auto
qed

lemma monic_imp_div_mod_int_poly_degree:
  fixes p :: "'a::{comm_ring_1,semiring_1_no_zero_divisors} poly"
  assumes m: "monic u"
  shows "\<exists>q r. p = q*u + r \<and> (r = 0 \<or> degree r < degree u)"
  using pseudo_mod_monic[OF m] using mult.commute by metis

corollary monic_imp_div_mod_int_poly_degree2:
  fixes p :: "'a::{comm_ring_1,semiring_1_no_zero_divisors} poly"
  assumes m: "monic u" and deg_u: "degree u > 0"
  shows "\<exists>q r. p = q*u + r \<and> (degree r < degree u)"
proof -
  obtain q r where "p = q * u + r" and r: "(r = 0 \<or> degree r < degree u)"
      using monic_imp_div_mod_int_poly_degree[OF m, of p] by auto
    moreover have "degree r < degree u" using deg_u r by auto
  ultimately show ?thesis by auto
qed
(**** End of the lemmas that could be moved to Computational_Algebra/Polynomial.thy ****)

(* To be categorized *)
lemma (in zero_hom) hom_upper_triangular:
  "A \<in> carrier_mat n n \<Longrightarrow> upper_triangular A \<Longrightarrow> upper_triangular (map_mat hom A)"
  by (auto simp: upper_triangular_def)

end