(*
  File:    FPS_Hensel.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Hensel's lemma for formal power series\<close>
theory FPS_Hensel
  imports "HOL-Computational_Algebra.Computational_Algebra" Puiseux_Polynomial_Library
begin

text \<open>
  The following proof of Hensel's lemma for formal power series follows the book
  ``Algebraic Geometry for Scientists and Engineers'' by Abhyankar~\<^cite>\<open>\<open>p.~90--92\<close> in "abhyankar1990"\<close>.
\<close>

definition fps_poly_swap1 :: "'a :: zero fps poly \<Rightarrow> 'a poly fps" where
  "fps_poly_swap1 p = Abs_fps (\<lambda>m. Abs_poly (\<lambda>n. fps_nth (coeff p n) m))"

lemma coeff_fps_nth_fps_poly_swap1 [simp]:
  "coeff (fps_nth (fps_poly_swap1 p) m) n = fps_nth (coeff p n) m"
proof -
  have "\<forall>\<^sub>\<infinity>n. poly.coeff p n = 0"
    using MOST_coeff_eq_0 by blast
  hence "\<forall>\<^sub>\<infinity>n. poly.coeff p n $ m = 0"
    by eventually_elim auto
  thus ?thesis
    by (simp add: fps_poly_swap1_def poly.Abs_poly_inverse)
qed

definition fps_poly_swap2 :: "'a :: zero poly fps \<Rightarrow> 'a fps poly" where
  "fps_poly_swap2 p = Abs_poly (\<lambda>m. Abs_fps (\<lambda>n. coeff (fps_nth p n) m))"

lemma fps_nth_coeff_fps_poly_swap2:
  assumes "\<And>n. degree (fps_nth p n) \<le> d"
  shows   "fps_nth (coeff (fps_poly_swap2 p) m) n = coeff (fps_nth p n) m"
proof -
  have "\<forall>\<^sub>\<infinity>n. n > d"
    using MOST_nat by blast
  hence "\<forall>\<^sub>\<infinity>n. (\<lambda>m. poly.coeff (p $ m) n) = (\<lambda>_. 0)"
    by eventually_elim (auto simp: fun_eq_iff intro!: coeff_eq_0 le_less_trans[OF assms(1)])
  hence ev: "\<forall>\<^sub>\<infinity>n. Abs_fps (\<lambda>m. poly.coeff (p $ m) n) = 0"
    by eventually_elim (simp add: fps_zero_def)

  have "fps_nth (coeff (fps_poly_swap2 p) m) n =
          poly.coeff (Abs_poly (\<lambda>m. Abs_fps (\<lambda>n. poly.coeff (p $ n) m))) m $ n"
    by (simp add: fps_poly_swap2_def)
  also have "\<dots> = Abs_fps (\<lambda>n. poly.coeff (p $ n) m) $ n"
    using ev by (subst poly.Abs_poly_inverse) auto
  finally show "fps_nth (coeff (fps_poly_swap2 p) m) n = coeff (fps_nth p n) m"
    by simp
qed

lemma degree_fps_poly_swap2_le:
  assumes "\<And>n. degree (fps_nth p n) \<le> d"
  shows   "degree (fps_poly_swap2 p) \<le> d"
proof (safe intro!: degree_le)
  fix n assume "n > d"
  show "poly.coeff (fps_poly_swap2 p) n = 0"
  proof (rule fps_ext)
    fix m
    have "poly.coeff (fps_poly_swap2 p) n $ m = poly.coeff (p $ m) n"
      by (subst fps_nth_coeff_fps_poly_swap2[OF assms]) auto
    also have "\<dots> = 0"
      by (intro coeff_eq_0 le_less_trans[OF assms \<open>n > d\<close>])
    finally show "poly.coeff (fps_poly_swap2 p) n $ m = 0 $ m"
      by simp
  qed
qed

lemma degree_fps_poly_swap2_eq:
  assumes "\<And>n. degree (fps_nth p n) \<le> d"
  assumes "d > 0 \<or> fps_nth p n \<noteq> 0"
  assumes "degree (fps_nth p n) = d"
  shows   "degree (fps_poly_swap2 p) = d"
proof (rule antisym)
  have "fps_nth (coeff (fps_poly_swap2 p) d) n = poly.coeff (fps_nth p n) d"
    by (subst fps_nth_coeff_fps_poly_swap2[OF assms(1)]) auto
  also have "\<dots> \<noteq> 0"
    using assms(2,3) by force
  finally have "coeff (fps_poly_swap2 p) d \<noteq> 0"
    by force
  thus "degree (fps_poly_swap2 p) \<ge> d"
    using le_degree by blast
next
  show "degree (fps_poly_swap2 p) \<le> d"
    by (intro degree_fps_poly_swap2_le) fact
qed

definition reduce_fps_poly :: "'a :: zero fps poly \<Rightarrow> 'a poly" where
  "reduce_fps_poly F = fps_nth (fps_poly_swap1 F) 0"

lemma
  fixes F :: "'a :: field fps poly"
  assumes "lead_coeff F = 1"
  shows   degree_reduce_fps_poly_monic: "degree (reduce_fps_poly F) = degree F"
    and   reduce_fps_poly_monic: "lead_coeff (reduce_fps_poly F) = 1"
proof -
  have eq1: "coeff (reduce_fps_poly F) (degree F) = 1"
    unfolding reduce_fps_poly_def by (simp add: assms)
  have eq2: "coeff (reduce_fps_poly F) n = 0" if "n > degree F" for n
    unfolding reduce_fps_poly_def using that by (simp add: coeff_eq_0)

  have "degree (reduce_fps_poly F) \<le> degree F"
    by (rule degree_le) (auto simp: eq2)
  moreover have "degree (reduce_fps_poly F) \<ge> degree F"
    by (rule le_degree) (simp add: eq1)
  from eq1 eq2 show "degree (reduce_fps_poly F) = degree F"
    by (intro antisym le_degree degree_le) auto
  with eq1 show "lead_coeff (reduce_fps_poly F) = 1"
    by simp
qed

locale fps_hensel_aux =
  fixes F :: "'a :: field_gcd poly fps"
  fixes g h :: "'a poly"
  assumes coprime: "coprime g h" and deg_g: "degree g > 0" and deg_h: "degree h > 0"
begin

context
  fixes g' h' :: "'a poly"
  defines "h' \<equiv> fst (bezout_coefficients g h)" and "g' \<equiv> snd (bezout_coefficients g h)"
begin

fun hensel_fpxs_aux :: "nat \<Rightarrow> 'a poly \<times> 'a poly" where
  "hensel_fpxs_aux n = (if n = 0 then (g, h) else
     (let
        U = fps_nth F n -
              (\<Sum>(i,j) | i < n \<and> j < n \<and> i + j = n. fst (hensel_fpxs_aux i) * snd (hensel_fpxs_aux j))
      in (U * g' + g * ((U * h') div h), (U * h') mod h)))"

lemmas [simp del] = hensel_fpxs_aux.simps

lemma hensel_fpxs_aux_0 [simp]: "hensel_fpxs_aux 0 = (g, h)"
  by (subst hensel_fpxs_aux.simps) auto

definition hensel_fpxs1 :: "'a poly fps"
  where "hensel_fpxs1 = Abs_fps (fst \<circ> hensel_fpxs_aux)"

definition hensel_fpxs2 :: "'a poly fps"
  where "hensel_fpxs2 = Abs_fps (snd \<circ> hensel_fpxs_aux)"

lemma hensel_fpxs1_0 [simp]: "hensel_fpxs1 $ 0 = g"
  by (simp add: hensel_fpxs1_def)

lemma hensel_fpxs2_0 [simp]: "hensel_fpxs2 $ 0 = h"
  by (simp add: hensel_fpxs2_def)

theorem fps_hensel_aux:
  defines "f \<equiv> fps_nth F 0"
  assumes "f = g * h"
  assumes "\<forall>n>0. degree (fps_nth F n) < degree f"
  defines "G \<equiv> hensel_fpxs1" and "H \<equiv> hensel_fpxs2"
  shows "F = G * H" "fps_nth G 0 = g" "fps_nth H 0 = h"
        "\<forall>n>0. degree (fps_nth G n) < degree g"
        "\<forall>n>0. degree (fps_nth H n) < degree h"
proof -
  show "fps_nth G 0 = g" "fps_nth H 0 = h"
    by (simp_all add: G_def H_def hensel_fpxs1_def hensel_fpxs2_def)

  have deg_f: "degree f = degree g + degree h"
    unfolding \<open>f = g * h\<close> using assms by (intro degree_mult_eq) auto

  have deg_H: "degree (fps_nth H n) < degree h" if \<open>n > 0\<close> for n
  proof (cases "snd (hensel_fpxs_aux n) = 0")
    case False
    thus ?thesis
      using deg_h \<open>n > 0\<close>
      by (auto simp: hensel_fpxs_aux.simps[of n] hensel_fpxs2_def H_def intro: degree_mod_less')
  qed (use assms deg_h in \<open>auto simp: hensel_fpxs2_def\<close>)
  thus "\<forall>n>0. degree (fps_nth H n) < degree h"
    by blast

  have *: "fps_nth F n = fps_nth (G * H) n \<and> (n > 0 \<longrightarrow> degree (fps_nth G n) < degree g)" for n
  proof (induction n rule: less_induct)
    case (less n)
    have fin: "finite {p. fst p < n \<and> snd p < n \<and> fst p + snd p = n}"
      by (rule finite_subset[of _ "{..n} \<times> {..n}"]) auto
    show ?case
    proof (cases "n = 0")
      case True
      thus ?thesis using assms
        by (auto simp: hensel_fpxs1_def hensel_fpxs2_def)
    next
      case False
      define U where "U = fps_nth F n -
         (\<Sum>(i,j) | i < n \<and> j < n \<and> i + j = n. fst (hensel_fpxs_aux i) * snd (hensel_fpxs_aux j))"
      define g'' h'' where "g'' = U * g'" and "h'' = U * h'"

      have "fps_nth (G * H) n =
              (\<Sum>i=0..n. fst (hensel_fpxs_aux i) * snd (hensel_fpxs_aux (n - i)))"
        using assms by (auto simp: hensel_fpxs1_def hensel_fpxs2_def fps_mult_nth)
      also have "\<dots> = (\<Sum>(i,j) | i + j = n. fst (hensel_fpxs_aux i) * snd (hensel_fpxs_aux j))"
        by (rule sum.reindex_bij_witness[of _ fst "\<lambda>i. (i, n - i)"]) auto
      also have "{(i,j). i + j = n} = {(i,j). i < n \<and> j < n \<and> i + j = n} \<union> {(n,0), (0,n)}"
        by auto
      also have "(\<Sum>(i,j)\<in>\<dots>. fst (hensel_fpxs_aux i) * snd (hensel_fpxs_aux j)) =
                 fps_nth F n - U + (fst (hensel_fpxs_aux n) * h + g * snd (hensel_fpxs_aux n))"
        using False fin by (subst sum.union_disjoint) (auto simp: case_prod_unfold U_def)
      also have eq: "fst (hensel_fpxs_aux n) * h + g * snd (hensel_fpxs_aux n) = U"
      proof -
        have "fst (hensel_fpxs_aux n) * h + g * snd (hensel_fpxs_aux n) =
              (g'' + g * (h'' div h)) * h + g * (h'' mod h)"
          using False by (simp add: hensel_fpxs_aux.simps[of n] U_def g''_def h''_def)
        also have "h'' mod h = h'' - (h'' div h) * h"
          by (simp add: minus_div_mult_eq_mod)
        also have "(g'' + g * (h'' div h)) * h + g * (h'' - h'' div h * h) = g * h'' + g'' * h"
          by (simp add: algebra_simps)
        also have "\<dots> = U * (h' * g + g' * h)"
          by (simp add: algebra_simps g''_def h''_def)
        also have "h' * g + g' * h = gcd g h"
          unfolding g'_def h'_def by (rule bezout_coefficients_fst_snd)
        also have "gcd g h = 1"
          using coprime by simp
        finally show ?thesis by simp
      qed
      finally have "fps_nth F n = fps_nth (G * H) n" by simp

      have "degree (G $ n) < degree g"
      proof (cases "G $ n = 0")
        case False
        have "degree (G $ n) + degree h = degree (G $ n * h)"
          using False assms by (intro degree_mult_eq [symmetric]) auto
        also from eq have "fps_nth G n * h = U - g * snd (hensel_fpxs_aux n)"
          by (simp add: algebra_simps G_def hensel_fpxs1_def)
        hence "degree (fps_nth G n * h) = degree (U - g * snd (hensel_fpxs_aux n))"
          by (simp only: )
        also have "\<dots> < degree f"
        proof (intro degree_diff_less)
          have "degree (g * snd (local.hensel_fpxs_aux n)) \<le>
                degree g + degree (snd (local.hensel_fpxs_aux n))"
            by (intro degree_mult_le)
          also have "degree (snd (local.hensel_fpxs_aux n)) < degree h"
            using deg_H[of n] \<open>n \<noteq> 0\<close> by (auto simp: H_def hensel_fpxs2_def)
          also have "degree g + degree h = degree f"
            by (subst deg_f) auto
          finally show "degree (g * snd (local.hensel_fpxs_aux n)) < degree f"
            by simp
        next
          show "degree U < degree f"
            unfolding U_def
          proof (intro degree_diff_less degree_sum_less)
            show "degree (F $ n) < degree f"
              using \<open>n \<noteq> 0\<close> assms by auto
          next
            show "degree f > 0"
              unfolding deg_f using deg_g by simp
          next
            fix z assume z: "z \<in> {(i, j). i < n \<and> j < n \<and> i + j = n}"
            have "degree (case z of (i, j) \<Rightarrow> fst (hensel_fpxs_aux i) * snd (hensel_fpxs_aux j)) =
                    degree (fps_nth G (fst z) * fps_nth H (snd z))" (is "?lhs = _")
              by (simp add: case_prod_unfold G_def H_def hensel_fpxs1_def hensel_fpxs2_def)
            also have "\<dots> \<le> degree (fps_nth G (fst z)) + degree (fps_nth H (snd z))"
              by (intro degree_mult_le)
            also have "\<dots> < degree g + degree h"
              using z less.IH[of "fst z"]
              by (intro add_strict_mono deg_H) (simp_all add: case_prod_unfold)
            finally show "?lhs < degree f"
              by (simp add: deg_f)
          qed
        qed
        finally show ?thesis
          by (simp add: deg_f)
      qed (use deg_g in auto)

      with \<open>fps_nth F n = fps_nth (G * H) n\<close> show ?thesis
        by blast
    qed
  qed

  from * show "F = G * H" and "\<forall>n>0. degree (fps_nth G n) < degree g"
    by (auto simp: fps_eq_iff)
qed

end

end

locale fps_hensel =
  fixes F :: "'a :: field_gcd fps poly" and f g h :: "'a poly"
  assumes monic: "lead_coeff F = 1"
  defines "f \<equiv> reduce_fps_poly F"
  assumes f_splits: "f = g * h"
  assumes coprime: "coprime g h" and deg_g: "degree g > 0" and deg_h: "degree h > 0"
begin

definition F' where "F' = fps_poly_swap1 F"

sublocale fps_hensel_aux F' g h
  by unfold_locales (fact deg_g deg_h coprime)+

definition G where
  "G = fps_poly_swap2 hensel_fpxs1"

definition H where
  "H = fps_poly_swap2 hensel_fpxs2"

lemma deg_f: "degree f = degree F"
proof (intro antisym)
  have "coeff f (degree F) \<noteq> 0"
    using monic by (simp add: f_def reduce_fps_poly_def)
  thus "degree f \<ge> (degree F)"
    by (rule le_degree)
next
  have "coeff f n = 0" if "n > degree F" for n
    using that by (simp add: f_def reduce_fps_poly_def coeff_eq_0)
  thus "degree f \<le> degree F"
    using degree_le by blast
qed

lemma
  F_splits:     "F = G * H" and
  reduce_G:     "reduce_fps_poly G = g" and
  reduce_H:     "reduce_fps_poly H = h" and
  deg_G:        "degree G = degree g" and
  deg_H:        "degree H = degree h" and
  lead_coeff_G: "lead_coeff G = fps_const (lead_coeff g)" and
  lead_coeff_H: "lead_coeff H = fps_const (lead_coeff h)"
proof -
  from deg_g deg_h have [simp]: "g \<noteq> 0" "h \<noteq> 0"
    by auto
  define N where "N = degree F"

  have deg_f: "degree f = N"
  proof (intro antisym)
    have "coeff f N \<noteq> 0"
      using monic by (simp add: f_def reduce_fps_poly_def N_def)
    thus "degree f \<ge> N"
      by (rule le_degree)
  next
    have "coeff f n = 0" if "n > N" for n
      using that by (simp add: f_def reduce_fps_poly_def N_def coeff_eq_0)
    thus "degree f \<le> N"
      using degree_le by blast
  qed

  have "F' $ 0 = f"
    unfolding F'_def f_def reduce_fps_poly_def ..
  have F'0: "F' $ 0 = g * h"
    using f_splits by (simp add: F'_def f_def reduce_fps_poly_def)

  have "\<forall>n>0. degree (F' $ n) < N"
  proof (subst F'_def, intro allI impI degree_lessI)
    fix n :: nat
    assume n: "n > 0"
    show "fps_poly_swap1 F $ n \<noteq> 0 \<or> 0 < N"
      using n deg_g deg_h f_splits deg_f by (auto simp: F'0 degree_mult_eq)
    fix k
    assume k: "k \<ge> N"
    have "coeff (F' $ n) k = coeff F k $ n"
      unfolding F'_def by simp
    also have "\<dots>= 0"
      using monic \<open>n > 0\<close> k by (cases "k > N") (auto simp: N_def coeff_eq_0)
    finally show "coeff (fps_poly_swap1 F $ n) k = 0"
      by (simp add: F'_def)
  qed
  hence degs_less: "\<forall>n>0. degree (F' $ n) < degree (F' $ 0)"
    by (simp add: \<open>F' $ 0 = f\<close> deg_f)
  note hensel = fps_hensel_aux[OF F'0 degs_less]

  have deg_less1: "degree (hensel_fpxs1 $ n) < degree g" if "n > 0" for n
    using hensel(4) that by (simp add: F'_def)
  have deg_le1: "degree (hensel_fpxs1 $ n) \<le> degree g" for n
  proof (cases "n = 0")
    case True
    hence "hensel_fpxs1 $ n = g"
      by (simp add: hensel_fpxs1_def)
    thus ?thesis by simp
  qed (auto intro: less_imp_le deg_less1 simp: f_def)

  have deg_less2: "degree (hensel_fpxs2 $ n) < degree h" if "n > 0" for n
    using hensel(5) that by (simp add: F'_def)
  have deg_le2: "degree (hensel_fpxs2 $ n) \<le> degree h" for n
  proof (cases "n = 0")
    case True
    hence "hensel_fpxs2 $ n = h"
      by (simp add: hensel_fpxs2_def)
    thus ?thesis by simp
  qed (auto intro: less_imp_le deg_less2 simp: f_def)

  show "F = G * H"
    unfolding poly_eq_iff fps_eq_iff
  proof safe
    fix n k
    have "poly.coeff F n $ k = poly.coeff (F' $ k) n"
      unfolding F'_def by simp
    also have "F' = hensel_fpxs1 * hensel_fpxs2"
      by (rule hensel)
    also have "\<dots> $ k = (\<Sum>i=0..k. hensel_fpxs1 $ i * hensel_fpxs2 $ (k - i))"
      unfolding fps_mult_nth ..
    also have "poly.coeff \<dots> n =
                 (\<Sum>i=0..k. \<Sum>j\<le>n. coeff (hensel_fpxs1 $ i) j * coeff (hensel_fpxs2 $ (k - i)) (n - j))"
      by (simp add: coeff_sum coeff_mult)
    also have "(\<lambda>i j. coeff (hensel_fpxs1 $ i) j) = (\<lambda>i j. coeff G j $ i)"
      unfolding G_def
      by (subst fps_nth_coeff_fps_poly_swap2[OF deg_le1]) (auto simp: F'_def)
    also have "(\<lambda>i j. coeff (hensel_fpxs2 $ i) j) = (\<lambda>i j. coeff H j $ i)"
      unfolding H_def
      by (subst fps_nth_coeff_fps_poly_swap2[OF deg_le2]) (auto simp: F'_def)
    also have "(\<Sum>i=0..k. \<Sum>j\<le>n. poly.coeff G j $ i * poly.coeff H (n - j) $ (k - i)) =
               (\<Sum>j\<le>n. \<Sum>i=0..k. poly.coeff G j $ i * poly.coeff H (n - j) $ (k - i))"
      by (rule sum.swap)
    also have "\<dots> = poly.coeff (G * H) n $ k"
      by (simp add: coeff_mult fps_mult_nth fps_sum_nth)
    finally show "poly.coeff F n $ k = poly.coeff (G * H) n $ k" .
  qed

  show "reduce_fps_poly G = g" unfolding G_def reduce_fps_poly_def poly_eq_iff
    by (auto simp: fps_nth_coeff_fps_poly_swap2[OF deg_le1])
  show "reduce_fps_poly H = h" unfolding H_def reduce_fps_poly_def poly_eq_iff
    by (auto simp: fps_nth_coeff_fps_poly_swap2[OF deg_le2])
  show "degree G = degree g" unfolding G_def
    by (rule degree_fps_poly_swap2_eq[where n = 0] deg_le1 disjI1 deg_g deg_le2)+ simp_all
  show "degree H = degree h" unfolding H_def
    by (rule degree_fps_poly_swap2_eq[where n = 0] deg_le1 disjI1 deg_h deg_le2)+ simp_all

  show "lead_coeff G = fps_const (lead_coeff g)"
  proof (rule fps_ext)
    fix n ::nat
    have "lead_coeff G $ n = coeff (hensel_fpxs1 $ n) (degree G)"
      by (subst G_def, subst fps_nth_coeff_fps_poly_swap2[OF deg_le1]) auto
    also have "\<dots> = (if n = 0 then lead_coeff g else 0)"
      by (auto simp: \<open>degree G = degree g\<close> intro: coeff_eq_0 deg_less1)
    finally show "lead_coeff G $ n = fps_const (lead_coeff g) $ n"
      by simp
  qed

  show "lead_coeff H = fps_const (lead_coeff h)"
  proof (rule fps_ext)
    fix n ::nat
    have "lead_coeff H $ n = coeff (hensel_fpxs2 $ n) (degree H)"
      by (subst H_def, subst fps_nth_coeff_fps_poly_swap2[OF deg_le2]) auto
    also have "\<dots> = (if n = 0 then lead_coeff h else 0)"
      by (auto simp: \<open>degree H = degree h\<close> intro: coeff_eq_0 deg_less2)
    finally show "lead_coeff H $ n = fps_const (lead_coeff h) $ n"
      by simp
  qed
qed

end

end


theory T95
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*<*)
theory sol06_2
imports "~~/src/HOL/IMP/Small_Step" "~~/src/HOL/IMP/Compiler"
begin
(*>*)
text {* \ExerciseSheet{6}{18.~11.~2014}
*}

text {*
\Exercise{Deskip}

Define a recursive function
*}
(*<*)(*kill*)
definition
"deskseq c1 c2 = (if c1=SKIP then c2 else if c2=SKIP then c1 else c1;;c2)"

definition
"deskif b c1 c2 =
 (if c1=SKIP & c2=SKIP then SKIP else IF b THEN c1 ELSE c2)"
(*>*)
fun deskip :: "com \<Rightarrow> com" (*<*)(*keep*)where(*>*)
(*<*)
"deskip (c1;;c2) = deskseq (deskip c1) (deskip c2)" |
"deskip (IF b THEN c1 ELSE c2) = deskif b (deskip c1) (deskip c2)" |
"deskip (WHILE b DO c) = WHILE b DO deskip c" |
"deskip c = c"
(*>*)

text{*
that eliminates as many @{const SKIP}s as possible from a command. For example:
@{prop[display]"deskip (SKIP;; WHILE b DO (x::=a;; SKIP)) = WHILE b DO x::=a"}
Prove its correctness by induction on @{text c}: *}

lemma "deskip c \<sim> c"
(*<*)
proof(induction c)
  case (Seq c1 c2)
  thus ?case
    by (auto simp add: deskseq_def) (metis Skip Big_Step.SkipE big_step.Seq)+
next
  case (If b c1 c2)
  thus ?case
    by (auto simp add: deskif_def) (metis big_step.IfFalse big_step.IfTrue Skip)
next
  case While thus ?case by (simp add: sim_while_cong)
qed auto
(*>*)

text{*
Remember lemma @{thm[source]sim_while_cong} for the @{text WHILE} case.
*}

(*<*)
end
(*>*)


header {* Sigma-Formulas and Theorem 2.5 *}

theory Sigma
imports Predicates
begin

section{*Ground Terms and Formulas*}

definition ground_aux :: "tm \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_aux t S \<equiv> (supp t \<subseteq> S)"

abbreviation ground :: "tm \<Rightarrow> bool"
  where "ground t \<equiv> ground_aux t {}"

definition ground_fm_aux :: "fm \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_fm_aux A S \<equiv> (supp A \<subseteq> S)"

abbreviation ground_fm :: "fm \<Rightarrow> bool"
  where "ground_fm A \<equiv> ground_fm_aux A {}"

lemma ground_aux_simps[simp]:
  "ground_aux Zero S = True"
  "ground_aux (Var k) S = (if atom k \<in> S then True else False)"
  "ground_aux (Eats t u) S = (ground_aux t S \<and> ground_aux u S)"
unfolding ground_aux_def
by (simp_all add: supp_at_base)

lemma ground_fm_aux_simps[simp]:
  "ground_fm_aux Fls S = True"
  "ground_fm_aux (t IN u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_fm_aux (t EQ u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_fm_aux (A OR B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (A AND B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (A IFF B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (Neg A) S =  (ground_fm_aux A S)"
  "ground_fm_aux (Ex x A) S = (ground_fm_aux A (S \<union> {atom x}))"
by (auto simp: ground_fm_aux_def ground_aux_def supp_conv_fresh)

lemma ground_fresh[simp]:
  "ground t \<Longrightarrow> atom i \<sharp> t"
  "ground_fm A \<Longrightarrow> atom i \<sharp> A"
unfolding ground_aux_def ground_fm_aux_def fresh_def
by simp_all

section{*Sigma Formulas*}

text{*Section 2 material*}

subsection {* Strict Sigma Formulas *}

text{*Definition 2.1*}
inductive ss_fm :: "fm \<Rightarrow> bool" where
    MemI:  "ss_fm (Var i IN Var j)"
  | DisjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A OR B)"
  | ConjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A AND B)"
  | ExI:   "ss_fm A \<Longrightarrow> ss_fm (Ex i A)"
  | All2I: "ss_fm A \<Longrightarrow> atom j \<sharp> (i,A) \<Longrightarrow> ss_fm (All2 i (Var j) A)"

equivariance ss_fm

nominal_inductive ss_fm
  avoids ExI: "i" | All2I: "i"
by (simp_all add: fresh_star_def)

declare ss_fm.intros [intro]

definition Sigma_fm :: "fm \<Rightarrow> bool"
  where "Sigma_fm A \<longleftrightarrow> (\<exists>B. ss_fm B \<and> supp B \<subseteq> supp A \<and> {} \<turnstile> A IFF B)"

lemma Sigma_fm_Iff: "\<lbrakk>{} \<turnstile> B IFF A; supp A \<subseteq> supp B; Sigma_fm A\<rbrakk> \<Longrightarrow> Sigma_fm B"
  by (metis Sigma_fm_def Iff_trans order_trans)

lemma ss_fm_imp_Sigma_fm [intro]: "ss_fm A \<Longrightarrow> Sigma_fm A"
  by (metis Iff_refl Sigma_fm_def order_refl)

lemma Sigma_fm_Fls [iff]: "Sigma_fm Fls"
  by (rule Sigma_fm_Iff [of _ "Ex i (Var i IN Var i)"]) auto

subsection{* Closure properties for Sigma-formulas *}

lemma
  assumes "Sigma_fm A" "Sigma_fm B"
    shows Sigma_fm_AND [intro!]: "Sigma_fm (A AND B)"
      and Sigma_fm_OR [intro!]:  "Sigma_fm (A OR B)"
      and Sigma_fm_Ex [intro!]:  "Sigma_fm (Ex i A)"
proof -
  obtain SA SB where "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
                 and "ss_fm SB" "{} \<turnstile> B IFF SB" "supp SB \<subseteq> supp B"
    using assms by (auto simp add: Sigma_fm_def)
  then show "Sigma_fm (A AND B)"  "Sigma_fm (A OR B)"  "Sigma_fm (Ex i A)"
    apply (auto simp: Sigma_fm_def)
    apply (metis ss_fm.ConjI Conj_cong Un_mono supp_Conj)
    apply (metis ss_fm.DisjI Disj_cong Un_mono fm.supp(3))
    apply (rule exI [where x = "Ex i SA"])
    apply (auto intro!: Ex_cong)
    done
qed

lemma Sigma_fm_All2_Var:
  assumes H0: "Sigma_fm A" and ij: "atom j \<sharp> (i,A)"
  shows "Sigma_fm (All2 i (Var j) A)"
proof -
  obtain SA where SA: "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
    using H0 by (auto simp add: Sigma_fm_def)
  show "Sigma_fm (All2 i (Var j) A)"
    apply (rule Sigma_fm_Iff [of _ "All2 i (Var j) SA"])
    apply (metis All2_cong Refl SA(2) emptyE)
    using SA ij
    apply (auto simp: supp_conv_fresh subset_iff)
    apply (metis ss_fm.All2I fresh_Pair ss_fm_imp_Sigma_fm)
    done
qed

section{* Lemma 2.2: Atomic formulas are Sigma-formulas *}

lemma Eq_Eats_Iff:
   assumes [unfolded fresh_Pair, simp]: "atom i \<sharp> (z,x,y)"
   shows "{} \<turnstile> z EQ Eats x y IFF (All2 i z (Var i IN x OR Var i EQ y)) AND x SUBS z AND y IN z"
proof (rule Iff_I, auto)
  have "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN Eats x y"
    by (metis Assume Iff_MP_left Iff_sym Mem_cong Refl)
  then show "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN x OR Var i EQ y"
    by (metis Iff_MP_same Mem_Eats_Iff)
next
  show "{z EQ Eats x y} \<turnstile> x SUBS z"
    by (metis Iff_MP2_same Subset_cong [OF Refl Assume] Subset_Eats_I)
next
  show "{z EQ Eats x y} \<turnstile> y IN z"
    by (metis Iff_MP2_same Mem_cong Assume Refl Mem_Eats_I2)
next
  show "{x SUBS z, y IN z, All2 i z (Var i IN x OR Var i EQ y)} \<turnstile> z EQ Eats x y"
       (is "{_, _, ?allHyp} \<turnstile> _")
    apply (rule Eq_Eats_iff [OF assms, THEN Iff_MP2_same], auto)
    apply (rule Ex_I [where x="Var i"])
    apply (auto intro: Subset_D  Mem_cong [OF Assume Refl, THEN Iff_MP2_same])
    done
qed

lemma Subset_Zero_sf: "Sigma_fm (Var i SUBS Zero)"
proof -
  obtain j::name where j: "atom j \<sharp> i"
    by (rule obtain_fresh)
  hence Subset_Zero_Iff: "{} \<turnstile> Var i SUBS Zero IFF (All2 j (Var i) Fls)"
    by (auto intro!: Subset_I [of j] intro: Eq_Zero_D Subset_Zero_D All2_E [THEN rotate2])
  thus ?thesis using j
    by (auto simp: supp_conv_fresh
             intro!: Sigma_fm_Iff [OF Subset_Zero_Iff] Sigma_fm_All2_Var)
qed

lemma Eq_Zero_sf: "Sigma_fm (Var i EQ Zero)"
proof -
  obtain j::name where "atom j \<sharp> i"
    by (rule obtain_fresh)
  thus ?thesis
    by (auto simp add: supp_conv_fresh
             intro!: Sigma_fm_Iff [OF _ _ Subset_Zero_sf] Subset_Zero_D EQ_imp_SUBS)
qed

lemma theorem_sf: assumes "{} \<turnstile> A" shows "Sigma_fm A"
proof -
  obtain i::name and j::name
    where ij: "atom i \<sharp> (j,A)" "atom j \<sharp> A"
    by (metis obtain_fresh)
  show ?thesis
    apply (rule Sigma_fm_Iff [where A = "Ex i (Ex j (Var i IN Var j))"])
    using ij
    apply (auto simp: )
    apply (rule Ex_I [where x=Zero], simp)
    apply (rule Ex_I [where x="Eats Zero Zero"])
    apply (auto intro: Mem_Eats_I2 assms thin0)
    done
qed

text {*The subset relation *}
lemma Var_Subset_sf: "Sigma_fm (Var i SUBS Var j)"
proof -
  obtain k::name where k: "atom (k::name) \<sharp> (i,j)"
    by (metis obtain_fresh)
  thus ?thesis
  proof (cases "i=j")
    case True thus ?thesis using k
      by (auto intro!: theorem_sf Subset_I [where i=k])
  next
    case False thus ?thesis using k
      by (auto simp: ss_fm_imp_Sigma_fm Subset.simps [of k] ss_fm.intros)
  qed
qed

lemma Zero_Mem_sf: "Sigma_fm (Zero IN Var i)"
proof -
  obtain j::name where "atom j \<sharp> i"
    by (rule obtain_fresh)
  hence Zero_Mem_Iff: "{} \<turnstile> Zero IN Var i IFF (Ex j (Var j  EQ Zero AND Var j  IN Var i))"
    by (auto intro: Ex_I [where x = Zero]  Mem_cong [OF Assume Refl, THEN Iff_MP_same])
  show ?thesis
    by (auto intro!: Sigma_fm_Iff [OF Zero_Mem_Iff] Eq_Zero_sf)
qed

lemma ijk: "i + k < Suc (i + j + k)"
  by arith

lemma All2_term_Iff_fresh: "i\<noteq>j \<Longrightarrow> atom j' \<sharp> (i,j,A) \<Longrightarrow>
   {} \<turnstile> (All2 i (Var j) A) IFF Ex j' (Var j EQ Var j' AND All2 i (Var j') A)"
apply auto
apply (rule Ex_I [where x="Var j"], auto)
apply (rule Ex_I [where x="Var i"], auto intro: ContraProve Mem_cong [THEN Iff_MP_same])
done

lemma Sigma_fm_All2_fresh:
  assumes "Sigma_fm A" "i\<noteq>j"
    shows "Sigma_fm (All2 i (Var j) A)"
proof -
  obtain j'::name where j': "atom j' \<sharp> (i,j,A)"
    by (metis obtain_fresh)
  show "Sigma_fm (All2 i (Var j) A)"
    apply (rule Sigma_fm_Iff [OF All2_term_Iff_fresh [OF _ j']])
    using assms j'
    apply (auto simp: supp_conv_fresh Var_Subset_sf
                intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
    done
qed

lemma Subset_Eats_sf:
  assumes "\<And>j::name. Sigma_fm (Var j IN t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Var i SUBS Eats t u)"
proof -
  obtain k::name where k: "atom k \<sharp> (t,u,Var i)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Var i SUBS Eats t u IFF All2 k (Var i) (Var k IN t OR Var k EQ u)"
    apply (auto simp: fresh_Pair intro: Set_MP Disj_I1 Disj_I2)
    apply (force intro!: Subset_I [where i=k] intro: All2_E' [OF Hyp] Mem_Eats_I1 Mem_Eats_I2)
    done
  thus ?thesis
    apply (rule Sigma_fm_Iff)
    using k
    apply (auto intro!: Sigma_fm_All2_fresh simp add: assms fresh_Pair supp_conv_fresh fresh_at_base)
    done
qed

lemma Eq_Eats_sf:
  assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Var i EQ Eats t u)"
proof -
  obtain j::name and k::name and l::name
    where atoms: "atom j \<sharp> (t,u,i)" "atom k \<sharp> (t,u,i,j)" "atom l \<sharp> (t,u,i,j,k)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Var i EQ Eats t u IFF
              Ex j (Ex k (Var i EQ Eats (Var j) (Var k) AND Var j EQ t AND Var k EQ u))"
    apply auto
    apply (rule Ex_I [where x=t], simp)
    apply (rule Ex_I [where x=u], auto intro: Trans Eats_cong)
    done
  thus ?thesis
    apply (rule Sigma_fm_Iff)
    apply (auto simp: assms supp_at_base)
    apply (rule Sigma_fm_Iff [OF Eq_Eats_Iff [of l]])
    using atoms
    apply (auto simp: supp_conv_fresh fresh_at_base Var_Subset_sf
                intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
    done
qed

lemma Eats_Mem_sf:
  assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Eats t u IN Var i)"
proof -
  obtain j::name where j: "atom j \<sharp> (t,u,Var i)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Eats t u IN Var i IFF
              Ex j (Var j IN Var i AND Var j EQ Eats t u)"
    apply (auto simp: fresh_Pair intro: Ex_I [where x="Eats t u"])
    apply (metis Assume Mem_cong [OF _ Refl, THEN Iff_MP_same] rotate2)
    done
  thus ?thesis
    by (rule Sigma_fm_Iff) (auto simp: assms supp_conv_fresh Eq_Eats_sf)
qed

lemma Subset_Mem_sf_lemma:
  "size t + size u < n \<Longrightarrow> Sigma_fm (t SUBS u) \<and> Sigma_fm (t IN u)"
proof (induction n arbitrary: t u rule: less_induct)
  case (less n t u)
  show ?case
  proof
    show "Sigma_fm (t SUBS u)"
      proof (cases t rule: tm.exhaust)
        case Zero thus ?thesis
          by (auto intro: theorem_sf)
      next
        case (Var i) thus ?thesis using less.prems
          apply (cases u rule: tm.exhaust)
          apply (auto simp: Subset_Zero_sf Var_Subset_sf)
          apply (force simp: supp_conv_fresh less.IH
                       intro: Subset_Eats_sf Sigma_fm_Iff [OF Extensionality])
          done
      next
        case (Eats t1 t2) thus ?thesis using less.IH [OF _ ijk] less.prems
          by (auto intro!: Sigma_fm_Iff [OF Eats_Subset_Iff]  simp: supp_conv_fresh)
             (metis add.commute)
      qed
  next
    show "Sigma_fm (t IN u)"
      proof (cases u rule: tm.exhaust)
        case Zero show ?thesis
          by (rule Sigma_fm_Iff [where A=Fls]) (auto simp: supp_conv_fresh Zero)
      next
        case (Var i) show ?thesis
        proof (cases t rule: tm.exhaust)
          case Zero thus ?thesis using `u = Var i`
            by (auto intro: Zero_Mem_sf)
        next
          case (Var j)
          thus ?thesis using `u = Var i`
            by auto
        next
          case (Eats t1 t2) thus ?thesis using `u = Var i` less.prems
            by (force intro: Eats_Mem_sf Sigma_fm_Iff [OF Extensionality _ _]
                      simp: supp_conv_fresh less.IH [THEN conjunct1])
        qed
      next
        case (Eats t1 t2) thus ?thesis  using  less.prems
          by (force intro: Sigma_fm_Iff [OF Mem_Eats_Iff] Sigma_fm_Iff [OF Extensionality _ _]
                    simp: supp_conv_fresh less.IH)
      qed
  qed
qed

lemma Subset_sf [iff]: "Sigma_fm (t SUBS u)"
  by (metis Subset_Mem_sf_lemma [OF lessI])

lemma Mem_sf [iff]: "Sigma_fm (t IN u)"
  by (metis Subset_Mem_sf_lemma [OF lessI])

text {*The equality relation is a Sigma-Formula *}
lemma Equality_sf [iff]: "Sigma_fm (t EQ u)"
  by (auto intro: Sigma_fm_Iff [OF Extensionality] simp: supp_conv_fresh)

section{*Universal Quantification Bounded by an Arbitrary Term*}

lemma All2_term_Iff: "atom i \<sharp> t \<Longrightarrow> atom j \<sharp> (i,t,A) \<Longrightarrow>
                  {} \<turnstile> (All2 i t A) IFF Ex j (Var j EQ t AND All2 i (Var j) A)"
apply auto
apply (rule Ex_I [where x=t], auto)
apply (rule Ex_I [where x="Var i"])
apply (auto intro: ContraProve Mem_cong [THEN Iff_MP2_same])
done

lemma Sigma_fm_All2 [intro!]:
  assumes "Sigma_fm A" "atom i \<sharp> t"
    shows "Sigma_fm (All2 i t A)"
proof -
  obtain j::name where j: "atom j \<sharp> (i,t,A)"
    by (metis obtain_fresh)
  show "Sigma_fm (All2 i t A)"
    apply (rule Sigma_fm_Iff [OF All2_term_Iff [of i t j]])
    using assms j
    apply (auto simp: supp_conv_fresh Sigma_fm_All2_Var)
    done
qed

section {* Lemma 2.3: Sequence-related concepts are Sigma-formulas *}

lemma OrdP_sf [iff]: "Sigma_fm (OrdP t)"
proof -
  obtain z::name and y::name where "atom z \<sharp> t" "atom y \<sharp> (t, z)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: OrdP.simps)
qed

lemma OrdNotEqP_sf [iff]: "Sigma_fm (OrdNotEqP t u)"
  by (auto simp: OrdNotEqP.simps)

lemma HDomain_Incl_sf [iff]: "Sigma_fm (HDomain_Incl t u)"
proof -
  obtain x::name and y::name and z::name
    where "atom x \<sharp> (t,u,y,z)" "atom y \<sharp> (t,u,z)" "atom z \<sharp> (t,u)"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma HFun_Sigma_Iff:
  assumes "atom z \<sharp> (r,z',x,y,x',y')"  "atom z' \<sharp> (r,x,y,x',y')"
       "atom x \<sharp> (r,y,x',y')"  "atom y \<sharp> (r,x',y')"
       "atom x' \<sharp> (r,y')"  "atom y' \<sharp> (r)"
  shows
  "{} \<turnstile>HFun_Sigma r IFF
         All2 z r (All2 z' r (Ex x (Ex y (Ex x' (Ex y'
             (Var z EQ HPair (Var x) (Var y) AND Var z' EQ HPair (Var x') (Var y')
              AND OrdP (Var x) AND OrdP (Var x') AND
              ((Var x NEQ Var x') OR (Var y EQ Var y'))))))))"
  apply (simp add: HFun_Sigma.simps [OF assms])
  apply (rule Iff_refl All_cong Imp_cong Ex_cong)+
  apply (rule Conj_cong [OF Iff_refl])
  apply (rule Conj_cong [OF Iff_refl], auto)
  apply (blast intro: Disj_I1 Neg_D OrdNotEqP_I)
  apply (blast intro: Disj_I2)
  apply (blast intro: OrdNotEqP_E rotate2)
  done

lemma HFun_Sigma_sf [iff]: "Sigma_fm (HFun_Sigma t)"
proof -
  obtain x::name and y::name and z::name and x'::name and y'::name and z'::name
    where atoms: "atom z \<sharp> (t,z',x,y,x',y')"  "atom z' \<sharp> (t,x,y,x',y')"
       "atom x \<sharp> (t,y,x',y')"  "atom y \<sharp> (t,x',y')"
       "atom x' \<sharp> (t,y')"  "atom y' \<sharp> (t)"
    by (metis obtain_fresh)
  show ?thesis
    by (auto intro!: Sigma_fm_Iff [OF HFun_Sigma_Iff [OF atoms]] simp: supp_conv_fresh atoms)
qed

lemma LstSeqP_sf [iff]: "Sigma_fm (LstSeqP t u v)"
  by (auto simp: LstSeqP.simps)

section {* A Key Result: Theorem 2.5 *}

subsection {* Sigma-Eats Formulas*}

inductive se_fm :: "fm \<Rightarrow> bool" where
    MemI:  "se_fm (t IN u)"
  | DisjI: "se_fm A \<Longrightarrow> se_fm B \<Longrightarrow> se_fm (A OR B)"
  | ConjI: "se_fm A \<Longrightarrow> se_fm B \<Longrightarrow> se_fm (A AND B)"
  | ExI:   "se_fm A \<Longrightarrow> se_fm (Ex i A)"
  | All2I: "se_fm A \<Longrightarrow> atom i \<sharp> t \<Longrightarrow> se_fm (All2 i t A)"

equivariance se_fm

nominal_inductive se_fm
  avoids ExI: "i" | All2I: "i"
by (simp_all add: fresh_star_def)

declare se_fm.intros [intro]

lemma subst_fm_in_se_fm: "se_fm A \<Longrightarrow> se_fm (A(k::=x))"
by (nominal_induct avoiding: k x rule: se_fm.strong_induct) (auto)

subsection{*Preparation*}
text{*To begin, we require some facts connecting quantification and ground terms.*}

lemma obtain_const_tm:  obtains t where "\<lbrakk>t\<rbrakk>e = x" "ground t"
proof (induct x rule: hf_induct)
  case 0 thus ?case
    by (metis ground_aux_simps(1) eval_tm.simps(1))
next
  case (hinsert y x) thus ?case
    by (metis ground_aux_simps(3) eval_tm.simps(3))
qed

text{*In a negative context, the formulation above is actually weaker than this one.*}
lemma ex_eval_fm_iff_exists_tm':
  "eval_fm e (Ex k A) \<longleftrightarrow> (\<exists>t. eval_fm e (A(k::=t)))"
by (auto simp: eval_subst_fm) (metis obtain_const_tm)

text{*A ground term defines a finite set of ground terms, its elements.*}
nominal_function elts :: "tm \<Rightarrow> tm set" where
   "elts Zero       = {}"
 | "elts (Var k)    = {}"
 | "elts (Eats t u) = insert u (elts t)"
by (auto simp: eqvt_def elts_graph_aux_def) (metis tm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma eval_fm_All2_Eats:
  "atom i \<sharp> (t,u) \<Longrightarrow>
   eval_fm e (All2 i (Eats t u) A) \<longleftrightarrow> eval_fm e (A(i::=u)) \<and> eval_fm e (All2 i t A)"
  by (simp only: ex_eval_fm_iff_exists_tm' eval_fm.simps) (auto simp: eval_subst_fm)

text{*The term @{term t} must be ground, since @{term elts} doesn't handle variables.*}
lemma eval_fm_All2_Iff_elts:
  "ground t \<Longrightarrow> eval_fm e (All2 i t A) \<longleftrightarrow> (\<forall>u \<in> elts t. eval_fm e (A(i::=u)))"
apply (induct t rule: tm.induct)
apply auto [2]
apply (simp add: eval_fm_All2_Eats del: eval_fm.simps)
done

lemma prove_elts_imp_prove_All2:
   "ground t \<Longrightarrow> (\<And>u. u \<in> elts t \<Longrightarrow> {} \<turnstile> A(i::=u)) \<Longrightarrow> {} \<turnstile> All2 i t A"
proof (induct t rule: tm.induct)
  case Zero thus ?case
    by auto
next
  case (Var i) thus ?case  --{*again: vacuously!*}
    by simp
next
  case (Eats t u)
  hence pt: "{} \<turnstile> All2 i t A" and pu: "{} \<turnstile> A(i::=u)"
    by auto
  have "{} \<turnstile> ((Var i IN t) IMP A)(i ::= Var i)"
    by (rule All_D [OF pt])
  hence "{} \<turnstile> ((Var i IN t) IMP A)"
    by simp
  thus ?case using pu
    by (auto intro: anti_deduction) (metis Iff_MP_same Var_Eq_subst_Iff thin1)
qed

subsection{*The base cases: ground atomic formulas *}

lemma ground_prove:
   "\<lbrakk>size t + size u < n; ground t; ground u\<rbrakk>
    \<Longrightarrow> (\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t SUBS u) \<and> (\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t IN u)"
proof (induction n arbitrary: t u rule: less_induct)
  case (less n t u)
  show ?case
  proof
    show "\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t SUBS u" using less
      by (cases t rule: tm.exhaust) auto
  next
    { fix y t u
      have "\<lbrakk>y < n; size t + size u < y; ground t; ground u; \<lbrakk>t\<rbrakk>e = \<lbrakk>u\<rbrakk>e\<rbrakk>
           \<Longrightarrow> {} \<turnstile> t EQ u"
        by (metis Equality_I less.IH add.commute order_refl)
    }
    thus "\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t IN u" using less.prems
      by (cases u rule: tm.exhaust) (auto simp: Mem_Eats_I1 Mem_Eats_I2 less.IH)
  qed
qed

lemma
  assumes "ground t" "ground u"
    shows ground_prove_SUBS: "\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t SUBS u"
      and ground_prove_IN:   "\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t IN u"
      and ground_prove_EQ:   "\<lbrakk>t\<rbrakk>e = \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t EQ u"
  by (metis Equality_I assms ground_prove [OF lessI] order_refl)+

lemma ground_subst:
  "ground_aux tm (insert (atom i) S) \<Longrightarrow> ground t \<Longrightarrow> ground_aux (subst i t tm) S"
  by (induct tm rule: tm.induct) (auto simp: ground_aux_def)

lemma ground_subst_fm:
  "ground_fm_aux A (insert (atom i) S) \<Longrightarrow> ground t \<Longrightarrow> ground_fm_aux (A(i::=t)) S"
  apply (nominal_induct A avoiding: i arbitrary: S rule: fm.strong_induct)
  apply (auto simp: ground_subst Set.insert_commute)
  done

lemma elts_imp_ground: "u \<in> elts t \<Longrightarrow> ground_aux t S \<Longrightarrow> ground_aux u S"
  by (induct t rule: tm.induct) auto

lemma ground_se_fm_induction:
   "ground_fm \<alpha> \<Longrightarrow> size \<alpha> < n \<Longrightarrow> se_fm \<alpha> \<Longrightarrow> eval_fm e \<alpha> \<Longrightarrow> {} \<turnstile> \<alpha>"
proof (induction n arbitrary: \<alpha> rule: less_induct)
  case (less n \<alpha>)
  show ?case using `se_fm \<alpha>`
  proof (cases rule: se_fm.cases)
    case (MemI t u) thus "{} \<turnstile> \<alpha>" using less
      by (auto intro: ground_prove_IN)
  next
    case (DisjI A B) thus "{} \<turnstile> \<alpha>" using less
      by (auto intro: Disj_I1 Disj_I2)
  next
    case (ConjI A B) thus "{} \<turnstile> \<alpha>" using less
      by auto
  next
    case (ExI A i)
    thus "{} \<turnstile> \<alpha>" using less.prems
      apply (auto simp: ex_eval_fm_iff_exists_tm simp del: better_ex_eval_fm)
      apply (auto intro!: Ex_I less.IH subst_fm_in_se_fm ground_subst_fm)
      done
  next
    case (All2I A i t)
    hence t: "ground t" using less.prems
      by (auto simp: ground_aux_def fresh_def)
    hence "(\<forall>u\<in>elts t. eval_fm e (A(i::=u)))"
      by (metis All2I(1) t eval_fm_All2_Iff_elts less(5))
    thus "{} \<turnstile> \<alpha>" using less.prems All2I t
      apply (auto del: Neg_I intro!: prove_elts_imp_prove_All2 less.IH)
      apply (auto intro: subst_fm_in_se_fm ground_subst_fm elts_imp_ground)
      done
  qed
qed

lemma se_fm_imp_thm: "\<lbrakk>se_fm A; ground_fm A; eval_fm e A\<rbrakk> \<Longrightarrow> {} \<turnstile> A"
  by (metis ground_se_fm_induction lessI)

text{*Theorem 2.5*}
theorem Sigma_fm_imp_thm: "\<lbrakk>Sigma_fm A; ground_fm A; eval_fm e0 A\<rbrakk> \<Longrightarrow> {} \<turnstile> A"
  by (metis Iff_MP2_same ss_imp_se_fm empty_iff Sigma_fm_def eval_fm_Iff ground_fm_aux_def
            hfthm_sound se_fm_imp_thm subset_empty)

end


theory Words
  imports Main "HOL-Library.Sublist" "HOL-Library.List_Lexorder" HOL.Groups "HOL-Library.Multiset"
begin

type_synonym 'a word = "'a list"

no_notation append (infixr "@" 65)
notation append (infixr "\<cdot>" 65)
notation Nil ("\<epsilon>")

notation length ("\<bar>_\<bar>")
no_notation Groups.abs_class.abs ("\<bar>_\<bar>")

instantiation char::linorder begin

(* Just for convenience, so we can use literal chars for testing *)
definition less_char::"char \<Rightarrow> char \<Rightarrow> bool" where
  "less_char a b \<equiv> ((of_char a)::nat) < ((of_char b)::nat)"

definition less_eq_char::"char \<Rightarrow> char \<Rightarrow> bool" where
  "less_eq_char a b \<equiv> ((of_char a)::nat) \<le> ((of_char b)::nat)"

instance apply(standard)
  using less_char_def less_eq_char_def by auto

end

primrec concat_all:: "'a word list \<Rightarrow> 'a word" where
  "concat_all [] = \<epsilon>" |
  "concat_all (w#ws) = w\<cdot>(concat_all ws)"

fun factor:: "'a word \<Rightarrow> 'a word \<Rightarrow> bool" where
  "factor v w = sublist v w"

fun get_factor:: "'a word \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a word" ("_[_;_]" 101) where
  "get_factor w i j = (if i \<le> j then take (j-i) (drop i w) else \<epsilon>)"

primrec contains:: "'a word \<Rightarrow> 'a word \<Rightarrow> bool" where
  "contains \<epsilon> v = (v = \<epsilon>)" |
  "contains (x#u) v = ((prefix v (x#u)) \<or> (contains u v))"

fun indexof_0:: "'a word \<Rightarrow> 'a word \<Rightarrow> nat" where
  "indexof_0 (c#w) v = (if prefix v (c#w) then 0 else Suc (indexof_0 w v))"
| "indexof_0 [] v = 0"

fun indexof_nat:: "'a word \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> nat" where
  "indexof_nat w v n = n + indexof_0 (drop n w) v"

fun indexof:: "'a word \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> nat option" where
  "indexof w v i = (if (factor v  (w[i;\<bar>w\<bar>])) \<and> i\<le>\<bar>w\<bar> then Some (indexof_nat w v i) else None)"

fun replace:: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word" where
  "replace w v u = (case indexof w v 0 of Some i \<Rightarrow> (take i w)\<cdot>u\<cdot>(drop (i+(length v)) w) | None => w)"

subsection "Factorization"

lemma drop_append:
  assumes "n \<le> \<bar>w\<bar> \<and> x = drop n w"
  shows "\<exists>v. ((w = v\<cdot>x) \<and> (length v) = n)"
  using assms
proof (induct w)
  case Nil
  then show ?case
    by auto
next
  case (Cons a w)
  then show ?case
    by (metis antisym append_take_drop_id length_take min_def)
qed

lemma factor_iff: "factor v w \<longleftrightarrow> (\<exists>i. v = (w[i; i+\<bar>v\<bar>]))"
proof
  show "factor v w \<Longrightarrow> \<exists>i. v = (w[i;i + \<bar>v\<bar>])"
    unfolding factor.simps get_factor.simps
    by (metis append_eq_conv_conj diff_add_inverse le_add1 sublist_def)
next
  show "\<exists>i. v = (w[i;i + \<bar>v\<bar>]) \<Longrightarrow> factor v w"
    unfolding factor.simps get_factor.simps
    by (metis le_add1 sublist_drop sublist_order.order.trans sublist_take)
qed

lemma factorization:
  assumes "i < \<bar>w\<bar>"
    and "i \<le> j"
  shows "\<exists>!v. (w[i; j]) = v \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> \<bar>x\<bar> = i \<and> \<bar>v\<bar> = min (j-i) (\<bar>w\<bar>-i))"
proof -
  have "\<exists>!v. take (j - i) (drop i w) = v \<and> (\<exists>x. (\<exists>y. w = x \<cdot> v \<cdot> y) \<and> \<bar>x\<bar> = i
          \<and> \<bar>v\<bar> = min (j - i) (\<bar>w\<bar> - i))"
    using assms by (metis  append_take_drop_id length_drop length_take min.absorb4 min.commute)
  then show ?thesis
    using assms by (simp split: if_splits)
qed

lemma factorize_if:"w = x\<cdot>v\<cdot>y \<Longrightarrow> w[\<bar>x\<bar>; \<bar>x\<bar>+\<bar>v\<bar>] = v" by auto

lemma prefix_iff_fac: "prefix v w \<longleftrightarrow> (w[0; \<bar>v\<bar>] = v)"
  by (metis append_eq_conv_conj diff_zero drop0 get_factor.elims prefix_def zero_order(1))

lemma suffix_iff_fac: "suffix v w \<longleftrightarrow> (w[\<bar>w\<bar> - \<bar>v\<bar>; \<bar>w\<bar>] = v)"
proof
  show "suffix v w \<Longrightarrow> w[\<bar>w\<bar> - \<bar>v\<bar>;\<bar>w\<bar>] = v"
    unfolding suffix_def by auto
next
  show "w[\<bar>w\<bar> - \<bar>v\<bar>;\<bar>w\<bar>] = v \<Longrightarrow> suffix v w"
    by (metis diff_le_self get_factor.simps length_drop order_le_less suffix_drop take_all)
qed

lemma get_factor_01_is_take1: "w[0;1] = take 1 w"
  by auto

lemma empty_factor_if_i_geq_j: "i \<ge> j \<Longrightarrow> w[i;j] = \<epsilon>"
  by auto

lemma empty_factor_if_i_geq_length: "i \<ge> (length w) \<Longrightarrow> w[i;j] = \<epsilon>"
  by auto

lemma factor_epsilon: "\<epsilon>[i;j] = \<epsilon>"
  by auto

lemma factor_suffix: "\<bar>w\<bar> \<le> m \<Longrightarrow> w[i; m] = drop i w"
  by auto

lemma factor_len_0: "w[i;i] = \<epsilon>"
  by auto

lemma factor_is_word_if_j_geq_length: "j \<ge> (length w) \<Longrightarrow> w[0;j] = w"
  by auto

lemma fac_nth:"i < (length w) \<Longrightarrow> w[i; i+1] = (w!i)#\<epsilon>"
  by (simp add: take_Suc_conv_app_nth)

lemma contains_iff_factor:"contains w v \<longleftrightarrow> factor v w"
  by (induct w) (auto simp add: sublist_Cons_right)

lemma not_contains_no_fac_has_prefix:"(\<not>contains w d) \<Longrightarrow> w = x\<cdot>y \<Longrightarrow> (\<not> prefix d y)"
  by (auto simp add: contains_iff_factor sublist_append)

lemma if_contains_then_fac_has_prefix:"(contains w d) \<Longrightarrow> \<exists>x y. w = x\<cdot>y \<and> (prefix d y)"
  by (auto simp add: contains_iff_factor prefix_def sublist_def)

lemma epsilon_contains_epsilon[simp]: "contains \<epsilon> v \<Longrightarrow> v = \<epsilon>"
  by auto

subsection "Searching and Replacing Factors"

lemma indexof_if_not_contains:"\<not> (factor v (w[i; \<bar>w\<bar>])) \<Longrightarrow> indexof w v i = None"
  by simp

lemma indexof_if_not_contains''':"\<not> (factor v  (w[i; \<bar>w\<bar>])) \<Longrightarrow> indexof w v i = None"
  by simp

lemma indexof_if_contains: "i\<ge>0 \<Longrightarrow> i\<le>\<bar>w\<bar> \<Longrightarrow> factor v (w[i; \<bar>w\<bar>]) \<Longrightarrow> \<exists>r. indexof w v i = Some r"
  by auto

lemma indexof_if_contains''': "i\<ge>0 \<Longrightarrow> i\<le>\<bar>w\<bar> \<Longrightarrow> factor v (w[i; \<bar>w\<bar>]) \<Longrightarrow> \<exists>r. indexof w v i =  Some r"
  by simp

lemma indexof_Some_iff: "indexof w v i = Some r \<longleftrightarrow> (factor v  (w[i;\<bar>w\<bar>])) \<and> i\<le>\<bar>w\<bar> \<and> r = (indexof_nat w v i)"
  by(auto split: if_splits)

theorem indexof_01:
  assumes "factor v w"
  shows "\<exists>n. (indexof_0 w v) =  n \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> n = \<bar>x\<bar>) \<and> (\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> n' = \<bar>x\<bar> ) \<longrightarrow> n \<le> n')"
  using assms
proof (induction w)
  case Nil
  then show ?case
    by auto
next
  case (Cons a w)
  then have split: "prefix v (a # w) \<or> (\<not>prefix v (a # w) \<and> sublist v w)"
    by (metis contains.simps(2) contains_iff_factor factor.elims(2))
  then have "(\<exists>x y. a # w = append x (append v y) \<and> indexof_0 (a # w) v = length x)"
  proof
    assume "prefix v (a # w)"
    then have "indexof_0 (a # w) v = 0"
      by auto
    moreover
    have "\<exists>y. a # w = (append v y)"
      using \<open>prefix v (a # w)\<close> prefix_def by auto
    ultimately
    have "(\<exists>y. a # w = (append v y) \<and> indexof_0 (a # w) v = 0)"
      by auto
    then show "(\<exists>x y. a # w = append x (append v y) \<and> indexof_0 (a # w) v = length x)"
      by auto
  next
    assume "\<not> prefix v (a # w) \<and> sublist v w"
    then have "(\<exists>x y. w = x\<cdot>v\<cdot>y \<and> (indexof_0 w v) = length x)"
      using Cons(1) by auto
    then show "(\<exists>x y. a # w = x\<cdot> (v\<cdot> y) \<and> indexof_0 (a # w) v = length x)"
      by (metis \<open>\<not> prefix v (a # w) \<and> sublist v w\<close> add.right_neutral add_Suc_right append_Cons list.size(4) indexof_0.simps(1))
  qed
  moreover
  have "(\<forall>n'. (\<exists>x y. a # w = x\<cdot> (v\<cdot> y) \<and> n' = length x) \<longrightarrow> indexof_0 (a # w) v \<le> n')"
  proof (rule, rule)
    fix n'
    assume "\<exists>x y. (a # w = x\<cdot> (v\<cdot> y) \<and> n' = length x)"
    then obtain x y where x_y_p: "a # w = x\<cdot>(v\<cdot> y) \<and> n' = length x"
      by auto
    from split show "indexof_0 (a # w) v \<le> n'"
    proof
      assume "prefix v (a # w)"
      show "indexof_0 (a # w) v \<le> n'"
        by (simp add: \<open>prefix v (a # w)\<close>)
    next
      assume a: "\<not> prefix v (a # w) \<and> sublist v w "
      have n'_gr_0: "n' > 0"
        using \<open>a # w = append x (append v y) \<and> n' = length x\<close> a by force
      from a have "indexof_0 (a # w) v = Suc (indexof_0 w v)"
        by auto
      from a have "\<exists>n. (indexof_0 w v) =  n \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> n = \<bar>x\<bar>) \<and> (\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> n' = \<bar>x\<bar> ) \<longrightarrow> n \<le> n')"
        using Cons by auto
      then have "(\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> n' = length x) \<longrightarrow> (indexof_0 w v) \<le> n')"
        by auto
      then have "(\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> Suc n' = length (a#x)) \<longrightarrow> indexof_0 (a # w) v \<le> Suc n')"
        by auto
      then show "indexof_0 (a # w) v \<le> n'"
        by (smt (verit, ccfv_SIG) n'_gr_0 x_y_p a append_eq_Cons_conv gr0_implies_Suc prefixI)
    qed
  qed
  ultimately
  show ?case
    by auto
qed

theorem str_indexof_nat1:
  assumes "i\<le> length w" and "factor v (drop i w)"
  shows "\<exists>n. indexof_nat w v i = n \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> n \<and> n = length x) \<and> (\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> n' \<and> n' = length x)  \<longrightarrow> n \<le> n')"
proof -
  have sm: "\<exists>n. (indexof_0 (drop i w) v) =  n \<and> (\<exists>x y. (drop i w) = x\<cdot>v\<cdot>y \<and> n = \<bar>x\<bar>) \<and> (\<forall>n'. (\<exists>x y. (drop i w) = x\<cdot>v\<cdot>y \<and> n' = \<bar>x\<bar> ) \<longrightarrow> n \<le> n')"
    using assms indexof_01 by blast
  then have "\<exists>x y. (drop i w) = x\<cdot>v\<cdot>y \<and> (indexof_0 (drop i w) v) = length x"
    by auto
  then obtain x y where x_y_p: "(drop i w) = x\<cdot>v\<cdot>y \<and> (indexof_0 (drop i w) v) = length x"
    by auto
  define x' where "x' = take i w \<cdot> x"
  {
    have a: "w = x'\<cdot>v\<cdot>y"
      by (metis x_y_p append_assoc append_take_drop_id x'_def)
    moreover
    have b: "i \<le> (i + indexof_0 (drop i w) v)"
      by auto
    moreover
    have c: "i + indexof_0 (drop i w) v = length x'"
      using assms(1) x'_def x_y_p by fastforce
    ultimately
    have "(\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> (i + indexof_0 (drop i w) v) \<and> (i + indexof_0 (drop i w) v) = length x)"
      by metis
  }
  moreover
  have "\<forall>n. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> n \<and> n = length x) \<longrightarrow> (i + indexof_0 (drop i w) v) \<le> n"
  proof (rule, rule)
    fix n
    assume "(\<exists>x'' y''. w = x''\<cdot>v\<cdot>y'' \<and> i \<le> n \<and> n = length x'')"
    then obtain x'' y'' where x''_y''_p:
      "w = x''\<cdot>v\<cdot>y''"
      "i \<le> n"
      "n = length x''"
      by auto
    define x''' where "x''' = drop i x''"
    have drop_w_split: "(drop i w) = drop i x'' \<cdot> v\<cdot>y''"
      using x''_y''_p by force
    have "\<forall>n. (\<exists>x y. (drop i w) = x\<cdot>v\<cdot>y \<and> n = length x) \<longrightarrow> indexof_0 (drop i w) v \<le> n"
      using sm by auto
    then show "(i + indexof_0 (drop i w) v) \<le> n"
      using drop_w_split x''_y''_p(2) x''_y''_p(3) by fastforce
  qed
  ultimately
  (*have "smallest_int (i + indexof_0 (drop i w)  v) (\<lambda>n. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> n \<and> n = length x))"*)
  have "(\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> (i + indexof_0 (drop i w)  v) \<and> (i + indexof_0 (drop i w)  v) = length x) \<and> (\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> i \<le> n' \<and> n' = length x) \<longrightarrow> (i + indexof_0 (drop i w)  v)\<le>n')"
    by auto
  then show ?thesis
   by simp
qed

lemma indexof_Some_iff_factor: "\<exists>r. indexof w v 0 = Some r \<longleftrightarrow> factor v w"
  by(auto split: if_splits)

lemma replace_epsilon: "replace w \<epsilon> u = u\<cdot>w"
  apply(auto simp add: option.case_eq_if)
  by (metis append_self_conv2 append_take_drop_id indexof_0.elims prefix_bot.bot_least take_eq_Nil2)

lemma replace_id_if_not_contains: "\<not>contains w v \<Longrightarrow> replace w v u = w"
  using contains_iff_factor by auto

theorem replace_factor: "contains w v \<Longrightarrow> \<exists>x y. (w= x\<cdot>v\<cdot>y \<and> replace w v u = x\<cdot>u\<cdot>y)"
  apply(auto simp add: option.case_eq_if prefix_def )
   apply (metis append.assoc append_eq_conv_conj factor.elims(3) indexof_01 length_append)
  by (simp add: contains_iff_factor)

theorem replace_first_factor: "contains w v \<Longrightarrow> \<exists>x y. replace w v u = x\<cdot>u\<cdot>y \<and> w = x\<cdot>v\<cdot>y \<and> (\<forall> x'. (\<exists>y'. w=x'\<cdot>v\<cdot>y') \<longrightarrow> \<bar>x\<bar> \<le> \<bar>x'\<bar>)"
proof -
  assume "contains w v"
  then have "factor v w" using contains_iff_factor by auto
  then have "\<exists>n. indexof_nat w v 0 = n \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> 0 \<le> n \<and> n = \<bar>x\<bar>) \<and> (\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> 0 \<le> n' \<and> n' = \<bar>x\<bar>)  \<longrightarrow> n \<le> n')"
    by (metis bot_nat_0.extremum drop0 str_indexof_nat1)
  then obtain n where "indexof_nat w v 0 = n \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> n = \<bar>x\<bar>) \<and> (\<forall>n'. (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> 0 \<le> n' \<and> n' = \<bar>x\<bar>)  \<longrightarrow> n \<le> n')" by blast
  then have "replace w v u = (take n w)\<cdot>u\<cdot>(drop (n+\<bar>v\<bar>) w) \<and> (\<exists>x y. w = x\<cdot>v\<cdot>y \<and> n = \<bar>x\<bar>) \<and> (\<forall>n'. (\<exists>x' y'. w = x'\<cdot>v\<cdot>y' \<and> 0 \<le> n' \<and> n' = \<bar>x'\<bar>)  \<longrightarrow> n \<le> n')" by auto
  then have "\<exists>x y. replace w v u = x\<cdot>u\<cdot>y \<and> n = \<bar>x\<bar> \<and>  w = x\<cdot>v\<cdot>y \<and> (\<forall>n'. (\<exists>x' y'. w = x'\<cdot>v\<cdot>y' \<and> 0 \<le> n' \<and> n' = \<bar>x'\<bar>)  \<longrightarrow> n \<le> n')"
    by (metis append.assoc append_eq_conv_conj length_append)
  then have "\<exists>x y. replace w v u = x\<cdot>u\<cdot>y \<and>  w = x\<cdot>v\<cdot>y \<and> (\<forall>n'. (\<exists>x' y'. w = x'\<cdot>v\<cdot>y' \<and> 0 \<le> n' \<and> n' = \<bar>x'\<bar>)  \<longrightarrow> \<bar>x\<bar> \<le> n')" by metis
  then show ?thesis by blast
qed

end


section "Formula"

theory Formula
imports Base
begin

subsection "Variables"

datatype vbl = X nat
  \<comment> \<open>FIXME there's a lot of stuff about this datatype that is
  really just a lifting from nat (what else could it be). Makes me
  wonder whether things wouldn't be clearer is we just identified vbls
  with nats\<close>

primrec deX :: "vbl => nat" where "deX (X n) = n"

lemma X_deX[simp]: "X (deX a) = a"
  by(cases a) simp

definition "zeroX = X 0"

primrec
  nextX :: "vbl => vbl" where
  "nextX (X n) = X (Suc n)"

definition
  vblcase :: "['a,vbl => 'a,vbl] => 'a" where
  "vblcase a f n = (@z. (n=zeroX \<longrightarrow> z=a) \<and> (!x. n=nextX x \<longrightarrow> z=f(x)))"

declare [[case_translation vblcase zeroX nextX]]

definition
  freshVar :: "vbl set => vbl" where
  "freshVar vs = X (LEAST n. n \<notin> deX ` vs)"

lemma nextX_nextX[iff]: "nextX x = nextX y = (x =  y)"
  by(cases x, cases y) auto

lemma inj_nextX: "inj nextX"
  by(auto simp add: inj_on_def)

lemma ind': "P zeroX ==> (! v . P v --> P (nextX v)) ==> P v'"
  apply (case_tac v', simp)
  apply(rename_tac nat)
  apply(induct_tac nat)
   apply(simp add: zeroX_def)
  apply(rename_tac n)
  apply (drule_tac x="X n" in spec, simp)
  done

lemma ind: "\<lbrakk> P zeroX; \<And> v. P v \<Longrightarrow> P (nextX v) \<rbrakk> \<Longrightarrow> P v'"
  apply(rule ind') by auto

lemma zeroX_nextX[iff]: "zeroX ~= nextX a" \<comment> \<open>FIXME iff?\<close>
  apply(case_tac a)
  apply(simp add: zeroX_def)
  done

lemmas nextX_zeroX[iff] = not_sym[OF zeroX_nextX]

lemma nextX: "nextX (X n) = X (Suc n)"
  apply simp done

lemma vblcase_zeroX[simp]: "vblcase a b zeroX = a"
  by(simp add: vblcase_def)

lemma vblcase_nextX[simp]: "vblcase a b (nextX n) = b n"
  by(simp add: vblcase_def)

lemma vbl_cases: "x = zeroX | (? y . x = nextX y)"
  apply(case_tac x, rename_tac m)
  apply(case_tac m)
  apply(simp add: zeroX_def)
  apply(rule disjI2)
  apply (rule_tac x="X nat" in exI, simp)
  done

lemma vbl_casesE: "\<lbrakk> x = zeroX \<Longrightarrow> P; \<And> y. x = nextX y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply(auto intro: vbl_cases[elim_format]) done

lemma comp_vblcase: "f o vblcase a b = vblcase (f a) (f o b)"
  apply(rule ext)
  apply(rule_tac x = x in vbl_casesE)
   apply(simp_all add: vblcase_zeroX vblcase_nextX)
  done

lemma equalOn_vblcaseI': "equalOn (preImage nextX A) f g ==> equalOn A (vblcase x f) (vblcase x g)"
  apply(simp add: equalOn_def)
  apply(rule+)
  apply (case_tac xa rule: vbl_casesE, simp, simp)
  apply(drule_tac x=y in bspec)
  apply(simp add: preImage_def)
  by assumption

lemma equalOn_vblcaseI: "(zeroX : A --> x=y) ==> equalOn (preImage nextX A) f g ==> equalOn A (vblcase x f) (vblcase y g)"
  apply (rule equalOnI, rule)
  apply (case_tac xa rule: vbl_casesE, simp, simp)
  apply(simp add: preImage_def equalOn_def)
  done

lemma X_deX_connection: "X n : A = (n : (deX ` A))"
  by force

lemma finiteFreshVar: "finite A ==> freshVar A ~: A"
  apply(simp add: freshVar_def)
  apply(simp add: X_deX_connection)
  apply(rule_tac LeastI_ex)
  apply(rule_tac x="(Suc (Max (deX ` A)))" in exI)
  apply(rule natset_finite_max)
  by force

lemma freshVarI: "[| finite A; B <= A |] ==> freshVar A ~: B"
  apply(auto dest!: finiteFreshVar) done

lemma freshVarI2: "finite A ==> !x . x ~: A --> P x ==> P (freshVar A)"
  apply(auto dest!: finiteFreshVar) done

lemmas vblsimps = vblcase_zeroX vblcase_nextX zeroX_nextX
  nextX_zeroX nextX_nextX comp_vblcase

subsection "Predicates"

datatype predicate = Predicate nat

datatype signs = Pos | Neg

lemma signsE: "\<lbrakk> signs = Neg \<Longrightarrow> P; signs = Pos \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply(cases signs, auto) done

lemma expand_case_signs: "Q(case_signs vpos vneg F) = (
  (F = Pos --> Q (vpos)) &
  (F = Neg --> Q (vneg))
 )"
  by(induct F) simp_all

primrec sign :: "signs \<Rightarrow> bool \<Rightarrow> bool"
where
  "sign Pos x = x"
| "sign Neg x = (\<not> x)"

lemma sign_arg_cong: "x = y ==> sign z x = sign z y" by simp

primrec invSign :: "signs \<Rightarrow> signs"
where
  "invSign Pos = Neg"
| "invSign Neg = Pos"

subsection "Formulas"

datatype formula =
    FAtom signs predicate "(vbl list)"
  | FConj signs formula formula
  | FAll  signs formula

subsection "formula signs induct, formula signs cases"

lemma formula_signs_induct: "[|
  ! p vs. P (FAtom Pos p vs);
  ! p vs. P (FAtom Neg p vs);
  !! A B  . [| P A; P B |] ==> P (FConj Pos A B);
  !! A B  . [| P A; P B |] ==> P (FConj Neg A B);
  !! A    . [| P A |] ==> P (FAll  Pos A);
  !! A    . [| P A |] ==> P (FAll  Neg A)
  |]
  ==> P A"
  apply(induct_tac A)
  apply(rule signs.induct, force, force)+
  done

lemma formula_signs_cases: "!!P.
  [| !! p vs . P (FAtom Pos p vs);
  !! p vs . P (FAtom Neg p vs);
  !! f1 f2  . P (FConj Pos f1 f2);
  !! f1 f2  . P (FConj Neg f1 f2);
  !! f1    . P (FAll  Pos f1);
  !! f1    . P (FAll  Neg f1) |]
  ==> P A"
  apply(induct_tac A)
  apply(rule signs.induct, force, force)+
  done

    \<comment> \<open>induction using nat induction, not wellfounded induction\<close>
lemma strong_formula_induct': "!A. (! B. size B < size A --> P B) --> P A ==> ! A. size A = n --> P (A::formula)"
  by (induct_tac n rule: nat_less_induct, blast)

lemma strong_formula_induct: "(! A. (! B. size B < size A --> P B) --> P A) ==> P (A::formula)"
 by (rule strong_formula_induct'[rule_format], blast+)

lemma sizelemmas: "size A < size (FConj z A B)"
  "size B < size (FConj z A B)"
  "size A < size (FAll  z A)"
  by auto

lemma expand_case_formula:
  "Q(case_formula fatom fconj fall F) = (
  (! z P vs  . F = FAtom z P vs  --> Q (fatom z P vs)) &
  (! z A0 A1 . F = FConj z A0 A1 --> Q (fconj z A0 A1)) &
  (! z A     . F = FAll  z A     --> Q (fall  z A))
 )"
  apply(cases F) apply simp_all done

primrec FNot :: "formula => formula"
where
  FNot_FAtom: "FNot (FAtom z P vs)  = FAtom (invSign z) P vs"
| FNot_FConj: "FNot (FConj z A0 A1) = FConj (invSign z) (FNot A0) (FNot A1)"
| FNot_FAll:  "FNot (FAll  z body)  = FAll  (invSign z) (FNot body)"

primrec neg  :: "signs => signs"
where
  "neg Pos = Neg"
| "neg Neg = Pos"

primrec
  dual :: "[(signs => signs),(signs => signs),(signs => signs)] => formula => formula"
where
  dual_FAtom: "dual p q r (FAtom z P vs)  = FAtom (p z) P vs"
| dual_FConj: "dual p q r (FConj z A0 A1) = FConj (q z) (dual p q r A0) (dual p q r A1)"
| dual_FAll:  "dual p q r (FAll  z body)  = FAll  (r z) (dual p q r body)"

lemma dualCompose: "dual p q r o dual P Q R = dual (p o P) (q o Q) (r o R)"
  apply(rule ext)
  apply (induct_tac x, auto)
  done

lemma dualFNot': "dual invSign invSign invSign = FNot"
  apply(rule ext)
  apply(induct_tac x)
  apply auto
  done

lemma dualFNot: "dual invSign id id (FNot A) = FNot (dual invSign id id A)"
  by(induct A) (auto simp: id_def)

lemma dualId: "dual id id id A = A"
  by(induct A) (auto simp: id_def)

subsection "Frees"

primrec freeVarsF  :: "formula => vbl set"
where
  freeVarsFAtom: "freeVarsF (FAtom z P vs)  = set vs"
| freeVarsFConj: "freeVarsF (FConj z A0 A1) = (freeVarsF A0) Un (freeVarsF A1)"
| freeVarsFAll:  "freeVarsF (FAll  z body)  = preImage nextX (freeVarsF body)"

definition
  freeVarsFL :: "formula list => vbl set" where
  "freeVarsFL gamma = Union (freeVarsF ` (set gamma))"

lemma freeVarsF_FNot[simp]: "freeVarsF (FNot A) = freeVarsF A"
  by(induct A) auto

lemma freeVarsFL_nil[simp]: "freeVarsFL ([]) = {}"
  by(simp add: freeVarsFL_def)

lemma freeVarsFL_cons: "freeVarsFL (A#Gamma) = freeVarsF A \<union> freeVarsFL Gamma"
  by(simp add: freeVarsFL_def)
    \<comment> \<open>FIXME not simp, since simp stops some later lemmas because the simpset isn't confluent\<close>

lemma finite_freeVarsFL[simp]: "finite (freeVarsFL gamma)"
  by(induct gamma) (auto simp: freeVarsFL_cons)

lemma freeVarsDual: "freeVarsF (dual p q r A) = freeVarsF A"
  by(induct A) auto

subsection "Substitutions"

primrec subF :: "[vbl => vbl,formula] => formula"
where
  subFAtom: "subF theta (FAtom z P vs)  = FAtom z P (map theta vs)"
| subFConj: "subF theta (FConj z A0 A1) = FConj z (subF theta A0) (subF theta A1)"
| subFAll: "subF theta (FAll z body)  =
  FAll  z (subF (% v . (case v of zeroX => zeroX | nextX v => nextX (theta v))) body)"

lemma size_subF: "!!theta. size (subF theta A) = size (A::formula)"
  by(induct A) auto

lemma subFNot: "!!theta. subF theta (FNot A) = FNot (subF theta A)"
  by(induct A) auto

lemma subFDual: "!!theta. subF theta (dual p q r A) = dual p q r (subF theta A)"
  by(induct A) auto

definition
  instanceF :: "[vbl,formula] => formula" where
  "instanceF w body = subF (%v. case v of zeroX => w | nextX v => v) body"

lemma size_instance: "!!v. size (instanceF v A) = size (A::formula)"
  by(induct A) (auto simp: instanceF_def size_subF)

lemma instanceFDual: "instanceF u (dual p q r A) = dual p q r (instanceF u A)"
  by(induct A) (simp_all add: instanceF_def subFDual)

subsection "Models"

typedecl
  object

axiomatization obj :: "nat => object"
where inj_obj: "inj obj"

subsection "model, non empty set and positive atom valuation"

definition "model = {z :: (object set * ([predicate,object list] => bool)). (fst z ~= {})}"

typedef model = model
  unfolding model_def by auto

definition
  objects :: "model => object set" where
  "objects M = fst (Rep_model M)"

definition
  evalP :: "model => predicate => object list => bool" where
  "evalP M = snd (Rep_model M)"

lemma evalP_arg2_cong: "x = y ==> evalP M p x = evalP M p y" by simp

lemma objectsNonEmpty: "objects M \<noteq> {}"
  using Rep_model[of M]
  by(simp add: objects_def model_def)

lemma modelsNonEmptyI: "fst (Rep_model M) \<noteq> {}"
  using Rep_model[of M] by(simp add: objects_def model_def)

subsection "Validity"

primrec evalF :: "[model,vbl => object,formula] => bool"
where
  evalFAtom: "evalF M phi (FAtom z P vs)  = sign z (evalP M P (map phi vs))"
| evalFConj: "evalF M phi (FConj z A0 A1) = sign z (sign z (evalF M phi A0) & sign z (evalF M phi A1))"
| evalFAll:  "evalF M phi (FAll  z body)  = sign z (!x: (objects M).
                                                       sign z
                                                            (evalF M (%v . (case v of
                                                                                zeroX   => x
                                                                              | nextX v => phi v)) body))"

definition
  valid :: "formula => bool" where
  "valid F \<longleftrightarrow> (\<forall>M phi. evalF M phi F = True)"

lemma evalF_FAll: "evalF M phi (FAll Pos A) = (!x: (objects M). (evalF M (vblcase x (%v .phi v)) A))"
  by simp

lemma evalF_FEx: "evalF M phi (FAll Neg A) = ( ? x:(objects M). (evalF M (vblcase x (%v. phi v)) A))"
  by simp

lemma evalF_arg2_cong: "x = y ==> evalF M p x = evalF M p y" by simp

lemma evalF_FNot: "!!phi. evalF M phi (FNot A) = (\<not> evalF M phi A)"
  by(induct A rule: formula_signs_induct) simp_all

lemma evalF_equiv[rule_format]: "! f g. (equalOn (freeVarsF A) f g) \<longrightarrow> (evalF M f A = evalF M g A)"
  apply(induct A)
    apply (force simp:equalOn_def cong: map_cong, clarify) apply simp apply(drule_tac equalOn_UnD) apply force
  apply clarify apply simp apply(rename_tac signs A f g) apply(rule_tac f = "sign signs" in arg_cong) apply(rule ball_cong) apply rule
  apply(rule_tac f = "sign signs" in arg_cong) apply(force intro: equalOn_vblcaseI')
  done
    \<comment> \<open>FIXME tricky to automate cong args convincingly?\<close>

    \<comment> \<open>composition of substitutions\<close>
lemma evalF_subF_eq: "!phi theta. evalF M phi (subF theta A) = evalF M (phi o theta) A"
  apply(induct_tac A)
    apply(simp del: o_apply)
   apply(simp del: o_apply)
  apply(intro allI)
  apply(simp del: o_apply)
  apply(rename_tac signs phi0 phi theta)
  apply(rule_tac f="sign signs" in arg_cong)
  apply(rule ball_cong) apply rule
  apply(rule_tac f="sign signs" in arg_cong)
  apply(subgoal_tac "(vblcase x phi \<circ> vblcase zeroX (\<lambda>v. nextX (theta v))) = (vblcase x (phi \<circ> theta))")
  apply(simp del: o_apply)
  apply(rule ext)
  apply (case_tac xa rule: vbl_casesE, simp, simp)
  done

lemma o_id'[simp]: "f o (% x. x) = f"
by (fold id_def, simp)

lemma evalF_instance: "evalF M phi (instanceF u A) = evalF M (vblcase (phi u) phi) A"
  apply(simp add: instanceF_def evalF_subF_eq vblsimps)
  done

\<comment> \<open>FIXME move\<close>

lemma s[simp]:" FConj signs formula1 formula2 \<noteq> formula1"
  apply(induct_tac formula1, auto) done

lemma s'[simp]:" FConj signs formula1 formula2 \<noteq> formula2"
  apply(induct formula2, auto) done

lemma instanceF_E: "instanceF g formula \<noteq> FAll signs formula"
  apply clarify
  apply(subgoal_tac "Suc (size (instanceF g formula)) = (size (FAll signs formula))")
  apply force
  apply(simp (no_asm) only: size_instance[rule_format])
  apply simp done

end


theory Misc
  imports "HOL-Library.Extended_Real"
begin

section \<open>nat\<close>

lemma less_implies_Suc_le:
  assumes "n \<le> m"
  assumes "n \<noteq> m"
  shows "Suc n \<le> m"
  using assms
  by simp

section \<open>list\<close>

lemma list_length_1:
  assumes "length l = Suc 0"
  assumes "x = hd l"
  assumes "y = last l"
  shows "l = [x] \<and> x = y"
  using assms
  by (auto simp add: length_Suc_conv)

lemma list_length_2:
  assumes "length l = Suc (Suc 0)"
  assumes "x = hd l"
  assumes "y = last l"
  shows "l = [x, y]"
  using assms
  by (auto simp add: length_Suc_conv)

lemma tl_non_empty_conv:
  shows "tl l \<noteq> [] \<longleftrightarrow> Suc 0 < length l"
proof -
  have "tl l \<noteq> [] \<longleftrightarrow> 0 < length (tl l)"
    by blast
  also have "... \<longleftrightarrow> Suc 0 < length l"
    by simp
  finally show ?thesis
    .
qed

(* Adapted from the formalization of directed graphs (Graph_Theory). *)
lemma not_distinct_decomp:
  assumes "\<not> distinct as"
  shows "\<exists>xs y ys zs. as = xs @ y # ys @ y # zs \<and> distinct xs \<and> y \<notin> set xs \<and> y \<notin> set ys"
proof -
  obtain xs y ys where
    "y \<in> set xs"
    "distinct xs"
    "as = xs @ y # ys"
    using assms
    by (auto simp add: not_distinct_conv_prefix)
  moreover then obtain xs' ys' where
    "xs = xs' @ y # ys'"
    by (auto simp add: in_set_conv_decomp)
  ultimately show ?thesis
    by auto
qed

section \<open>Extended real\<close>

lemma ereal_add_commute_2:
  fixes a b c d :: ereal
  shows "a + b + c + d = b + c + a + d"
proof -
  have "a + b + c + d = a + (b + c) + d"
    by (simp add: ab_semigroup_add_class.add_ac(1))
  also have "... = b + c + a + d"
    by (intro add_mono_thms_linordered_semiring(4)) (simp add: add.commute)
  finally show ?thesis
    .
qed

lemma ereal_add_mono_2:
  fixes a b c x y z :: ereal
  assumes "a \<le> b + c"
  assumes "x \<le> y + z"
  shows "a + x \<le> b + c + y + z"
  using add_mono[OF assms]
  by (simp add: add.assoc)

lemma ereal_add_left_mono:
  fixes a b c :: ereal
  assumes "\<bar>b\<bar> \<noteq> \<infinity>"
  assumes "a - b \<le> c"
  shows "a \<le> b + c"
  using assms
  by (simp add: ereal_minus_le add.commute)

lemma ereal_add_add_left_mono:
  fixes a b c :: ereal
  assumes "\<bar>b\<bar> \<noteq> \<infinity>"
  assumes "a - b - b \<le> c"
  shows "a \<le> b + b + c"
proof -
  have "\<bar>b + b\<bar> \<noteq> \<infinity>"
    using assms(1)
    by auto
  moreover have "a - (b + b) \<le> c"
    using assms
    by (simp add: ereal_diff_add_eq_diff_diff_swap)
  ultimately show ?thesis
    by (rule ereal_add_left_mono)
qed

lemma ereal_minus_mono:
  fixes a b c :: ereal
  assumes "\<bar>b\<bar> \<noteq> \<infinity>"
  assumes "a \<le> b + c"
  shows "a - b \<le> c"
proof -
  have "a - b \<le> b + c - b"
    using assms(2)
    by (rule ereal_minus_mono) simp
  also have "... = c"
    using assms(1)
    by (rule ereal_diff_add_inverse)
  finally show ?thesis
    .
qed

lemma ereal_minus_mono_2:
  fixes a b c :: ereal
  assumes "\<bar>c\<bar> \<noteq> \<infinity>"
  assumes "a \<le> b + c"
  shows "a - c \<le> b"
proof -
  have "a \<le> c + b"
    using assms(2)
    by (simp add: algebra_simps)
  hence "a - c \<le> c + b - c"
    by (rule Extended_Real.ereal_minus_mono) simp
  also have "... = b"
    using assms(1)
    by (rule ereal_diff_add_inverse)
  finally show ?thesis
    .
qed

lemma ereal_minus_minus_mono:
  fixes a b c d :: ereal
  assumes "\<bar>c\<bar> \<noteq> \<infinity>"
  assumes "a \<le> b + c + c + d"
  shows "a - c - c \<le> b + d"
proof -
  have "\<bar>c + c\<bar> \<noteq> \<infinity>"
    using assms(1)
    by auto
  moreover have "a \<le> (b + d) + (c + c)"
    using assms(2)
    by (metis add.assoc add.commute)
  ultimately have "a - (c + c) \<le> (b + d)"
    by (rule ereal_minus_mono_2)
  thus ?thesis
    using assms(1)
    by (simp add: ereal_diff_add_eq_diff_diff_swap)
qed

lemma ereal_plus_minus_mono:
  fixes a b c :: ereal
  assumes "\<bar>b\<bar> \<noteq> \<infinity>"
  assumes "\<bar>c\<bar> \<noteq> \<infinity>"
  assumes "a - b \<le> c"
  shows "a - c \<le> b"
proof -
  have "a - b + b \<le> c + b"
    using assms(3)
    by (rule add_right_mono)
  hence "b + a - b \<le> c + b"
    by (simp add: ereal_diff_add_assoc2 add.commute)
  hence "a \<le> c + b"
    using ereal_diff_add_inverse[OF assms(1)]
    by simp
  hence "a \<le> b + c"
    by (simp add: add.commute)
  with assms(2) show ?thesis
    by (rule ereal_minus_mono_2)
qed

lemma ereal_plus_minus_minus_mono:
  fixes a b c :: ereal
  assumes "\<bar>b\<bar> \<noteq> \<infinity>"
  assumes "\<bar>c\<bar> \<noteq> \<infinity>"
  assumes "a - b - b \<le> c"
  shows "a - c \<le> b + b"
proof -
  have "\<bar>b + b\<bar> \<noteq> \<infinity>"
    using assms(1)
    by auto
  moreover have "\<bar>c\<bar> \<noteq> \<infinity>"
    using assms(2)
    by simp
  moreover have "a - (b + b) \<le> c"
    using assms(3)
    by (simp add: ereal_diff_add_eq_diff_diff_swap[OF assms(1)])
  ultimately show ?thesis
    by (rule ereal_plus_minus_mono)
qed

lemma INF_in_image:
  fixes f :: "'a \<Rightarrow> ereal"
  assumes S_finite: "finite S"
  assumes S_non_empty: "S \<noteq> {}"
  shows "Inf (f ` S) \<in> f ` S"
proof -
  have image_finite: "finite (f ` S)"
    using S_finite
    by simp
  have image_non_empty: "(f ` S) \<noteq> {}"
    using S_non_empty
    by simp

  have "Inf (f ` S) = Min (f ` S)"
    using image_finite image_non_empty
    by (rule cInf_eq_Min)
  moreover have "Min (f ` S) \<in> (f ` S)"
    using image_finite image_non_empty
    by (rule Min_in)
  ultimately show ?thesis
    by simp
qed

end