theory Polynomial_Expression_Additional
  imports
    "Polynomial_Expression"
    "HOL-Decision_Procs.Approximation"
begin

lemma real_of_float_eq_zero_iff[simp]: "real_of_float x = 0 \<longleftrightarrow> x = 0"
  by (simp add: real_of_float_eq)

text \<open>Theory @{theory Taylor_Models.Polynomial_Expression} contains a, more or less, 1:1 generalization
   of theory \<open>Multivariate_Polynomial\<close>. Any additions belong here.\<close>

declare [[coercion_map map_poly]]
declare [[coercion "interval_of::float\<Rightarrow>float interval"]]

text \<open>Apply float interval arguments to a float poly.\<close>
value "Ipoly [Ivl (Float 4 (-6)) (Float 10 6)] (poly.Add (poly.C (Float 3 5)) (poly.Bound 0))"

text \<open>@{term map_poly} for homomorphisms\<close>

lemma map_poly_homo_polyadd_eq_zero_iff:
  "map_poly f (p +\<^sub>p q) = 0\<^sub>p \<longleftrightarrow> p +\<^sub>p q = 0\<^sub>p"
  if [symmetric, simp]: "\<And>x y. f (x + y) = f x + f y" "\<And>x. f x = 0 \<longleftrightarrow> x = 0"
  by (induction p q rule: polyadd.induct) auto

lemma zero_iffD: "(\<And>x. f x = 0 \<longleftrightarrow> x = 0) \<Longrightarrow> f 0 = 0"
  by auto

lemma map_poly_homo_polyadd:
  "map_poly f (p1 +\<^sub>p p2) = map_poly f p1 +\<^sub>p map_poly f p2"
  if [simp]: "\<And>x y. f (x + y) = f x + f y" "\<And>x. f x = 0 \<longleftrightarrow> x = 0"
  by (induction p1 p2 rule: polyadd.induct)
    (auto simp: zero_iffD[OF that(2)] Let_def map_poly_homo_polyadd_eq_zero_iff)

lemma map_poly_homo_polyneg:
  "map_poly f (~\<^sub>p p1) = ~\<^sub>p (map_poly f p1)"
  if [simp]: "\<And>x y. f (- x) = - f x"
  by (induction p1) (auto simp: Let_def map_poly_homo_polyadd_eq_zero_iff)

lemma map_poly_homo_polysub:
  "map_poly f (p1 -\<^sub>p p2) = map_poly f p1 -\<^sub>p map_poly f p2"
  if [simp]: "\<And>x y. f (x + y) = f x + f y" "\<And>x. f x = 0 \<longleftrightarrow> x = 0" "\<And>x y. f (- x) = - f x"
  by (auto simp: polysub_def map_poly_homo_polyadd map_poly_homo_polyneg)

lemma map_poly_homo_polymul:
  "map_poly f (p1 *\<^sub>p p2) = map_poly f p1 *\<^sub>p map_poly f p2"
  if [simp]: "\<And>x y. f (x + y) = f x + f y" "\<And>x. f x = 0 \<longleftrightarrow> x = 0" "\<And>x y. f (x * y) = f x * f y"
  by (induction p1 p2 rule: polymul.induct)
    (auto simp: zero_iffD[OF that(2)] map_poly_homo_polyadd)

lemma map_poly_homo_polypow:
  "map_poly f (p1 ^\<^sub>p n) = map_poly f p1 ^\<^sub>p n"
  if [simp]: "\<And>x y. f (x + y) = f x + f y" "\<And>x. f x = 0 \<longleftrightarrow> x = 0" "\<And>x y. f (x * y) = f x * f y"
    "f 1 = 1"
proof(induction n rule: nat_less_induct)
  case (1 n)
  then show ?case
    apply (cases n)
     apply (auto simp: map_poly_homo_polyadd map_poly_homo_polymul)
    by (smt Suc_less_eq div2_less_self even_Suc odd_Suc_div_two map_poly_homo_polymul that)
qed

lemmas map_poly_homo_polyarith = map_poly_homo_polyadd map_poly_homo_polyneg map_poly_homo_polysub map_poly_homo_polymul map_poly_homo_polypow

text \<open>Count the number of parameters of a polynomial.\<close>

fun num_params :: "'a poly \<Rightarrow> nat"
  where "num_params (poly.C c) = 0"
  | "num_params (poly.Bound n)  = Suc n"
  | "num_params (poly.Add a b)  = max (num_params a) (num_params b)"
  | "num_params (poly.Sub a b)  = max (num_params a) (num_params b)"
  | "num_params (poly.Mul a b)  = max (num_params a) (num_params b)"
  | "num_params (poly.Neg a)    = num_params a"
  | "num_params (poly.Pw a n)   = num_params a"
  | "num_params (poly.CN a n b) = max (max (num_params a) (num_params b)) (Suc n)"

lemma num_params_map_poly[simp]:
  shows "num_params (map_poly f p) = num_params p"
  by (induction p, simp_all)

lemma num_params_polyadd:
  shows "num_params (p1 +\<^sub>p p2) \<le> max (num_params p1) (num_params p2)"
proof (induction p1 p2 rule: polyadd.induct)
  case (4 c n p c' n' p')
  then show ?case
    by auto (auto simp: max_def Let_def split: if_splits)
qed auto

lemma num_params_polyneg:
  shows "num_params (~\<^sub>p p) = num_params p"
  by (induction p rule: polyneg.induct) simp_all

lemma num_params_polymul:
  shows "num_params (p1 *\<^sub>p p2) \<le> max (num_params p1) (num_params p2)"
proof (induction p1 p2 rule: polymul.induct)
  case (4 c n p c' n' p')
  then show ?case
    by auto (auto simp: max_def Let_def split: if_splits
          intro!: num_params_polyadd[THEN order_trans])
qed auto

lemma num_params_polypow:
  shows "num_params (p ^\<^sub>p n) \<le> num_params p"
  apply (induction n rule: polypow.induct)
  unfolding polypow.simps
  by (auto intro!: order_trans[OF num_params_polymul]
      simp: Let_def simp del: polypow.simps)

lemma num_params_polynate:
  shows "num_params (polynate p) \<le> num_params p"
proof(induction p rule: polynate.induct)
  case (2 l r)
  thus ?case
    using num_params_polyadd[of "polynate l" "polynate r"]
    by simp
next
  case (3 l r)
  thus ?case
    using num_params_polyadd[of "polynate l" "~\<^sub>p (polynate r)"]
    by (simp add: polysub_def num_params_polyneg)
next
  case (4 l r)
  thus ?case
    using num_params_polymul[of "polynate l" "polynate r"]
    by simp
next
  case (5 p)
  thus ?case
    by (simp add: num_params_polyneg)
next
  case (6 p n)
  thus ?case
    using num_params_polypow[of n "polynate p"]
    by simp
qed simp_all

lemma polynate_map_poly_real[simp]:
  fixes p :: "float poly"
  shows "map_poly real_of_float (polynate p) = polynate (map_poly real_of_float p)"
  by (induction p) (simp_all add: map_poly_homo_polyarith)

text \<open>Evaluating a float poly is equivalent to evaluating the corresponding
   real poly with the float parameters converted to reals.\<close>
lemma Ipoly_real_float_eqiv:
  fixes p::"float poly" and xs::"float list"
  assumes "num_params p \<le> length xs"
  shows "Ipoly xs (p::real poly) = Ipoly xs p"
  using assms by (induction p, simp_all)

text \<open>Evaluating an \<open>'a poly\<close> with \<open>'a interval\<close> arguments is monotone.\<close>
lemma Ipoly_interval_args_mono:
  fixes p::"'a::linordered_idom poly"
    and   x::"'a list"
    and   xs::"'a interval list"
  assumes "x all_in\<^sub>i xs"
  assumes "num_params p \<le> length xs"
  shows "Ipoly x p \<in> set_of (Ipoly xs (map_poly interval_of p))"
  using assms
  by (induction p)
    (auto simp: all_in_i_def plus_in_intervalI minus_in_intervalI times_in_intervalI
      uminus_in_intervalI set_of_power_mono)

lemma Ipoly_interval_args_inc_mono:
  fixes p::"'a::{real_normed_algebra, linear_continuum_topology, linordered_idom} poly"
    and   I::"'a interval list" and J::"'a interval list"
  assumes "num_params p \<le> length I"
  assumes "I all_subset J"
  shows "set_of (Ipoly I (map_poly interval_of p)) \<subseteq> set_of (Ipoly J (map_poly interval_of p))"
  using assms
  by (induction p)
    (simp_all add: set_of_add_inc set_of_sub_inc set_of_mul_inc set_of_neg_inc set_of_pow_inc)

section \<open>Splitting polynomials to reduce floating point precision\<close>

text \<open>TODO: Move this!
  Definitions regarding floating point numbers should not be in a theory about polynomials.\<close>
fun float_prec :: "float \<Rightarrow> int"
  where "float_prec f = (let p=exponent f in if p \<ge> 0 then 0 else -p)"

fun float_round :: "nat \<Rightarrow> float \<Rightarrow> float"
  where "float_round prec f = (
         let d = float_down prec f; u = float_up prec f
         in if f - d < u - f then d else u)"

text \<open>Splits any polynomial \<open>p\<close> into two polynomials \<open>l\<close>, \<open>r\<close>, such that \<open>\<forall>x::real. p(x) = l(x) + r(x)\<close>
   and all floating point coefficients in \<open>p\<close> are rounded to precision \<open>prec\<close>.
   Not all cases need to give good results. Polynomials normalized with polynate
   only contain \<open>poly.C\<close> and \<open>poly.CN\<close> constructors.\<close>
fun split_by_prec :: "nat \<Rightarrow> float poly \<Rightarrow> float poly * float poly"
  where "split_by_prec prec (poly.C f) = (let r = float_round prec f in (poly.C r, poly.C (f - r)))"
  | "split_by_prec prec (poly.Bound n) = (poly.Bound n, poly.C 0)"
  | "split_by_prec prec (poly.Add l r) = (let (ll, lr) = split_by_prec prec l;
                                                (rl, rr) = split_by_prec prec r
                                            in (poly.Add ll rl, poly.Add lr rr))"
  | "split_by_prec prec (poly.Sub l r) = (let (ll, lr) = split_by_prec prec l;
                                             (rl, rr) = split_by_prec prec r
                                         in (poly.Sub ll rl, poly.Sub lr rr))"
  | "split_by_prec prec (poly.Mul l r) = (let (ll, lr) = split_by_prec prec l;
                                                (rl, rr) = split_by_prec prec r
                                            in (poly.Mul ll rl, poly.Add (poly.Add (poly.Mul lr rl) (poly.Mul ll rr)) (poly.Mul lr rr)))"
  | "split_by_prec prec (poly.Neg p) = (let (l, r) = split_by_prec prec p in (poly.Neg l, poly.Neg r))"
  | "split_by_prec prec (poly.Pw p 0) = (poly.C 1, poly.C 0)"
  | "split_by_prec prec (poly.Pw p (Suc n)) = (let (l, r) = split_by_prec prec p in (poly.Pw l n, poly.Sub (poly.Pw p (Suc n)) (poly.Pw l n)))"
  | "split_by_prec prec (poly.CN c n p) = (let (cl, cr) = split_by_prec prec c;
                                                 (pl, pr) = split_by_prec prec p
                                             in (poly.CN cl n pl, poly.CN cr n pr))"

text \<open>TODO: Prove precision constraint on \<open>l\<close>.\<close>
lemma split_by_prec_correct:
  fixes args :: "real list"
  assumes "(l, r) = split_by_prec prec p"
  shows "Ipoly args p = Ipoly args l + Ipoly args r" (is ?P1)
    and   "num_params l \<le> num_params p" (is ?P2)
    and   "num_params r \<le> num_params p" (is ?P3)
  unfolding atomize_conj
  using assms
proof(induction p arbitrary: l r)
  case (Add p1 p2 l r)
  thus ?case
    apply(simp add: Add(1,2)[OF prod.collapse] split_beta)
    using max.coboundedI1 max.coboundedI2 prod.collapse
    by metis
next
  case (Sub p1 p2 l r)
  thus ?case
    apply(simp add: Sub(1,2)[OF prod.collapse] split_beta)
    using max.coboundedI1 max.coboundedI2 prod.collapse
    by metis
next
  case (Mul p1 p2 l r)
  thus ?case
    apply(simp add: Mul(1,2)[OF prod.collapse] split_beta algebra_simps)
    using max.coboundedI1 max.coboundedI2 prod.collapse
    by metis
next
  case (Neg p l r)
  thus ?case by (simp add: Neg(1)[OF prod.collapse] split_beta)
next
  case (Pw p n l r)
  thus ?case by (cases n) (simp_all add: Pw(1)[OF prod.collapse] split_beta)
next
  case (CN c n p2)
  thus ?case
    apply(simp add: CN(1,2)[OF prod.collapse] split_beta algebra_simps)
    by (meson le_max_iff_disj prod.collapse)
qed (simp_all add: Let_def)

section \<open>Splitting polynomials by degree\<close>

fun maxdegree :: "('a::zero) poly \<Rightarrow> nat"
  where "maxdegree (poly.C c) = 0"
  | "maxdegree (poly.Bound n) = 1"
  | "maxdegree (poly.Add l r) = max (maxdegree l) (maxdegree r)"
  | "maxdegree (poly.Sub l r) = max (maxdegree l) (maxdegree r)"
  | "maxdegree (poly.Mul l r) = maxdegree l + maxdegree r"
  | "maxdegree (poly.Neg p) = maxdegree p"
  | "maxdegree (poly.Pw p n) = n * maxdegree p"
  | "maxdegree (poly.CN c n p) = max (maxdegree c) (1 + maxdegree p)"

fun split_by_degree :: "nat \<Rightarrow> 'a::zero poly \<Rightarrow> 'a poly * 'a poly"
  where "split_by_degree n (poly.C c) = (poly.C c, poly.C 0)"
  | "split_by_degree 0 p = (poly.C 0, p)"
  | "split_by_degree (Suc n) (poly.CN c v p) = (
         let (cl, cr) = split_by_degree (Suc n) c;
             (pl, pr) = split_by_degree n p
         in (poly.CN cl v pl, poly.CN cr v pr))"
    \<comment> \<open>This function is only intended for use on polynomials in normal form.
       Hence most cases never get executed.\<close>
  | "split_by_degree n p = (poly.C 0, p)"

lemma split_by_degree_correct:
  fixes x :: "real list" and p :: "float poly"
  assumes "(l, r) = split_by_degree ord p"
  shows "maxdegree l \<le> ord" (is ?P1)
    and   "Ipoly x p = Ipoly x l + Ipoly x r" (is ?P2)
    and   "num_params l \<le> num_params p" (is ?P3)
    and   "num_params r \<le> num_params p" (is ?P4)
  unfolding atomize_conj
  using assms
proof(induction p arbitrary: l r ord)
  case (C c l r ord)
  thus ?case by simp
next
  case (Bound v l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Add p1 p2 l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Sub p1 p2 l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Mul p1 p2 l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Neg p l r ord)
  thus ?case by (cases ord) simp_all
next
  case (Pw p k l r ord)
  thus ?case by (cases ord) simp_all
next
  case (CN c v p l r ord)
  then show ?case
  proof(cases ord)
    case (Suc m)
    obtain cl cr where cl_cr_def: "(cl, cr) = split_by_degree (Suc m) c"
      by (cases "split_by_degree (Suc m) c", simp)
    obtain pl pr where pl_pr_def: "(pl, pr) = split_by_degree m p"
      by (cases "split_by_degree m p", simp)
    have [simp]: "Ipoly x p = Ipoly x pl + Ipoly x pr"
      using CN(2)[OF pl_pr_def]
      by (cases ord) simp_all
    from CN(3)
    have l_decomp: "l = CN cl v pl" and r_decomp: "r = CN cr v pr"
      by (simp_all add: Suc cl_cr_def[symmetric] pl_pr_def[symmetric])
    show ?thesis
      using CN(1)[OF cl_cr_def]  CN(2)[OF pl_pr_def]
      unfolding l_decomp
      by (cases p) (auto simp add: l_decomp r_decomp algebra_simps Suc)
  qed simp
qed

text \<open>Operations on lists.\<close>

lemma length_map2[simp]: "length (map2 f a b) = min (length a) (length b)"
proof(induction "map2 f a b" arbitrary: a b)
  case (Nil a b)
  hence "a = [] | b = []"
    by(cases a, simp, cases b, simp_all)
  then show ?case
    by auto
next
  case (Cons x c a b)
  have "0 < length a \<and> 0 < length b"
    using Cons(2)
    by (cases a, simp, cases b, simp_all)
  then obtain xa ar xb br
    where a_decomp[simp]: "a = xa # ar"
      and   b_decomp[simp]: "b = xb # br"
    by (cases a, simp_all, cases b, simp_all)
  show ?case
    using Cons
    by simp
qed

lemma map2_nth[simp]:
  assumes "n < length a"
  assumes "n < length b"
  shows "(map2 f a b)!n = f (a!n) (b!n)"
  using assms
proof(induction n arbitrary: a b)
  case (0 a b)
  have "0 < length a" and "0 < length b"
    using 0
    by simp_all
  thus ?case
    using 0
    by simp
next
  case (Suc n a b)
  from Suc.prems have  "0 < length a" "0 < length b" "n < length (tl a)" "n < length (tl b)"
    using Suc.prems by auto
  have "map2 f a b = map2 f (hd a # tl a) (hd b # tl b)"
    using \<open>0 < length a\<close> \<open>0 < length b\<close>
    by simp
  also have "\<dots> ! Suc n = map2 f (tl a) (tl b) ! n"
    by simp
  also have "\<dots> = f (tl a ! n) (tl b ! n)"
    using \<open>n < length (tl a)\<close> \<open>n < length (tl b)\<close> by (rule Suc.IH)
  also have "tl a ! n = (hd a # tl a) ! Suc n" by simp
  also have "(hd a # tl a) = a" using \<open>0 < length a\<close> by simp
  also have "tl b ! n = (hd b # tl b) ! Suc n" by simp
  also have "(hd b # tl b) = b" using \<open>0 < length b\<close> by simp
  finally show ?case .
qed

text \<open>Translating a polynomial by a vector.\<close>
fun poly_translate :: "'a list \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
  where "poly_translate vs (poly.C c)  = poly.C c"
  | "poly_translate vs (poly.Bound n) = poly.Add (poly.Bound n) (poly.C (vs ! n))"
  | "poly_translate vs (poly.Add l r) = poly.Add (poly_translate vs l) (poly_translate vs r)"
  | "poly_translate vs (poly.Sub l r) = poly.Sub (poly_translate vs l) (poly_translate vs r)"
  | "poly_translate vs (poly.Mul l r) = poly.Mul (poly_translate vs l) (poly_translate vs r)"
  | "poly_translate vs (poly.Neg p) = poly.Neg (poly_translate vs p)"
  | "poly_translate vs (poly.Pw p n) = poly.Pw (poly_translate vs p) n"
  | "poly_translate vs (poly.CN c n p) = poly.Add (poly_translate vs c) (poly.Mul (poly.Add (poly.Bound n) (poly.C (vs ! n))) (poly_translate vs p))"

text \<open>Translating a polynomial is equivalent to translating its argument.\<close>
lemma poly_translate_correct:
  assumes "num_params p \<le> length x"
  assumes "length x = length v"
  shows "Ipoly x (poly_translate v p) = Ipoly (map2 (+) x v) p"
  using assms
  by (induction p, simp_all)

lemma real_poly_translate:
  assumes "num_params p \<le> length v"
  shows "Ipoly x (map_poly real_of_float (poly_translate v p)) = Ipoly x (poly_translate v (map_poly real_of_float p))"
  using assms
  by (induction p, simp_all)

lemma num_params_poly_translate[simp]:
  shows "num_params (poly_translate v p) = num_params p"
  by (induction p, simp_all)

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section \<open>Reconstructing Factors of Integer Polynomials\<close>

subsection \<open>Square-Free Polynomials over Finite Fields and Integers\<close>
theory Square_Free_Int_To_Square_Free_GFp
imports
  Subresultants.Subresultant_Gcd
  Polynomial_Factorization.Rational_Factorization
  Finite_Field
  Polynomial_Factorization.Square_Free_Factorization
begin

lemma square_free_int_rat: assumes sf: "square_free f"
  shows "square_free (map_poly rat_of_int f)"
proof -
  let ?r = "map_poly rat_of_int"
  from sf[unfolded square_free_def] have f0: "f \<noteq> 0" "\<And> q. degree q \<noteq> 0 \<Longrightarrow> \<not> q * q dvd f" by auto
  show ?thesis
  proof (rule square_freeI)
    show "?r f \<noteq> 0" using f0 by auto
    fix q
    assume dq: "degree q > 0" and dvd: "q * q dvd ?r f"
    hence q0: "q \<noteq> 0" by auto
    obtain q' c where norm: "rat_to_normalized_int_poly q = (c,q')" by force
    from rat_to_normalized_int_poly[OF norm] have c0: "c \<noteq> 0" by auto
    note q = rat_to_normalized_int_poly(1)[OF norm]
    from dvd obtain k where rf: "?r f = q * (q * k)" unfolding dvd_def by (auto simp: ac_simps)
    from rat_to_int_factor_explicit[OF this norm] obtain s where
      f: "f = q' * smult (content f) s" by auto
    let ?s = "smult (content f) s"
    from arg_cong[OF f, of ?r] c0
    have "?r f = q * (smult (inverse c) (?r ?s))"
      by (simp add: field_simps q hom_distribs)
    from arg_cong[OF this[unfolded rf], of "\<lambda> f. f div q"] q0
    have "q * k = smult (inverse c) (?r ?s)"
      by (metis nonzero_mult_div_cancel_left)
    from arg_cong[OF this, of "smult c"] have "?r ?s = q * smult c k" using c0
      by (auto simp: field_simps)
    from rat_to_int_factor_explicit[OF this norm] obtain t where "?s = q' * t" by blast
    from f[unfolded this] sf[unfolded square_free_def] f0 have "degree q' = 0" by auto
    with rat_to_normalized_int_poly(4)[OF norm] dq show False by auto
  qed
qed

lemma content_free_unit:
  assumes "content (p::'a::{idom,semiring_gcd} poly) = 1"
  shows "p dvd 1 \<longleftrightarrow> degree p = 0"
  by (insert assms, auto dest!:degree0_coeffs simp: normalize_1_iff poly_dvd_1)

lemma square_free_imp_resultant_non_zero: assumes sf: "square_free (f :: int poly)"
  shows "resultant f (pderiv f) \<noteq> 0"
proof (cases "degree f = 0")
  case True
  from degree0_coeffs[OF this] obtain c where f: "f = [:c:]" by auto
  with sf have c: "c \<noteq> 0" unfolding square_free_def by auto
  show ?thesis unfolding f by simp
next
  case False note deg = this
  define pp where "pp = primitive_part f"
  define c where "c = content f"
  from sf have f0: "f \<noteq> 0" unfolding square_free_def by auto
  hence c0: "c \<noteq> 0" unfolding c_def by auto
  have f: "f = smult c pp" unfolding c_def pp_def unfolding content_times_primitive_part[of f] ..
  from sf[unfolded f] c0 have sf': "square_free pp" by (metis dvd_smult smult_0_right square_free_def)
  from deg[unfolded f] c0 have deg': "\<And> x. degree pp > 0 \<or> x" by auto
  from content_primitive_part[OF f0] have cp: "content pp = 1" unfolding pp_def .
  let ?p' = "pderiv pp"
  {
    assume "resultant pp ?p' = 0"
    from this[unfolded resultant_0_gcd] have "\<not> coprime pp ?p'" by auto
    then obtain r where r: "r dvd pp" "r dvd ?p'" "\<not> r dvd 1"
      by (blast elim: not_coprimeE)
    from r(1) obtain k where "pp = r * k" ..
    from pos_zmult_eq_1_iff_lemma[OF arg_cong[OF this,
      of content, unfolded content_mult cp, symmetric]] content_ge_0_int[of r]
    have cr: "content r = 1" by auto
    with r(3) content_free_unit have dr: "degree r \<noteq> 0" by auto
    let ?r = "map_poly rat_of_int"
    from r(1) have dvd: "?r r dvd ?r pp" unfolding dvd_def by (auto simp: hom_distribs)
    from r(2) have "?r r dvd ?r ?p'" apply (intro of_int_poly_hom.hom_dvd) by auto
    also have "?r ?p' = pderiv (?r pp)" unfolding of_int_hom.map_poly_pderiv ..
    finally have dvd': "?r r dvd pderiv (?r pp)" by auto
    from dr have dr': "degree (?r r) \<noteq> 0" by simp
    from square_free_imp_separable[OF square_free_int_rat[OF sf']]
    have "separable (?r pp)" .
    hence cop: "coprime (?r pp) (pderiv (?r pp))" unfolding separable_def .
    from f0 f have pp0: "pp \<noteq> 0" by auto
    from dvd dvd' have "?r r dvd gcd (?r pp) (pderiv (?r pp))" by auto
    from divides_degree[OF this] pp0 have "degree (?r r) \<le> degree (gcd (?r pp) (pderiv (?r pp)))"
      by auto
    with dr' have "degree (gcd (?r pp) (pderiv (?r pp))) \<noteq> 0" by auto
    hence "\<not> coprime (?r pp) (pderiv (?r pp))" by auto
    with cop have False by auto
  }
  hence "resultant pp ?p' \<noteq> 0" by auto
  with resultant_smult_left[OF c0, of pp ?p', folded f] c0
  have "resultant f ?p' \<noteq> 0" by auto
  with resultant_smult_right[OF c0, of f ?p', folded pderiv_smult f] c0
  show "resultant f (pderiv f) \<noteq> 0" by auto
qed

lemma large_mod_0: assumes "(n :: int) > 1" "\<bar>k\<bar> < n" "k mod n = 0" shows "k = 0"
proof -
  from \<open>k mod n = 0\<close> have "n dvd k"
    by auto
  then obtain m where "k = n * m" ..
  with \<open>n > 1\<close> \<open>\<bar>k\<bar> < n\<close> show ?thesis
    by (auto simp add: abs_mult)
qed

definition separable_bound :: "int poly \<Rightarrow> int" where
  "separable_bound f = max (abs (resultant f (pderiv f)))
    (max (abs (lead_coeff f)) (abs (lead_coeff (pderiv f))))"

lemma square_free_int_imp_resultant_non_zero_mod_ring: assumes sf: "square_free f"
  and large: "int CARD('a) > separable_bound f"
  shows "resultant (map_poly of_int f :: 'a :: prime_card mod_ring poly) (pderiv (map_poly of_int f)) \<noteq> 0
  \<and> map_poly of_int f \<noteq> (0 :: 'a mod_ring poly)"
proof (intro conjI, rule notI)
  let ?i = "of_int :: int \<Rightarrow> 'a mod_ring"
  let ?m = "of_int_poly :: _ \<Rightarrow> 'a mod_ring poly"
  let ?f = "?m f"
  from sf[unfolded square_free_def] have f0: "f \<noteq> 0" by auto
  hence lf: "lead_coeff f \<noteq> 0" by auto
  {
    fix k :: int
    have C1: "int CARD('a) > 1" using prime_card[where 'a = 'a] by (auto simp: prime_nat_iff)
    assume "abs k < CARD('a)" and "?i k = 0"
    hence "k = 0" unfolding of_int_of_int_mod_ring
        by (transfer) (rule large_mod_0[OF C1])
  } note of_int_0 = this
  from square_free_imp_resultant_non_zero[OF sf]
  have non0: "resultant f (pderiv f) \<noteq> 0" .
  {
    fix g :: "int poly"
    assume abs: "abs (lead_coeff g) < CARD('a)"
    have "degree (?m g) = degree g" by (rule degree_map_poly, insert of_int_0[OF abs], auto)
  } note deg = this
  note large = large[unfolded separable_bound_def]
  from of_int_0[of "lead_coeff f"] large lf have "?i (lead_coeff f) \<noteq> 0" by auto
  thus f0: "?f \<noteq> 0" unfolding poly_eq_iff by auto
  assume 0: "resultant ?f (pderiv ?f) = 0"
  have "resultant ?f (pderiv ?f) = ?i (resultant f (pderiv f))"
    unfolding of_int_hom.map_poly_pderiv[symmetric]
    by (subst of_int_hom.resultant_map_poly(1)[OF deg deg], insert large, auto simp: hom_distribs)
  from of_int_0[OF _ this[symmetric, unfolded 0]] non0
  show False using large by auto
qed

lemma square_free_int_imp_separable_mod_ring: assumes sf: "square_free f"
  and large: "int CARD('a) > separable_bound f"
  shows "separable (map_poly of_int f :: 'a :: prime_card mod_ring poly)"
proof -
  define g where "g = map_poly (of_int :: int \<Rightarrow> 'a mod_ring) f"
  from square_free_int_imp_resultant_non_zero_mod_ring[OF sf large]
  have res: "resultant g (pderiv g) \<noteq> 0" and g: "g \<noteq> 0" unfolding g_def by auto
  from res[unfolded resultant_0_gcd] have "degree (gcd g (pderiv g)) = 0" by auto
  from degree0_coeffs[OF this]
  have "separable g" unfolding separable_def
    by (metis degree_pCons_0 g gcd_eq_0_iff is_unit_gcd is_unit_iff_degree)
  thus ?thesis unfolding g_def .
qed

lemma square_free_int_imp_square_free_mod_ring: assumes sf: "square_free f"
  and large: "int CARD('a) > separable_bound f"
shows "square_free (map_poly of_int f :: 'a :: prime_card mod_ring poly)"
  using separable_imp_square_free[OF square_free_int_imp_separable_mod_ring[OF assms]] .

end


(*  Title:      HOL/Nunchaku_Examples/Integer_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2012

Examples featuring Nunchaku applied to natural numbers and integers.
*)

section {* Examples Featuring Nunchaku Applied to Natural Numbers and Integers *}

theory Integer_Nuns
imports "../Nunchaku"
begin

nunchaku_params [verbose, timeout = 240]

lemma "Suc x = x + 1"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x < Suc x"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x + y \<ge> (x :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "y \<noteq> 0 \<Longrightarrow> x + y > (x :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x + y = y + (x :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x > y \<Longrightarrow> x - y \<noteq> (0 :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x \<le> y \<Longrightarrow> x - y = (0 :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x - (0 :: nat) = x"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<noteq> (0 :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "0 * y = (0 :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "y * 0 = (0 :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (x :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (y :: nat)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x * y div y = (x :: nat)"
nunchaku [expect = genuine]
oops

lemma "y \<noteq> 0 \<Longrightarrow> x * y div y = (x :: nat)"
nunchaku [expect = none]
sorry

lemma "5 * 55 < (260 :: nat)"
nunchaku [timeout = 5, expect = unknown] (* unfortunate *)
oops

lemma "nat (of_nat n) = n"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x + y \<ge> (x :: int)"
nunchaku [expect = genuine]
oops

lemma "\<lbrakk>x \<ge> 0; y \<ge> 0\<rbrakk> \<Longrightarrow> x + y \<ge> (0 :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "y \<ge> 0 \<Longrightarrow> x + y \<ge> (x :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x \<ge> 0 \<Longrightarrow> x + y \<ge> (y :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x \<ge> 0 \<Longrightarrow> x + y \<ge> (x :: int)"
nunchaku [expect = genuine]
oops

lemma "\<lbrakk>x \<le> 0; y \<le> 0\<rbrakk> \<Longrightarrow> x + y \<le> (0 :: int)"
nunchaku [expect = genuine]
sorry

lemma "y \<noteq> 0 \<Longrightarrow> x + y > (x :: int)"
nunchaku [expect = genuine]
oops

lemma "x + y = y + (x :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x > y \<Longrightarrow> x - y \<noteq> (0 :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "x \<le> y \<Longrightarrow> x - y = (0 :: int)"
nunchaku [expect = genuine]
oops

lemma "x - (0 :: int) = x"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<noteq> (0 :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "0 * y = (0 :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "y * 0 = (0 :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (x :: int)"
nunchaku [expect = genuine]
oops

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (y :: int)"
nunchaku [expect = genuine]
oops

lemma "x * y div y = (x :: int)"
nunchaku [expect = genuine]
oops

lemma "y \<noteq> 0 \<Longrightarrow> x * y div y = (x :: int)"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "(x * y < 0) \<longleftrightarrow> (x > 0 \<and> y < 0) \<or> (x < 0 \<and> y > (0 :: int))"
nunchaku [timeout = 5, expect = unknown]
sorry

lemma "-5 * 55 > (-260 :: int)"
nunchaku [timeout = 5, expect = unknown] (* unfortunate *)
oops

lemma "nat (of_nat n) = n"
nunchaku [timeout = 5, expect = unknown]
sorry

datatype tree =
  Null
| Node nat tree tree

primrec labels where
  "labels Null = {}" |
  "labels (Node x t u) = {x} \<union> labels t \<union> labels u"

lemma "labels (Node x t u) \<noteq> labels (Node y v w)"
nunchaku [expect = potential] (* unfortunate *)
oops

lemma "labels (Node x t u) \<noteq> {}"
nunchaku [expect = none]
oops

lemma "card (labels t) > 0"
nunchaku [expect = genuine]
oops

lemma "(\<Sum>n \<in> labels t. n + 2) \<ge> 2"
nunchaku [expect = genuine]
oops

lemma "t \<noteq> Null \<Longrightarrow> (\<Sum>n \<in> labels t. n + 2) \<ge> 2"
nunchaku [expect = genuine]
sorry

lemma "(\<Sum>i \<in> labels (Node x t u). f i :: nat) = f x + (\<Sum>i \<in> labels t. f i) + (\<Sum>i \<in> labels u. f i)"
nunchaku [expect = genuine]
oops

end


theory Buchi
imports NDTable
begin

section {* Non-deterministic Büchi automata *}

subsection {* Büchi automata and their languages *}

text {*
  Non-deterministic Büchi automata extend non-deterministic
  transition tables by an acceptance condition defined in
  terms of a set of accepting states. A run is accepting iff
  it passes infinitely often through some accepting state.

  This informal requirement can be interpreted in two different
  ways:
  \begin{enumerate}
  \item There should be some accepting state that appears
    infinitely often in a run for that run to be accepted.
  \item There should be infinitely many positions in the run
    that correspond to accepting states.
  \end{enumerate}
  These two interpretations agree for finite-state automata,
  but not necessarily for infinite-state ones. We formalize
  both interpretations and study their impact on the
  subsequent theory.
*}

record ('q,'a) ndbuchi = "('q,'a) ndtable" +
  accept :: "'q set"  -- "set of accepting states"

definition
  buchi_accepting :: "['q set, 'q word] \<Rightarrow> bool" where
  "buchi_accepting F run \<equiv> (limit run) \<inter> F \<noteq> {}"

definition
  buchi_accepting' :: "['q set, 'q word] \<Rightarrow> bool" where
  "buchi_accepting' F run \<equiv> \<exists>\<^sub>\<infinity>n. run n \<in> F"

lemma accepting_accepting' [elim]:
  assumes acc: "buchi_accepting F run"
  shows "buchi_accepting' F run"
proof -
  from acc obtain q where "q \<in> F" and  "\<exists>\<^sub>\<infinity>n. run n = q"
    by (auto simp add: buchi_accepting_def limit_def)
  thus ?thesis
    by (auto simp add: buchi_accepting'_def elim:INFM_mono)
qed

text {*
  The reverse implication is true under some finiteness condition;
  for example, if $F$ is finite or if the run contains only
  finitely many states. The following lemma states the precise condition.
*}

lemma accepting'_accepting [elim]:
  assumes acc': "buchi_accepting' F run" and fin: "finite (F \<inter> range run)"
  shows "buchi_accepting F run"
proof (rule ccontr)
  assume contr: "\<not>?thesis"
  hence "\<forall>q \<in> F. finite (run -` {q})"
    by (auto simp add: buchi_accepting_def limit_vimage)
  hence "\<forall>q \<in> F \<inter> range run. finite (run -` {q})"
    by blast
  with fin have "finite (\<Union>q \<in> F \<inter> range run. run -` {q})"
    by auto
  with acc' show "False"
    by (auto simp add: buchi_accepting'_def Inf_many_def vimage_def UNION_eq)
qed

text {*
  The language of a B\"uchi automaton is the set of words
  for which there exists some accepting run (under either
  interpretation).
*}

definition
  buchi_language where
  "buchi_language auto \<equiv>
   { inp . \<exists>run. nd_run auto inp run
               \<and> buchi_accepting (accept auto) run }"

definition
  buchi_language' where
  "buchi_language' auto \<equiv>
   { inp . \<exists>run. nd_run auto inp run
               \<and> buchi_accepting' (accept auto) run }"

lemma language_language':
  assumes "x \<in> buchi_language auto"
  shows "x \<in> buchi_language' auto"
using assms by (auto simp add: buchi_language_def buchi_language'_def)

lemma language'_language:
  assumes x: "x \<in> buchi_language' auto" and fin: "finite_state auto"
  shows "x \<in> buchi_language auto"
proof -
  from x obtain run where
    run: "nd_run auto x run" and acc: "buchi_accepting' (accept auto) run"
    by (auto simp add: buchi_language'_def)
  from fin run have "finite (range run)"
    by (rule finite_state_run)
  with acc have "buchi_accepting (accept auto) run"
    by auto
  with run show ?thesis
    by (auto simp add: buchi_language_def)
qed

lemma language'_language_bis:
  assumes x: "x \<in> buchi_language' auto" and fin: "finite (accept auto)"
  shows "x \<in> buchi_language auto"
proof -
  from x obtain run where
    run: "nd_run auto x run" and acc: "buchi_accepting' (accept auto) run"
    by (auto simp add: buchi_language'_def)
  from acc fin have "buchi_accepting (accept auto) run"
    by auto
  with run show ?thesis
    by (auto simp add: buchi_language_def)
qed

text {*
  The following theorem shows that the language of a Büchi
  automaton is non-empty if and only if there exist an initial state $q$
  and an accepting state $q'$ such that $q'$ is reachable from both $q$
  and (non-trivially) from itself. This result underlies the implementation
  of model checkers for linear-time temporal logic.
*}

lemma buchi_loop_nonempty:
  assumes ini: "q \<in> initial auto"
  and acc: "q' \<in> accept auto"
  and q: "q - auto \<rightarrow>\<^sup>* q'"
  and q': "q' - auto \<rightarrow>\<^sup>+ q'"
  shows "buchi_language auto \<noteq> {}"
proof -
  from q obtain w rw
    where rw: "nd_exec_fragment auto w rw"
    and rw0:  "rw!0 = q" and rwn: "rw ! length w = q'"
    by (blast dest: acc_star_exec)
  from q' obtain x rx
    where rx: "nd_exec_fragment auto x rx"
    and rx0: "rx!0 = q'" and rxn: "rx ! length x = q'"
    and lenx: "0 < length x"
    by (blast dest: acc_plus_exec)

  -- "abbreviations that make the following proof more readable"
  let ?rxm = "take (length x) rx"
  let ?loop = "?rxm\<^sup>\<omega>"
  let ?run = "rw \<frown> (suffix 1 ?loop)"

  from lenx rx have lenrxm: "0 < length ?rxm"
    by (simp add: nd_exec_fragment_length)

  -- "first goal: @{text ?run} is an execution"
  from rx rx0 rxn lenx have "nd_execution auto x\<^sup>\<omega> ?loop"
    by (auto elim: loop_execution)
  moreover
  from lenrxm rx0 have "?loop 0 = q'"
    by simp
  moreover note rw rwn
  ultimately
  have run_ex: "nd_execution auto (w \<frown> x\<^sup>\<omega>) ?run"
    by (fastsimp elim: exec_conc)

  -- "moreover, it is a run (starting in initial state)"
  from rw have "?run 0 = rw!0"
    by (simp add: nd_exec_fragment_length conc_fst)
  with rw0 ini have "?run 0 \<in> initial auto"
    by simp
  with run_ex have run: "nd_run auto (w \<frown> x\<^sup>\<omega>) ?run"
    by blast

  -- "finally, @{text ?run} is accepting"
  from lenrxm have "limit ?run = set ?rxm"
    by simp
  moreover
  from lenrxm lenx have "rx!0 = ?rxm!0"
    by auto
  with lenrxm have "rx!0 \<in> set ?rxm"
    by (simp only: nth_mem)
  moreover
  note rx0
  ultimately
  have "q' \<in> limit ?run"
    by simp
  with acc have "buchi_accepting (accept auto) ?run"
    by (auto simp add: buchi_accepting_def)

  with run show ?thesis
    by (auto simp add: buchi_language_def)
qed

lemma buchi_nonempty_loop:
  assumes nempty: "buchi_language auto \<noteq> {}"
  shows "\<exists>p q. p \<in> initial auto \<and> q \<in> accept auto
              \<and> p - auto \<rightarrow>\<^sup>* q \<and> q - auto \<rightarrow>\<^sup>+ q"
proof -
  from nempty obtain inp run
    where run: "nd_run auto inp run"
      and acc: "buchi_accepting (accept auto) run"
    by (auto simp add: buchi_language_def)
  from run have initial: "run 0 \<in> initial auto" ..
  from acc obtain q
    where q_lim: "q \<in> limit run" and q_acc: "q \<in> accept auto"
    by (auto simp add: buchi_accepting_def)

  -- "$q$ is in the limit: fix two occurrences of $q$ in $run$"
  from q_lim obtain i where i: "run i = q"
    by (auto simp add: limit_def INFM_nat)
  from q_lim obtain j where j: "i<j \<and> run j = q"
    by (auto simp add: limit_def INFM_nat)

  from run have reach1: "run 0 - auto \<rightarrow>\<^sup>* run i"
    by (auto intro: nd_execution_acc_star)
  from run j have reach2: "run i - auto \<rightarrow>\<^sup>+ run j"
    by (auto intro: nd_execution_acc_plus)

  from initial q_acc i j reach1 reach2
  show ?thesis by auto
qed

theorem buchi_nonempty_iff_loop:
  "(buchi_language auto \<noteq> {}) =
   (\<exists>p q. p \<in> initial auto \<and> q \<in> accept auto
          \<and> p - auto \<rightarrow>\<^sup>* q \<and> q - auto \<rightarrow>\<^sup>+ q)"
  (is "?lhs = ?rhs")
proof
  assume ?lhs thus ?rhs
    by (rule buchi_nonempty_loop)
next
  assume ?rhs thus ?lhs
    by (blast intro: buchi_loop_nonempty del: notI)
qed

text {*
  For the alternative definition of Büchi acceptance, the analogous
  theorem is true only for finite-state automata.
*}

theorem buchi'_nonempty_iff_loop:
  assumes fin: "finite_state auto"
  shows "(buchi_language' auto \<noteq> {}) =
   (\<exists>p q. p \<in> initial auto \<and> q \<in> accept auto
          \<and> p - auto \<rightarrow>\<^sup>* q \<and> q - auto \<rightarrow>\<^sup>+ q)"
  (is "?lhs = ?rhs")
proof -
  from fin have "buchi_language' auto = buchi_language auto"
    by (auto elim: language_language' language'_language)
  thus ?thesis
    by (simp add: buchi_nonempty_iff_loop)
qed

subsection {* Union of Büchi automata *}

text {*
  The class of languages definable by Büchi automata is closed
  under set operations. Here we cover the case of set union;
  intersection and complement are harder and will be proven in
  separate theories. The idea is to take the (disjoint)
  union of the two automata to obtain an automaton accepting the
  union of two languages.
*}

definition
  buchi_union where
  "buchi_union auta autb \<equiv>
   \<lparr> initial = initial auta <+> initial autb,
     trans = \<lambda> src a. case src of Inl x \<Rightarrow> Inl ` (trans auta x a)
                                | Inr y \<Rightarrow> Inr ` (trans autb y a),
     accept = accept auta <+> accept autb
   \<rparr>"

lemma buchi_union_states_of:
  "states_of (buchi_union auta autb) = (states_of auta) <+> (states_of autb)"
  (is "?lhs = ?rhs")
proof -
  let ?un = "buchi_union auta autb"
  have init: "initial ?un = (initial auta) <+> (initial autb)"
    by (simp add: buchi_union_def)
  have "(\<Union> qr a. trans ?un qr a) =
        (\<Union>q a. trans ?un (Inl q) a) \<union> (\<Union>r a. trans ?un (Inr r) a)"
    by (simp add: Union_sum)
  also have "\<dots> = (\<Union>q a. Inl ` (trans auta q a)) \<union> (\<Union>r a. Inr ` (trans autb r a))"
    by (simp add: buchi_union_def)
  finally show ?thesis
    by (auto simp add: init states_of_def image_def)
qed

text {*
  To prove the correctness of this construction, we first show that
  any run of one of the component automata can be lifted to a
  run of the union. Second, we'll show that any run of the union
  is in fact of this form.
*}

lemma buchi_union_lift_left:
  assumes run: "nd_execution auta inp run"
  shows "nd_execution (buchi_union auta autb) inp (Inl \<circ> run)"
proof (rule, simp)
  fix n
  from run
  have "run (Suc n) \<in> trans auta (run n) (inp n)" ..
  thus "Inl (run (Suc n))
        \<in> trans (buchi_union auta autb) (Inl (run n)) (inp n)"
    by (simp add: buchi_union_def)
qed

lemma buchi_union_lift_right:
  assumes run: "nd_execution autb inp run"
  shows "nd_execution (buchi_union auta autb) inp (Inr \<circ> run)"
proof (rule, simp)
  fix n
  from run
  have "run (Suc n) \<in> trans autb (run n) (inp n)" ..
  thus "Inr (run (Suc n))
        \<in> trans (buchi_union auta autb) (Inr (run n)) (inp n)"
    by (simp add: buchi_union_def)
qed

lemma buchi_union_run_left:
  assumes run: "nd_execution (buchi_union auta autb) inp run"
  and start: "run 0 \<in> range Inl"
  shows "\<exists>runa. nd_execution auta inp runa \<and> run = Inl \<circ> runa"
proof -
  let ?ra = "\<lambda>n. THE q. run n = Inl q"
  have inl: "\<forall>n. run n = Inl (?ra n)"
  proof
    fix n
    show "run n = Inl (?ra n)"
    proof (induct n)
      from start show "run 0 = Inl (?ra 0)" by auto
    next
      fix m
      assume ih: "run m = Inl (?ra m)"
      from run
      have "run (Suc m) \<in> trans (buchi_union auta autb) (run m) (inp m)" ..
      with ih show "run (Suc m) = Inl (?ra (Suc m))"
	by (auto simp add: buchi_union_def split add: sum.splits)
    qed
  qed
  moreover
  have "\<forall>n. ?ra (Suc n) \<in> trans auta (?ra n) (inp n)"
  proof
    fix n
    from run
    have "run (Suc n) \<in> trans (buchi_union auta autb) (run n) (inp n)" ..
    also from inl obtain x where "run n = Inl x" by blast
    hence "run n \<notin> range Inr" by auto
    ultimately show "?ra (Suc n) \<in> trans auta (?ra n) (inp n)"
      by (auto simp add: buchi_union_def split add: sum.splits)
  qed
  ultimately have "nd_execution auta inp ?ra \<and> run = Inl \<circ> ?ra"
    by (auto intro: ext)
  thus ?thesis by blast
qed

lemma buchi_union_run_right:
  assumes run: "nd_execution (buchi_union auta autb) inp run"
  and start: "run 0 \<in> range Inr"
  shows "\<exists>runb. nd_execution autb inp runb \<and> run = Inr \<circ> runb"
proof -
  let ?rb = "\<lambda>n. THE q. run n = Inr q"
  have inl: "\<forall>n. run n = Inr (?rb n)"
  proof
    fix n
    show "run n = Inr (?rb n)"
    proof (induct n)
      from start show "run 0 = Inr (?rb 0)" by auto
    next
      fix m
      assume ih: "run m = Inr (?rb m)"
      from run
      have "run (Suc m) \<in> trans (buchi_union auta autb) (run m) (inp m)" ..
      with ih show "run (Suc m) = Inr (?rb (Suc m))"
	by (auto simp add: buchi_union_def split add: sum.splits)
    qed
  qed
  moreover
  have "\<forall>n. ?rb (Suc n) \<in> trans autb (?rb n) (inp n)"
  proof
    fix n
    from run
    have "run (Suc n) \<in> trans (buchi_union auta autb) (run n) (inp n)" ..
    also from inl obtain x where "run n = Inr x" by blast
    hence "run n \<notin> range Inl" by auto
    ultimately show "?rb (Suc n) \<in> trans autb (?rb n) (inp n)"
      by (auto simp add: buchi_union_def split add: sum.splits)
  qed
  ultimately have "nd_execution autb inp ?rb \<and> run = Inr \<circ> ?rb"
    by (auto intro: ext)
  thus ?thesis by blast
qed

text {*
  Moreover, the acceptance conditions are transferred appropriately.
  (Because of the above lemmas, it is enough to show this for
  ``lifted'' runs.)
*}

lemma buchi_union_accept_left:
  "buchi_accepting (accept (buchi_union auta autb)) (Inl \<circ> run)
   = buchi_accepting (accept auta) run"
by (auto simp add: inj_Inl buchi_accepting_def buchi_union_def)

lemma buchi_union_accept_right:
  "buchi_accepting (accept (buchi_union auta autb)) (Inr \<circ> run)
   = buchi_accepting (accept autb) run"
by (auto simp add: inj_Inr buchi_accepting_def buchi_union_def)

lemma buchi_union_accept'_left:
  "buchi_accepting' (accept (buchi_union auta autb)) (Inl \<circ> run)
   = buchi_accepting' (accept auta) run"
by (auto simp add: inj_Inl buchi_accepting'_def buchi_union_def
         elim: INFM_mono)

lemma buchi_union_accept'_right:
  "buchi_accepting' (accept (buchi_union auta autb)) (Inr \<circ> run)
   = buchi_accepting' (accept autb) run"
by (auto simp add: inj_Inr buchi_accepting'_def buchi_union_def
         elim: INFM_mono)

text {*
  The correctness of the construction of the union automaton
  follows, under either acceptance condition.
*}

theorem buchi_union:
  "buchi_language (buchi_union auta autb)
   = (buchi_language auta) \<union> (buchi_language autb)"
  (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
  proof
    fix inp
    assume "inp \<in> ?lhs"
    then obtain run
      where run: "nd_run (buchi_union auta autb) inp run
                  \<and> buchi_accepting (accept (buchi_union auta autb)) run"
      by (auto simp add: buchi_language_def)
    from run have "run 0 \<in> (initial auta <+> initial autb)"
      by (simp add: nd_run_def buchi_union_def)
    hence "run 0 \<in> Inl ` (initial auta) \<or> run 0 \<in> Inr ` (initial autb)"
      by auto
    thus "inp \<in> ?rhs"
    proof
      assume start: "run 0 \<in> Inl ` (initial auta)"
      with run obtain runa
	where runa: "nd_execution auta inp runa \<and> run = Inl \<circ> runa"
	by (fastsimp intro: buchi_union_run_left simp add: nd_run_def)
      with start have aini: "runa 0 \<in> initial auta" by auto
      from run runa have "buchi_accepting (accept auta) runa"
	by (simp add: buchi_union_accept_left)
      with runa aini
      have "inp \<in> buchi_language auta"
	by (auto simp add: buchi_language_def nd_run_def)
      thus ?thesis ..
    next
      assume start: "run 0 \<in> Inr ` (initial autb)"
      with run obtain runb
	where runb: "nd_execution autb inp runb \<and> run = Inr \<circ> runb"
	by (fastsimp intro: buchi_union_run_right simp add: nd_run_def)
      with start have bini: "runb 0 \<in> initial autb" by auto
      from run runb have "buchi_accepting (accept autb) runb"
	by (simp add: buchi_union_accept_right)
      with runb bini
      have "inp \<in> buchi_language autb"
	by (auto simp add: buchi_language_def nd_run_def)
      thus ?thesis ..
    qed
  qed
next
  show "?rhs \<subseteq> ?lhs"
  proof
    fix inp assume "inp \<in> ?rhs"
    thus "inp \<in> ?lhs"
    proof
      assume "inp \<in> buchi_language auta"
      then obtain run
	where run: "nd_run auta inp run \<and> buchi_accepting (accept auta) run"
	by (auto simp add: buchi_language_def)
      from run have "run 0 \<in> initial auta"
	by (simp add: nd_run_def)
      hence "Inl (run 0) \<in> initial (buchi_union auta autb)"
	by (auto simp add: buchi_union_def)
      with run
      have exec: "nd_run (buchi_union auta autb) inp (Inl \<circ> run)"
	by (simp add: nd_run_def buchi_union_lift_left)
      moreover from run
      have "buchi_accepting (accept (buchi_union auta autb)) (Inl \<circ> run)"
	by (simp add: buchi_union_accept_left)
      ultimately show "inp \<in> ?lhs"
	by (auto simp add: buchi_language_def)
    next
      assume "inp \<in> buchi_language autb"
      then obtain run
	where run: "nd_run autb inp run \<and> buchi_accepting (accept autb) run"
	by (auto simp add: buchi_language_def)
      from run have "run 0 \<in> initial autb"
	by (simp add: nd_run_def)
      hence "Inr (run 0) \<in> initial (buchi_union auta autb)"
	by (auto simp add: buchi_union_def)
      with run
      have exec: "nd_run (buchi_union auta autb) inp (Inr \<circ> run)"
	by (simp add: nd_run_def buchi_union_lift_right)
      moreover from run
      have "buchi_accepting (accept (buchi_union auta autb)) (Inr \<circ> run)"
	by (simp add: buchi_union_accept_right)
      ultimately show "inp \<in> ?lhs"
	by (auto simp add: buchi_language_def)
    qed
  qed
qed

theorem buchi_union':
  "buchi_language' (buchi_union auta autb)
   = (buchi_language' auta) \<union> (buchi_language' autb)"
  (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
  proof
    fix inp
    assume "inp \<in> ?lhs"
    then obtain run
      where run: "nd_run (buchi_union auta autb) inp run"
        and acc: "buchi_accepting' (accept (buchi_union auta autb)) run"
      by (auto simp add: buchi_language'_def)
    from run have "run 0 \<in> (initial auta <+> initial autb)"
      by (simp add: nd_run_def buchi_union_def)
    hence "run 0 \<in> Inl ` (initial auta) \<or> run 0 \<in> Inr ` (initial autb)"
      by auto
    thus "inp \<in> ?rhs"
    proof
      assume start: "run 0 \<in> Inl ` (initial auta)"
      with run obtain runa
	where runa: "nd_execution auta inp runa \<and> run = Inl \<circ> runa"
	by (fastsimp intro: buchi_union_run_left simp add: nd_run_def)
      with start have aini: "runa 0 \<in> initial auta" by auto
      from runa acc have "buchi_accepting' (accept auta) runa"
	by (simp add: buchi_union_accept'_left)
      with runa aini
      have "inp \<in> buchi_language' auta"
	by (auto simp add: buchi_language'_def nd_run_def)
      thus ?thesis ..
    next
      assume start: "run 0 \<in> Inr ` (initial autb)"
      with run obtain runb
	where runb: "nd_execution autb inp runb \<and> run = Inr \<circ> runb"
	by (fastsimp intro: buchi_union_run_right simp add: nd_run_def)
      with start have bini: "runb 0 \<in> initial autb" by auto
      from runb acc have "buchi_accepting' (accept autb) runb"
	by (simp add: buchi_union_accept'_right)
      with runb bini
      have "inp \<in> buchi_language' autb"
	by (auto simp add: buchi_language'_def nd_run_def)
      thus ?thesis ..
    qed
  qed
next
  show "?rhs \<subseteq> ?lhs"
  proof
    fix inp assume "inp \<in> ?rhs"
    thus "inp \<in> ?lhs"
    proof
      assume "inp \<in> buchi_language' auta"
      then obtain run
	where run: "nd_run auta inp run" and acc:"buchi_accepting' (accept auta) run"
	by (auto simp add: buchi_language'_def)
      from run have "run 0 \<in> initial auta"
	by (simp add: nd_run_def)
      hence "Inl (run 0) \<in> initial (buchi_union auta autb)"
	by (auto simp add: buchi_union_def)
      with run have exec: "nd_run (buchi_union auta autb) inp (Inl \<circ> run)"
	by (simp add: nd_run_def buchi_union_lift_left)
      moreover from acc
      have "buchi_accepting' (accept (buchi_union auta autb)) (Inl \<circ> run)"
	by (simp add: buchi_union_accept'_left)
      ultimately show "inp \<in> ?lhs"
	by (auto simp add: buchi_language'_def)
    next
      assume "inp \<in> buchi_language' autb"
      then obtain run
	where run: "nd_run autb inp run" and acc:"buchi_accepting' (accept autb) run"
	by (auto simp add: buchi_language'_def)
      from run have "run 0 \<in> initial autb"
	by (simp add: nd_run_def)
      hence "Inr (run 0) \<in> initial (buchi_union auta autb)"
	by (auto simp add: buchi_union_def)
      with run have exec: "nd_run (buchi_union auta autb) inp (Inr \<circ> run)"
	by (simp add: nd_run_def buchi_union_lift_right)
      moreover from acc
      have "buchi_accepting' (accept (buchi_union auta autb)) (Inr \<circ> run)"
	by (simp add: buchi_union_accept'_right)
      ultimately show "inp \<in> ?lhs"
	by (auto simp add: buchi_language'_def)
    qed
  qed
qed

text {*
  The run dag of the union automaton is obtained as the ``disjoint
  union'' of the corresponding run dags of the component automata.
*}

lemma buchi_union_run_dag:
  "run_dag (buchi_union auta autb) inp =
   \<lparr> roots = (roots (run_dag auta inp)) <+> (roots (run_dag autb inp)),
     succs = \<lambda>(q,l). case q of Inl x \<Rightarrow> Inl ` (succs (run_dag auta inp) (x,l))
                             | Inr y \<Rightarrow> Inr ` (succs (run_dag autb inp) (y,l))
  \<rparr>"
by (auto simp add: buchi_union_def run_dag_def cong del: sum.weak_case_cong)

lemma reachable_left_then_union:
  assumes hyp: "pos' \<in> reachable (run_dag auta inp) pos"
  shows "(Inl (fst pos'), snd pos') \<in>
         reachable (run_dag (buchi_union auta autb) inp) (Inl (fst pos), snd pos)"
    (is "?rch pos pos'")
using hyp proof induct
  show "?rch pos pos" ..
next
  fix nd pos''
  assume pos'': "?rch pos pos''"
    and nd: "nd \<in> succs (run_dag auta inp) pos''"
  from nd have "Inl nd \<in> succs (run_dag (buchi_union auta autb) inp) (Inl(fst pos''), snd pos'')"
    by (auto simp add: buchi_union_run_dag)
  with pos'' show "?rch pos (nd, Suc(snd pos''))"
    by auto
qed

lemma reachable_left_then_union':
  assumes hyp: "(q',l') \<in> reachable (run_dag auta inp) (q,l)"
  shows "(Inl q', l') \<in> reachable (run_dag (buchi_union auta autb) inp) (Inl q, l)"
proof -
  from reachable_left_then_union[OF hyp] show ?thesis by auto
qed

lemma reachable_right_then_union:
  assumes hyp: "pos' \<in> reachable (run_dag autb inp) pos"
  shows "(Inr (fst pos'), snd pos') \<in>
         reachable (run_dag (buchi_union auta autb) inp) (Inr (fst pos), snd pos)"
    (is "?rch pos pos'")
using hyp proof induct
  show "?rch pos pos" ..
next
  fix nd pos''
  assume pos'': "?rch pos pos''"
    and nd: "nd \<in> succs (run_dag autb inp) pos''"
  from nd have "Inr nd \<in> succs (run_dag (buchi_union auta autb) inp) (Inr(fst pos''), snd pos'')"
    by (auto simp add: buchi_union_run_dag)
  with pos'' show "?rch pos (nd, Suc(snd pos''))"
    by auto
qed

lemma reachable_right_then_union':
  assumes hyp: "(q',l') \<in> reachable (run_dag autb inp) (q,l)"
  shows "(Inr q', l') \<in> reachable (run_dag (buchi_union auta autb) inp) (Inr q, l)"
proof -
  from reachable_right_then_union[OF hyp] show ?thesis by auto
qed

lemma reachable_union_then_left:
  assumes hyp: "pos' \<in> reachable (run_dag (buchi_union auta autb) inp) (Inl q, l)"
  shows "\<exists>q' l'. pos' = (Inl q', l') \<and> (q',l') \<in> reachable (run_dag auta inp) (q,l)"
    (is "\<exists>q' l'. ?rch pos' q' l'")
using hyp proof induct
  have "?rch (Inl q, l) q l" by simp
  thus "\<exists>q' l'. ?rch (Inl q, l) q' l'" by blast
next
  fix nd pos''
  assume pos'': "\<exists>q'' l''. ?rch pos'' q'' l''"
    and nd: "nd \<in> succs (run_dag (buchi_union auta autb) inp) pos''"
  from pos'' obtain q'' l'' where q'': "?rch pos'' q'' l''" by blast
  with pos'' nd obtain q' where "nd = Inl q' \<and> q' \<in> succs (run_dag auta inp) (q'',l'')"
    by (auto simp add: buchi_union_run_dag)
  with q'' have "?rch (nd, Suc(snd pos'')) q' (Suc l'')" by auto
  thus "\<exists>q' l'. ?rch (nd, Suc(snd pos'')) q' l'" by blast
qed

lemma reachable_union_then_right:
  assumes hyp: "pos' \<in> reachable (run_dag (buchi_union auta autb) inp) (Inr q, l)"
  shows "\<exists>q' l'. pos' = (Inr q', l') \<and> (q',l') \<in> reachable (run_dag autb inp) (q,l)"
    (is "\<exists>q' l'. ?rch pos' q' l'")
using hyp proof induct
  have "?rch (Inr q, l) q l" by simp
  thus "\<exists>q' l'. ?rch (Inr q, l) q' l'" by blast
next
  fix nd pos''
  assume pos'': "\<exists>q'' l''. ?rch pos'' q'' l''"
    and nd: "nd \<in> succs (run_dag (buchi_union auta autb) inp) pos''"
  from pos'' obtain q'' l'' where q'': "?rch pos'' q'' l''" by blast
  with pos'' nd obtain q' where "nd = Inr q' \<and> q' \<in> succs (run_dag autb inp) (q'',l'')"
    by (auto simp add: buchi_union_run_dag)
  with q'' have "?rch (nd, Suc(snd pos'')) q' (Suc l'')" by auto
  thus "\<exists>q' l'. ?rch (nd, Suc(snd pos'')) q' l'" by blast
qed

lemma reachable_union_left:
  "reachable (run_dag (buchi_union auta autb) inp) (Inl q, l)
   = {(Inl q', l') | q' l' . (q',l') \<in> reachable (run_dag auta inp) (q,l)}"
by (auto dest: reachable_left_then_union reachable_union_then_left)

lemma reachable_union_right:
  "reachable (run_dag (buchi_union auta autb) inp) (Inr q, l)
   = {(Inr q', l') | q' l' . (q',l') \<in> reachable (run_dag autb inp) (q,l)}"
by (auto dest: reachable_right_then_union reachable_union_then_right)

theorem rch_positions_union:
  "rch_positions (run_dag (buchi_union auta autb) inp) =
   {(Inl q', l') | q' l' . (q',l') \<in> rch_positions (run_dag auta inp)} \<union>
   {(Inr q', l') | q' l' . (q',l') \<in> rch_positions (run_dag autb inp)}"
  (is "?lhs = ?left \<union> ?right")
proof -
  let ?undg = "run_dag (buchi_union auta autb) inp"
  let ?ldg = "run_dag auta inp"
  let ?rdg = "run_dag autb inp"
  have sub: "?lhs \<subseteq> ?left \<union> ?right"
  proof
    fix pos
    assume pos: "pos \<in> rch_positions ?undg"
    then obtain rt
      where rt: "rt \<in> roots ?undg" and rtpos: "pos \<in> reachable ?undg (rt,0)"
      by (auto simp add: rch_positions_def reachables_def)
    from rt have "rt \<in> roots ?ldg <+> roots ?rdg"
      by (auto simp add: buchi_union_run_dag)
    thus "pos \<in> ?left \<union> ?right"
    proof -- {* case distinction on ``left'' or ``right'' root *}
      fix lrt
      assume lrt: "lrt \<in> roots ?ldg"
	and rt: "rt = Inl lrt"
      from rt rtpos obtain q l
	where "pos = (Inl q, l)" and "(q,l) \<in> reachable ?ldg (lrt, 0)"
	by (blast dest: reachable_union_then_left)
      with lrt show ?thesis
	by (auto simp add: rch_positions_def reachables_def)
    next
      fix rrt
      assume rrt: "rrt \<in> roots ?rdg"
	and rt: "rt = Inr rrt"
      from rt rtpos obtain q l
	where "pos = (Inr q, l)" and "(q,l) \<in> reachable ?rdg (rrt, 0)"
	by (blast dest: reachable_union_then_right)
      with rrt show ?thesis
	by (auto simp add: rch_positions_def reachables_def)
    qed
  qed
  have sup1: "?left \<subseteq> ?lhs"
  proof clarsimp
    fix q l
    assume q: "(q,l) \<in> rch_positions ?ldg"
    then obtain rt where
      rt: "rt \<in> roots ?ldg" and rch: "(q,l) \<in> reachable ?ldg (rt,0)"
      by (auto simp add: rch_positions_def reachables_def)
    from rt have "Inl rt \<in> roots ?undg"
      by (auto simp add: buchi_union_run_dag)
    moreover
    from rch have "(Inl q, l) \<in> reachable ?undg (Inl rt, 0)"
      by (rule reachable_left_then_union')
    ultimately show "(Inl q, l) \<in> rch_positions ?undg"
      by (auto simp add: rch_positions_def reachables_def)
  qed
  have sup2: "?right \<subseteq> ?lhs"
  proof clarsimp
    fix q l
    assume q: "(q,l) \<in> rch_positions ?rdg"
    then obtain rt where
      rt: "rt \<in> roots ?rdg" and rch: "(q,l) \<in> reachable ?rdg (rt,0)"
      by (auto simp add: rch_positions_def reachables_def)
    from rt have "Inr rt \<in> roots ?undg"
      by (auto simp add: buchi_union_run_dag)
    moreover
    from rch have "(Inr q, l) \<in> reachable ?undg (Inr rt, 0)"
      by (rule reachable_right_then_union')
    ultimately show "(Inr q, l) \<in> rch_positions ?undg"
      by (auto simp add: rch_positions_def reachables_def)
  qed
  from sub sup1 sup2 show ?thesis by blast
qed

corollary slice_union:
  "slice (run_dag (buchi_union auta autb) inp) lvl =
   slice (run_dag auta inp) lvl <+> slice (run_dag autb inp) lvl"
by (auto simp add: slice_def rch_positions_union)

text {*
  The union of two finite-state Büchi automata is again finite-state.
*}

theorem buchi_union_finite_state:
  assumes fina: "finite_state auta" and finb: "finite_state autb"
  shows "finite_state (buchi_union auta autb)"
using assms by (auto simp add: finite_state_def buchi_union_states_of finite_Plus)

(**** proof for old definition of finiteness
proof (auto simp add: finite_state_def)
  fix inp
  from fina have "finite (fst ` rch_positions (run_dag auta inp))"
    by (simp add: finite_state_def)
  hence "finite (Inl ` (fst ` rch_positions (run_dag auta inp)))"
    by (rule finite_imageI)
  moreover
  have "(fst ` {(Inl q,l) | q l . (q,l) \<in> rch_positions (run_dag auta inp)})
        \<subseteq> Inl ` (fst ` rch_positions (run_dag auta inp))"
    by (auto simp add: image_def)
  ultimately
  have lt: "finite (fst ` {(Inl q,l) | q l . (q,l) \<in> rch_positions (run_dag auta inp)})"
    by (auto elim: finite_subset)

  from finb have "finite (fst ` rch_positions (run_dag autb inp))"
    by (simp add: finite_state_def)
  hence "finite (Inr ` (fst ` rch_positions (run_dag autb inp)))"
    by (rule finite_imageI)
  moreover
  have "(fst ` {(Inr q,l) | q l . (q,l) \<in> rch_positions (run_dag autb inp)})
        \<subseteq> Inr ` (fst ` rch_positions (run_dag autb inp))"
    by (auto simp add: image_def)
  ultimately
  have rt: "finite (fst ` {(Inr q,l) | q l . (q,l) \<in> rch_positions (run_dag autb inp)})"
    by (auto elim: finite_subset)

  from lt rt show "finite (fst ` rch_positions (run_dag (buchi_union auta autb) inp))"
    by (auto simp add: rch_positions_union image_Un)
qed
****)

theorem buchi_union_bounded_nondet:
  assumes fina: "bounded_nondet auta m" and finb: "bounded_nondet autb n"
  shows "bounded_nondet (buchi_union auta autb) (m+n)"
proof (clarsimp simp add: bounded_nondet_def)
  fix inp lvl
  let ?slice = "slice (run_dag (buchi_union auta autb) inp) lvl"
  let ?sla = "slice (run_dag auta inp) lvl"
  let ?slb = "slice (run_dag autb inp) lvl"
  from fina have sla: "finite ?sla"
    by (simp add: bounded_nondet_def)
  from finb have slb: "finite ?slb"
    by (simp add: bounded_nondet_def)
  from fina have carda: "card ?sla \<le> m"
    by (simp add: bounded_nondet_def)
  from finb have cardb: "card ?slb \<le> n"
    by (simp add: bounded_nondet_def)
  have "card ?slice = card (?sla <+> ?slb)"
    by (simp add: slice_union)
  also from sla slb have "\<dots> = (card ?sla) + (card ?slb)"
    by (rule card_Plus)
  also from carda cardb have "\<dots> \<le> m + n"
    by auto
  finally show "finite ?slice \<and> card ?slice \<le> m+n"
    by (auto simp add: sla slb slice_union finite_Plus)
qed

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Monotone Operators\<close>
theory Monotone_Operators
  imports
    Fixpoints_Base
    HOTG.Universes
    Sets
begin

definition monotone :: "set \<Rightarrow> (set \<Rightarrow> set) \<Rightarrow> bool"
  where "monotone D h \<equiv> (\<forall>W X. W \<subseteq> X \<longrightarrow> X \<subseteq> D \<longrightarrow> h W \<subseteq> h X)"

lemma monotone_type [type]: "monotone : (D: Set) \<Rightarrow> (Subset D \<Rightarrow> Subset D) \<Rightarrow> Bool"
  by unfold_types

lemma monotoneI [intro!]:
  assumes "\<And>W X. \<lbrakk>W \<subseteq> X; X \<subseteq> D\<rbrakk> \<Longrightarrow> h W \<subseteq> h X"
  shows "monotone D h"
  unfolding monotone_def using assms by blast

abbreviation "Monop D \<equiv> monotone D \<sqdot> (Subset D \<Rightarrow> Subset D)"

lemma MonopI:
  assumes closed_on_D: "\<And>x. x \<subseteq> D \<Longrightarrow> h x \<subseteq> D"
  and monotone_D: "monotone D h"
  shows "h : Monop D"
  by (unfold_types) (insert monotone_D, auto intro!: closed_on_D)

lemma Monop_app_subset_app_if_subset:
  "\<lbrakk>h : Monop D; X \<subseteq> D; W \<subseteq> X\<rbrakk> \<Longrightarrow> h W \<subseteq> h X"
  unfolding monotone_def by unfold_types

lemma Monop_prefixpoint: "h : Monop D \<Longrightarrow> prefixpoint D h"
  unfolding prefixpoint_def by auto

lemma Monop_app_Subset_if_Subset [derive]:
  "h : Monop D \<Longrightarrow> X : Subset D \<Longrightarrow> h X : Subset D"
  by unfold_types

subsubsection \<open>Instances\<close>

lemma id_Monop [derive]: "(\<lambda>x. x) : Monop D"
  unfolding monotone_def by unfold_types auto

lemma K_MonopI [derive]: "x : Subset D \<Longrightarrow> (\<lambda>_. x) : Monop D"
  unfolding monotone_def by unfold_types auto

lemma bin_union_Monop_app_subset_app_bin_union:
  assumes "h : Monop D" "A \<subseteq> D" "B \<subseteq> D"
  shows "h A \<union> h B \<subseteq> h (A \<union> B)"
proof -
  have "h A \<subseteq> h (A \<union> B)"
    by (rule Monop_app_subset_app_if_subset) (insert assms, auto)
  moreover have "h B \<subseteq> h (A \<union> B)"
    by (rule Monop_app_subset_app_if_subset) (insert assms, auto)
  ultimately show ?thesis by auto
qed

lemma bin_union_MonopI [derive]:
  assumes "f : Monop D" "g : Monop D"
  shows "(\<lambda>x. f x \<union> g x) : Monop D" (is "?h : Monop D")
proof (rule MonopI)
  fix X assume "X \<subseteq> D"
  with assms show "f X \<union> g X \<subseteq> D"
    by (auto intro!: Monop_prefixpoint[unfolded prefixpoint_def])
next
  show "monotone D ?h"
  proof (rule monotoneI)
    fix W X assume "W \<subseteq> X" "X \<subseteq> D"
    have "f W \<subseteq> f X" by (rule Monop_app_subset_app_if_subset) auto
    moreover have "g W \<subseteq> g X" by (rule Monop_app_subset_app_if_subset) auto
    ultimately show "f W \<union> g W \<subseteq> f X \<union> g X" by auto
  qed
qed

lemma replacement_MonopI:
  assumes "f : Monop D"
  and "\<And>X. X : Subset D \<Longrightarrow> g : Element (f X) \<Rightarrow> Element D"
  shows "(\<lambda>x. {g y | y \<in> f x}) : Monop D" (is "?h : Monop D")
proof (rule MonopI)
  fix X assume "X \<subseteq> D"
  with assms show "{g y | y \<in> f X} \<subseteq> D"
    (*TODO unfold_type directly loops*)
    by (unfold Element_def) (unfold_types, auto)
next
  show "monotone D ?h"
  proof (rule monotoneI)
    fix W X assume "W \<subseteq> X" "X \<subseteq> D"
    have "f W \<subseteq> f X" by (rule Monop_app_subset_app_if_subset) auto
    then show "{g y | y \<in> f W} \<subseteq> {g y | y \<in> f X}"
      by (rule repl_subset_repl_if_subset_dom)
  qed
qed

lemma pairs_MonopI [derive]:
  assumes "A : Monop (univ X)" "B : Monop (univ X)"
  shows "(\<lambda>x. A x \<times> B x) : Monop (univ X)" (is "?h : Monop ?D")
proof (rule MonopI)
  fix X assume "X \<subseteq> ?D"
  with subset_univ_if_subset_univ_pairs show "A X \<times> B X \<subseteq> ?D" by auto
next
  show "monotone ?D ?h"
  proof (rule monotoneI)
    fix W X assume "W \<subseteq> X" "X \<subseteq> ?D"
    have "A W \<subseteq> A X" by (rule Monop_app_subset_app_if_subset) auto
    moreover have "B W \<subseteq> B X" by (rule Monop_app_subset_app_if_subset) auto
    ultimately show "A W \<times> B W \<subseteq> A X \<times> B X" by auto
  qed
qed

end


section \<open>Positional Strategies\<close>

theory Strategy
imports
  Main
  ParityGame
begin

subsection \<open>Definitions\<close>

text \<open>
  A \emph{strategy} is simply a function from nodes to nodes
  We only consider positional strategies.
\<close>
type_synonym 'a Strategy = "'a \<Rightarrow> 'a"

text \<open>
  A \emph{valid} strategy for player @{term p} is a function assigning a successor to each node
  in @{term "VV p"}.\<close>
definition (in ParityGame) strategy :: "Player \<Rightarrow> 'a Strategy \<Rightarrow> bool" where
  "strategy p \<sigma> \<equiv> \<forall>v \<in> VV p. \<not>deadend v \<longrightarrow> v\<rightarrow>\<sigma> v"

lemma (in ParityGame) strategyI [intro]:
  "(\<And>v. \<lbrakk> v \<in> VV p; \<not>deadend v \<rbrakk> \<Longrightarrow> v\<rightarrow>\<sigma> v) \<Longrightarrow> strategy p \<sigma>"
  unfolding strategy_def by blast

subsection \<open>Strategy-Conforming Paths\<close>

text \<open>
  If @{term "path_conforms_with_strategy p P \<sigma>"} holds, then we call @{term P} a
  \emph{@{term \<sigma>}-path}.
  This means that @{term P} follows @{term \<sigma>} on all nodes of player @{term p}
  except maybe the last node on the path.
\<close>
coinductive (in ParityGame) path_conforms_with_strategy
  :: "Player \<Rightarrow> 'a Path \<Rightarrow> 'a Strategy \<Rightarrow> bool" where
  path_conforms_LNil:  "path_conforms_with_strategy p LNil \<sigma>"
| path_conforms_LCons_LNil: "path_conforms_with_strategy p (LCons v LNil) \<sigma>"
| path_conforms_VVp: "\<lbrakk> v \<in> VV p; w = \<sigma> v; path_conforms_with_strategy p (LCons w Ps) \<sigma> \<rbrakk>
    \<Longrightarrow> path_conforms_with_strategy p (LCons v (LCons w Ps)) \<sigma>"
| path_conforms_VVpstar: "\<lbrakk> v \<notin> VV p; path_conforms_with_strategy p Ps \<sigma> \<rbrakk>
    \<Longrightarrow> path_conforms_with_strategy p (LCons v Ps) \<sigma>"

text \<open>
  Define a locale for valid maximal paths that conform to a given strategy, because we need
  this concept quite often.  However, we are not yet able to add interesting lemmas to this locale.
  We will do this at the end of this section, where we have more lemmas available.
\<close>
locale vmc_path = vm_path +
  fixes p \<sigma> assumes P_conforms [simp]: "path_conforms_with_strategy p P \<sigma>"

text \<open>
  Similary, define a locale for valid maximal paths that conform to given strategies for both
  players.
\<close>
locale vmc2_path = comp?: vmc_path G P v0 "p**" \<sigma>' + vmc_path G P v0 p \<sigma>
  for G P v0 p \<sigma> \<sigma>'

subsection \<open>An Arbitrary Strategy\<close>

context ParityGame begin

text \<open>
  Define an arbitrary strategy.  This is useful to define other strategies by overriding part of
  this strategy.
\<close>
definition "\<sigma>_arbitrary \<equiv> \<lambda>v. SOME w. v\<rightarrow>w"

lemma valid_arbitrary_strategy [simp]: "strategy p \<sigma>_arbitrary" proof
  fix v assume "\<not>deadend v"
  thus "v \<rightarrow> \<sigma>_arbitrary v" unfolding \<sigma>_arbitrary_def using someI_ex[of "\<lambda>w. v\<rightarrow>w"] by blast
qed

subsection \<open>Valid Strategies\<close>

lemma valid_strategy_updates: "\<lbrakk> strategy p \<sigma>; v0\<rightarrow>w0 \<rbrakk> \<Longrightarrow> strategy p (\<sigma>(v0 := w0))"
  unfolding strategy_def by auto

lemma valid_strategy_updates_set:
  assumes "strategy p \<sigma>" "\<And>v. \<lbrakk> v \<in> A; v \<in> VV p; \<not>deadend v \<rbrakk> \<Longrightarrow> v\<rightarrow>\<sigma>' v"
  shows "strategy p (override_on \<sigma> \<sigma>' A)"
  unfolding strategy_def by (metis assms override_on_def strategy_def)

lemma valid_strategy_updates_set_strong:
  assumes "strategy p \<sigma>" "strategy p \<sigma>'"
  shows "strategy p (override_on \<sigma> \<sigma>' A)"
  using assms(1) assms(2)[unfolded strategy_def] valid_strategy_updates_set by simp

lemma subgame_strategy_stays_in_subgame:
  assumes \<sigma>: "ParityGame.strategy (subgame V') p \<sigma>"
    and "v \<in> ParityGame.VV (subgame V') p" "\<not>Digraph.deadend (subgame V') v"
  shows "\<sigma> v \<in> V'"
proof-
  interpret G': ParityGame "subgame V'" using subgame_ParityGame .
  have "\<sigma> v \<in> V\<^bsub>subgame V'\<^esub>" using assms unfolding G'.strategy_def G'.edges_are_in_V(2) by blast
  thus "\<sigma> v \<in> V'" by (metis Diff_iff IntE subgame_VV Player.distinct(2))
qed

lemma valid_strategy_supergame:
  assumes \<sigma>: "strategy p \<sigma>"
    and \<sigma>': "ParityGame.strategy (subgame V') p \<sigma>'"
    and G'_no_deadends: "\<And>v. v \<in> V' \<Longrightarrow> \<not>Digraph.deadend (subgame V') v"
  shows "strategy p (override_on \<sigma> \<sigma>' V')" (is "strategy p ?\<sigma>")
proof
  interpret G': ParityGame "subgame V'" using subgame_ParityGame .
  fix v assume v: "v \<in> VV p" "\<not>deadend v"
  show "v \<rightarrow> ?\<sigma> v" proof (cases)
    assume "v \<in> V'"
    hence "v \<in> G'.VV p" using subgame_VV \<open>v \<in> VV p\<close> by blast
    moreover have "\<not>G'.deadend v" using G'_no_deadends \<open>v \<in> V'\<close> by blast
    ultimately have "v \<rightarrow>\<^bsub>subgame V'\<^esub> \<sigma>' v" using \<sigma>' unfolding G'.strategy_def by blast
    moreover have "\<sigma>' v = ?\<sigma> v" using \<open>v \<in> V'\<close> by simp
    ultimately show ?thesis by (metis subgame_E subsetCE)
  next
    assume "v \<notin> V'"
    thus ?thesis using v \<sigma> unfolding strategy_def by simp
  qed
qed

lemma valid_strategy_in_V: "\<lbrakk> strategy p \<sigma>; v \<in> VV p; \<not>deadend v \<rbrakk> \<Longrightarrow> \<sigma> v \<in> V"
  unfolding strategy_def using valid_edge_set by auto

lemma valid_strategy_only_in_V: "\<lbrakk> strategy p \<sigma>; \<And>v. v \<in> V \<Longrightarrow> \<sigma> v = \<sigma>' v \<rbrakk> \<Longrightarrow> strategy p \<sigma>'"
  unfolding strategy_def using edges_are_in_V(1) by auto

subsection \<open>Conforming Strategies\<close>

lemma path_conforms_with_strategy_ltl [intro]:
  "path_conforms_with_strategy p P \<sigma> \<Longrightarrow> path_conforms_with_strategy p (ltl P) \<sigma>"
  by (drule path_conforms_with_strategy.cases) (simp_all add: path_conforms_with_strategy.intros(1))

lemma path_conforms_with_strategy_drop:
  "path_conforms_with_strategy p P \<sigma> \<Longrightarrow> path_conforms_with_strategy p (ldropn n P) \<sigma>"
  by (simp add: path_conforms_with_strategy_ltl ltl_ldrop[of "\<lambda>P. path_conforms_with_strategy p P \<sigma>"])

lemma path_conforms_with_strategy_prefix:
  "path_conforms_with_strategy p P \<sigma> \<Longrightarrow> lprefix P' P \<Longrightarrow> path_conforms_with_strategy p P' \<sigma>"
proof (coinduction arbitrary: P P')
  case (path_conforms_with_strategy P P')
  thus ?case proof (cases rule: path_conforms_with_strategy.cases)
    case path_conforms_LNil
    thus ?thesis using path_conforms_with_strategy(2) by auto
  next
    case path_conforms_LCons_LNil
    thus ?thesis by (metis lprefix_LCons_conv lprefix_antisym lprefix_code(1) path_conforms_with_strategy(2))
  next
    case (path_conforms_VVp v w)
    thus ?thesis proof (cases)
      assume "P' \<noteq> LNil \<and> P' \<noteq> LCons v LNil"
      hence "\<exists>Q. P' = LCons v (LCons w Q)"
        by (metis local.path_conforms_VVp(1) lprefix_LCons_conv path_conforms_with_strategy(2))
      thus ?thesis using local.path_conforms_VVp(1,3,4) path_conforms_with_strategy(2) by force
    qed auto
  next
    case (path_conforms_VVpstar v)
    thus ?thesis proof (cases)
      assume "P' \<noteq> LNil"
      hence "\<exists>Q. P' = LCons v Q"
        using local.path_conforms_VVpstar(1) lprefix_LCons_conv path_conforms_with_strategy(2) by fastforce
      thus ?thesis using local.path_conforms_VVpstar path_conforms_with_strategy(2) by auto
    qed simp
  qed
qed

lemma path_conforms_with_strategy_irrelevant:
  assumes "path_conforms_with_strategy p P \<sigma>" "v \<notin> lset P"
  shows "path_conforms_with_strategy p P (\<sigma>(v := w))"
  using assms apply (coinduction arbitrary: P) by (drule path_conforms_with_strategy.cases) auto

lemma path_conforms_with_strategy_irrelevant_updates:
  assumes "path_conforms_with_strategy p P \<sigma>" "\<And>v. v \<in> lset P \<Longrightarrow> \<sigma> v = \<sigma>' v"
  shows "path_conforms_with_strategy p P \<sigma>'"
using assms proof (coinduction arbitrary: P)
  case (path_conforms_with_strategy P)
  thus ?case proof (cases rule: path_conforms_with_strategy.cases)
    case (path_conforms_VVp v' w Ps)
    have "w = \<sigma>' v'" using local.path_conforms_VVp(1,3) path_conforms_with_strategy(2) by auto
    thus ?thesis using local.path_conforms_VVp(1,4) path_conforms_with_strategy(2) by auto
  qed simp_all
qed

lemma path_conforms_with_strategy_irrelevant':
  assumes "path_conforms_with_strategy p P (\<sigma>(v := w))" "v \<notin> lset P"
  shows "path_conforms_with_strategy p P \<sigma>"
  by (metis assms fun_upd_triv fun_upd_upd path_conforms_with_strategy_irrelevant)

lemma path_conforms_with_strategy_irrelevant_deadend':
  assumes "path_conforms_with_strategy p P (\<sigma>(v := w))" "deadend v \<or> v \<notin> VV p" "valid_path P"
  shows "path_conforms_with_strategy p P \<sigma>"
  by (metis assms fun_upd_triv fun_upd_upd path_conforms_with_strategy_irrelevant_deadend)

lemma path_conforms_with_strategy_start:
  "path_conforms_with_strategy p (LCons v (LCons w P)) \<sigma> \<Longrightarrow> v \<in> VV p \<Longrightarrow> \<sigma> v = w"
  by (drule path_conforms_with_strategy.cases) simp_all

lemma path_conforms_with_strategy_lappend:
  assumes
    P: "lfinite P" "\<not>lnull P" "path_conforms_with_strategy p P \<sigma>"
    and P': "\<not>lnull P'" "path_conforms_with_strategy p P' \<sigma>"
    and conforms: "llast P \<in> VV p \<Longrightarrow> \<sigma> (llast P) = lhd P'"
  shows "path_conforms_with_strategy p (lappend P P') \<sigma>"
using assms proof (induct P rule: lfinite_induct)
  case (LCons P)
  show ?case proof (cases)
    assume "lnull (ltl P)"
    then obtain v0 where v0: "P = LCons v0 LNil"
      by (metis LCons.prems(1) lhd_LCons_ltl llist.collapse(1))
    have "path_conforms_with_strategy p (LCons (lhd P) P') \<sigma>" proof (cases)
      assume "lhd P \<in> VV p"
      moreover with v0 have "lhd P' = \<sigma> (lhd P)"
        using LCons.prems(5) by auto
      ultimately show ?thesis
        using path_conforms_VVp[of "lhd P" p "lhd P'" \<sigma>]
        by (metis (no_types) LCons.prems(4) \<open>\<not>lnull P'\<close> lhd_LCons_ltl)
    next
      assume "lhd P \<notin> VV p"
      thus ?thesis using path_conforms_VVpstar using LCons.prems(4) v0 by blast
    qed
    thus ?thesis by (simp add: v0)
  next
    assume "\<not>lnull (ltl P)"
    hence *: "path_conforms_with_strategy p (lappend (ltl P) P') \<sigma>"
      by (metis LCons.hyps(3) LCons.prems(1) LCons.prems(2) LCons.prems(5) LCons.prems(5)
                assms(4) assms(5) lhd_LCons_ltl llast_LCons2 path_conforms_with_strategy_ltl)
    have "path_conforms_with_strategy p (LCons (lhd P) (lappend (ltl P) P')) \<sigma>" proof (cases)
      assume "lhd P \<in> VV p"
      moreover hence "lhd (ltl P) = \<sigma> (lhd P)"
        by (metis LCons.prems(1) LCons.prems(2) \<open>\<not>lnull (ltl P)\<close>
                  lhd_LCons_ltl path_conforms_with_strategy_start)
      ultimately show ?thesis
        using path_conforms_VVp[of "lhd P" p "lhd (ltl P)" \<sigma>] * \<open>\<not>lnull (ltl P)\<close>
        by (metis lappend_code(2) lhd_LCons_ltl)
    next
      assume "lhd P \<notin> VV p"
      thus ?thesis by (simp add: "*" path_conforms_VVpstar)
    qed
    with \<open>\<not>lnull P\<close> show "path_conforms_with_strategy p (lappend P P') \<sigma>"
      by (metis lappend_code(2) lhd_LCons_ltl)
  qed
qed simp

lemma path_conforms_with_strategy_VVpstar:
  assumes "lset P \<subseteq> VV p**"
  shows "path_conforms_with_strategy p P \<sigma>"
using assms proof (coinduction arbitrary: P)
  case (path_conforms_with_strategy P)
  moreover have "\<And>v Ps. P = LCons v Ps \<Longrightarrow> ?case" using path_conforms_with_strategy by auto
  ultimately show ?case by (cases "P = LNil", simp) (metis lnull_def not_lnull_conv)
qed

lemma subgame_path_conforms_with_strategy:
  assumes V': "V' \<subseteq> V" and P: "path_conforms_with_strategy p P \<sigma>" "lset P \<subseteq> V'"
  shows "ParityGame.path_conforms_with_strategy (subgame V') p P \<sigma>"
proof-
  have "lset P \<subseteq> V\<^bsub>subgame V'\<^esub>" unfolding subgame_def using P(2) V' by auto
  with P(1) show ?thesis
    by (coinduction arbitrary: P rule: ParityGame.path_conforms_with_strategy.coinduct[OF subgame_ParityGame])
       (cases rule: path_conforms_with_strategy.cases, auto)
qed

lemma (in vmc_path) subgame_path_vmc_path:
  assumes V': "V' \<subseteq> V" and P: "lset P \<subseteq> V'"
  shows "vmc_path (subgame V') P v0 p \<sigma>"
proof-
  interpret G': ParityGame "subgame V'" using subgame_ParityGame by blast
  show ?thesis proof
    show "G'.valid_path P" using subgame_valid_path P_valid P by blast
    show "G'.maximal_path P" using subgame_maximal_path V' P_maximal P by blast
    show "G'.path_conforms_with_strategy p P \<sigma>"
      using subgame_path_conforms_with_strategy V' P_conforms P by blast
  qed simp_all
qed

subsection \<open>Greedy Conforming Path\<close>

text \<open>
  Given a starting point and two strategies, there exists a path conforming to both strategies.
  Here we define this path.  Incidentally, this also shows that the assumptions of the locales
  \<open>vmc_path\<close> and \<open>vmc2_path\<close> are satisfiable.

  We are only interested in proving the existence of such a path, so the definition
  (i.e., the implementation) and most lemmas are private.
\<close>

context begin

private primcorec greedy_conforming_path :: "Player \<Rightarrow> 'a Strategy \<Rightarrow> 'a Strategy \<Rightarrow> 'a \<Rightarrow> 'a Path" where
  "greedy_conforming_path p \<sigma> \<sigma>' v0 =
    LCons v0 (if deadend v0
      then LNil
      else if v0 \<in> VV p
        then greedy_conforming_path p \<sigma> \<sigma>' (\<sigma> v0)
        else greedy_conforming_path p \<sigma> \<sigma>' (\<sigma>' v0))"

private lemma greedy_path_LNil: "greedy_conforming_path p \<sigma> \<sigma>' v0 \<noteq> LNil"
  using greedy_conforming_path.disc_iff llist.discI(1) by blast

private lemma greedy_path_lhd: "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v P \<Longrightarrow> v = v0"
  using greedy_conforming_path.code by auto

private lemma greedy_path_deadend_v0: "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v P \<Longrightarrow> P = LNil \<longleftrightarrow> deadend v0"
  by (metis (no_types, lifting) greedy_conforming_path.disc_iff
      greedy_conforming_path.simps(3) llist.disc(1) ltl_simps(2))

private corollary greedy_path_deadend_v:
  "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v P \<Longrightarrow> P = LNil \<longleftrightarrow> deadend v"
  using greedy_path_deadend_v0 greedy_path_lhd by metis
corollary greedy_path_deadend_v': "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v LNil \<Longrightarrow> deadend v"
  using greedy_path_deadend_v by blast

private lemma greedy_path_ltl:
  assumes "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v P"
  shows "P = LNil \<or> P = greedy_conforming_path p \<sigma> \<sigma>' (\<sigma> v0) \<or> P = greedy_conforming_path p \<sigma> \<sigma>' (\<sigma>' v0)"
  apply (insert assms, frule greedy_path_lhd)
  apply (cases "deadend v0", simp add: greedy_conforming_path.code)
  by (metis (no_types, lifting) greedy_conforming_path.sel(2) ltl_simps(2))

private lemma greedy_path_ltl_ex:
  assumes "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v P"
  shows "P = LNil \<or> (\<exists>v. P = greedy_conforming_path p \<sigma> \<sigma>' v)"
  using assms greedy_path_ltl by blast

private lemma greedy_path_ltl_VVp:
  assumes "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v0 P" "v0 \<in> VV p" "\<not>deadend v0"
  shows "\<sigma> v0 = lhd P"
  using assms greedy_conforming_path.code by auto

private lemma greedy_path_ltl_VVpstar:
  assumes "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v0 P" "v0 \<in> VV p**" "\<not>deadend v0"
  shows "\<sigma>' v0 = lhd P"
  using assms greedy_conforming_path.code by auto

private lemma greedy_conforming_path_properties:
  assumes "v0 \<in> V" "strategy p \<sigma>" "strategy p** \<sigma>'"
  shows
        greedy_path_not_null:  "\<not>lnull (greedy_conforming_path p \<sigma> \<sigma>' v0)"
    and greedy_path_v0:        "greedy_conforming_path p \<sigma> \<sigma>' v0 $ 0 = v0"
    and greedy_path_valid:     "valid_path (greedy_conforming_path p \<sigma> \<sigma>' v0)"
    and greedy_path_maximal:   "maximal_path (greedy_conforming_path p \<sigma> \<sigma>' v0)"
    and greedy_path_conforms:  "path_conforms_with_strategy p (greedy_conforming_path p \<sigma> \<sigma>' v0) \<sigma>"
    and greedy_path_conforms': "path_conforms_with_strategy p** (greedy_conforming_path p \<sigma> \<sigma>' v0) \<sigma>'"
proof-
  define P where [simp]: "P = greedy_conforming_path p \<sigma> \<sigma>' v0"

  show "\<not>lnull P" "P $ 0 = v0" by (simp_all add: lnth_0_conv_lhd)

  {
    fix v0 assume "v0 \<in> V"
    let ?P = "greedy_conforming_path p \<sigma> \<sigma>' v0"
    assume asm: "\<not>(\<exists>v. ?P = LCons v LNil)"
    obtain P' where P': "?P = LCons v0 P'" by (metis greedy_path_LNil greedy_path_lhd neq_LNil_conv)
    hence "\<not>deadend v0" using asm greedy_path_deadend_v0 \<open>v0 \<in> V\<close> by blast
    from P' have 1: "\<not>lnull P'" using asm llist.collapse(1) \<open>v0 \<in> V\<close> greedy_path_deadend_v0 by blast
    moreover from P' \<open>\<not>deadend v0\<close> assms(2,3) \<open>v0 \<in> V\<close>
      have "v0\<rightarrow>lhd P'"
      unfolding strategy_def using greedy_path_ltl_VVp greedy_path_ltl_VVpstar
      by (cases "v0 \<in> VV p") auto
    moreover hence "lhd P' \<in> V" by blast
    moreover hence "\<exists>v. P' = greedy_conforming_path p \<sigma> \<sigma>' v \<and> v \<in> V"
      by (metis P' calculation(1) greedy_conforming_path.simps(2) greedy_path_ltl_ex lnull_def)
    text \<open>The conjunction of all the above.\<close>
    ultimately
      have "\<exists>P'. ?P = LCons v0 P' \<and> \<not>lnull P' \<and> v0\<rightarrow>lhd P' \<and> lhd P' \<in> V
        \<and> (\<exists>v. P' = greedy_conforming_path p \<sigma> \<sigma>' v \<and> v \<in> V)"
      using P' by blast
  } note coinduction_helper = this

  show "valid_path P" using assms unfolding P_def
  proof (coinduction arbitrary: v0 rule: valid_path.coinduct)
    case (valid_path v0)
    from \<open>v0 \<in> V\<close> assms(2,3) show ?case
      using coinduction_helper[of v0] greedy_path_lhd by blast
  qed

  show "maximal_path P" using assms unfolding P_def
  proof (coinduction arbitrary: v0)
    case (maximal_path v0)
    from \<open>v0 \<in> V\<close> assms(2,3) show ?case
      using coinduction_helper[of v0] greedy_path_deadend_v' by blast
  qed

  {
    fix p'' \<sigma>'' assume p'': "(p'' = p \<and> \<sigma>'' = \<sigma>) \<or> (p'' = p** \<and> \<sigma>'' = \<sigma>')"
    moreover with assms have "strategy p'' \<sigma>''" by blast
    hence "path_conforms_with_strategy p'' P \<sigma>''" using \<open>v0 \<in> V\<close> unfolding P_def
    proof (coinduction arbitrary: v0)
      case (path_conforms_with_strategy v0)
      show ?case proof (cases "v0 \<in> VV p''")
        case True
        { assume "\<not>(\<exists>v. greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v LNil)"
          with \<open>v0 \<in> V\<close> obtain P' where
            P': "greedy_conforming_path p \<sigma> \<sigma>' v0 = LCons v0 P'" "\<not>lnull P'" "v0\<rightarrow>lhd P'"
                "lhd P' \<in> V" "\<exists>v. P' = greedy_conforming_path p \<sigma> \<sigma>' v \<and> v \<in> V"
            using coinduction_helper by blast
          with \<open>v0 \<in> VV p''\<close> p'' have "\<sigma>'' v0 = lhd P'"
            using greedy_path_ltl_VVp greedy_path_ltl_VVpstar by blast
          with \<open>v0 \<in> VV p''\<close> P'(1,2,5) have ?path_conforms_VVp
            using greedy_conforming_path.code path_conforms_with_strategy(1) by fastforce
        }
        thus ?thesis by auto
      next
        case False
        thus ?thesis using coinduction_helper[of v0] path_conforms_with_strategy by auto
      qed
    qed
  }
  thus "path_conforms_with_strategy p P \<sigma>" "path_conforms_with_strategy p** P \<sigma>'" by blast+
qed

corollary strategy_conforming_path_exists:
  assumes "v0 \<in> V" "strategy p \<sigma>" "strategy p** \<sigma>'"
  obtains P where "vmc2_path G P v0 p \<sigma> \<sigma>'"
proof
  show "vmc2_path G (greedy_conforming_path p \<sigma> \<sigma>' v0) v0 p \<sigma> \<sigma>'"
    using assms by unfold_locales (simp_all add: greedy_conforming_path_properties)
qed

corollary strategy_conforming_path_exists_single:
  assumes "v0 \<in> V" "strategy p \<sigma>"
  obtains P where "vmc_path G P v0 p \<sigma>"
proof
  show "vmc_path G (greedy_conforming_path p \<sigma> \<sigma>_arbitrary v0) v0 p \<sigma>"
    using assms by unfold_locales (simp_all add: greedy_conforming_path_properties)
qed

end

end

subsection \<open>Valid Maximal Conforming Paths\<close>

text \<open>Now is the time to add some lemmas to the locale \<open>vmc_path\<close>.\<close>

context vmc_path begin
lemma Ptl_conforms [simp]: "path_conforms_with_strategy p (ltl P) \<sigma>"
  using P_conforms path_conforms_with_strategy_ltl by blast
lemma Pdrop_conforms [simp]: "path_conforms_with_strategy p (ldropn n P) \<sigma>"
  using P_conforms path_conforms_with_strategy_drop by blast
lemma prefix_conforms [simp]: "path_conforms_with_strategy p (ltake n P) \<sigma>"
  using P_conforms path_conforms_with_strategy_prefix by blast
lemma extension_conforms [simp]:
  "(v' \<in> VV p \<Longrightarrow> \<sigma> v' = v0) \<Longrightarrow> path_conforms_with_strategy p (LCons v' P) \<sigma>"
  by (metis P_LCons P_conforms path_conforms_VVp path_conforms_VVpstar)

lemma extension_valid_maximal_conforming:
  assumes "v'\<rightarrow>v0" "v' \<in> VV p \<Longrightarrow> \<sigma> v' = v0"
  shows "vmc_path G (LCons v' P) v' p \<sigma>"
  using assms by unfold_locales simp_all

lemma vmc_path_ldropn:
  assumes "enat n < llength P"
  shows "vmc_path G (ldropn n P) (P $ n) p \<sigma>"
  using assms by unfold_locales (simp_all add: lhd_ldropn)

lemma conforms_to_another_strategy:
  "path_conforms_with_strategy p P \<sigma>' \<Longrightarrow> vmc_path G P v0 p \<sigma>'"
  using P_not_null P_valid P_maximal P_v0 by unfold_locales blast+
end

lemma (in ParityGame) valid_maximal_conforming_path_0:
  assumes "\<not>lnull P" "valid_path P" "maximal_path P" "path_conforms_with_strategy p P \<sigma>"
  shows "vmc_path G P (P $ 0) p \<sigma>"
  using assms by unfold_locales (simp_all add: lnth_0_conv_lhd)

subsection \<open>Valid Maximal Conforming Paths with One Edge\<close>

text \<open>
  We define a locale for valid maximal conforming paths that contain at least one edge.
  This is equivalent to the first node being no deadend.  This assumption allows us to prove
  much stronger lemmas about @{term "ltl P"} compared to @{term "vmc_path"}.
\<close>

locale vmc_path_no_deadend = vmc_path +
  assumes v0_no_deadend [simp]: "\<not>deadend v0"
begin
definition "w0 \<equiv> lhd (ltl P)"

lemma Ptl_not_null [simp]: "\<not>lnull (ltl P)"
  using P_LCons P_maximal maximal_no_deadend v0_no_deadend by metis
lemma Ptl_LCons: "ltl P = LCons w0 (ltl (ltl P))" unfolding w0_def by simp
lemma P_LCons': "P = LCons v0 (LCons w0 (ltl (ltl P)))" using P_LCons Ptl_LCons by simp
lemma v0_edge_w0 [simp]: "v0\<rightarrow>w0" using P_valid P_LCons' by (metis valid_path_edges')

lemma v0_conforms: "v0 \<in> VV p \<Longrightarrow> \<sigma> v0 = w0"
  using path_conforms_with_strategy_start by (metis P_LCons' P_conforms)

lemma w0_V [simp]: "w0 \<in> V" by (metis Ptl_LCons Ptl_valid valid_path_cons_simp)
lemma w0_lset_P [simp]: "w0 \<in> lset P" by (metis P_LCons' lset_intros(1) lset_intros(2))

lemma vmc_path_ltl [simp]: "vmc_path G (ltl P) w0 p \<sigma>" by (unfold_locales) (simp_all add: w0_def)
end

context vmc_path begin

lemma vmc_path_lnull_ltl_no_deadend:
  "\<not>lnull (ltl P) \<Longrightarrow> vmc_path_no_deadend G P v0 p \<sigma>"
  using P_0 P_no_deadends by (unfold_locales) (metis enat_ltl_Suc lnull_0_llength)

lemma vmc_path_conforms:
  assumes "enat (Suc n) < llength P" "P $ n \<in> VV p"
  shows "\<sigma> (P $ n) = P $ Suc n"
proof-
  define P' where "P' = ldropn n P"
  then interpret P': vmc_path G P' "P $ n" p \<sigma> using vmc_path_ldropn assms(1) Suc_llength by blast
  have "\<not>deadend (P $ n)" using assms(1) P_no_deadends by blast
  then interpret P': vmc_path_no_deadend G P' "P $ n" p \<sigma> by unfold_locales
  have "\<sigma> (P $ n) = P'.w0" using P'.v0_conforms assms(2) by blast
  thus ?thesis using P'_def P'.P_Suc_0 assms(1) by simp
qed

subsection \<open>@{term lset} Induction Schemas for Paths\<close>

text \<open>Let us define an induction schema useful for proving @{term "lset P \<subseteq> S"}.\<close>

lemma vmc_path_lset_induction [consumes 1, case_names base step]:
  assumes "Q P"
    and base: "v0 \<in> S"
    and step_assumption: "\<And>P v0. \<lbrakk> vmc_path_no_deadend G P v0 p \<sigma>; v0 \<in> S; Q P \<rbrakk>
      \<Longrightarrow> Q (ltl P) \<and> (vmc_path_no_deadend.w0 P) \<in> S"
  shows "lset P \<subseteq> S"
proof
  fix v assume "v \<in> lset P"
  thus "v \<in> S" using vmc_path_axioms assms(1,2) proof (induct arbitrary: v0 rule: llist_set_induct)
    case (find P)
    then interpret vmc_path G P v0 p \<sigma> by blast
    show ?case by (simp add: find.prems(3))
  next
    case (step P v)
    then interpret vmc_path G P v0 p \<sigma> by blast
    show ?case proof (cases)
      assume "lnull (ltl P)"
      hence "P = LCons v LNil" by (metis llist.disc(2) lset_cases step.hyps(2))
      thus ?thesis using step.prems(3) P_LCons by blast
    next
      assume "\<not>lnull (ltl P)"
      then interpret vmc_path_no_deadend G P v0 p \<sigma>
        using vmc_path_lnull_ltl_no_deadend by blast
      show "v \<in> S"
        using step.hyps(3)
              step_assumption[OF vmc_path_no_deadend_axioms \<open>v0 \<in> S\<close> \<open>Q P\<close>]
              vmc_path_ltl
        by blast
    qed
  qed
qed

text \<open>@{thm vmc_path_lset_induction} without the Q predicate.\<close>
corollary vmc_path_lset_induction_simple [case_names base step]:
  assumes base: "v0 \<in> S"
    and step: "\<And>P v0. \<lbrakk> vmc_path_no_deadend G P v0 p \<sigma>; v0 \<in> S \<rbrakk>
      \<Longrightarrow> vmc_path_no_deadend.w0 P \<in> S"
  shows "lset P \<subseteq> S"
  using assms vmc_path_lset_induction[of "\<lambda>P. True"] by blast

text \<open>Another induction schema for proving @{term "lset P \<subseteq> S"} based on closure properties.\<close>

lemma vmc_path_lset_induction_closed_subset [case_names VVp VVpstar v0 disjoint]:
  assumes VVp: "\<And>v. \<lbrakk> v \<in> S; \<not>deadend v; v \<in> VV p \<rbrakk> \<Longrightarrow> \<sigma> v \<in> S \<union> T"
    and VVpstar: "\<And>v w. \<lbrakk> v \<in> S; \<not>deadend v; v \<in> VV p** ; v\<rightarrow>w \<rbrakk> \<Longrightarrow> w \<in> S \<union> T"
    and v0: "v0 \<in> S"
    and disjoint: "lset P \<inter> T = {}"
  shows "lset P \<subseteq> S"
using disjoint proof (induct rule: vmc_path_lset_induction)
  case (step P v0)
  interpret vmc_path_no_deadend G P v0 p \<sigma> using step.hyps(1) .
  have "lset (ltl P) \<inter> T = {}" using step.hyps(3)
    by (meson disjoint_eq_subset_Compl lset_ltl order.trans)
  moreover have "w0 \<in> S \<union> T"
    using assms(1,2)[of v0] step.hyps(2) v0_no_deadend v0_conforms
    by (cases "v0 \<in> VV p") simp_all
  ultimately show ?case using step.hyps(3) w0_lset_P by blast
qed (insert v0)

end

end