(* Title:      Modal N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Modal N-Semirings\<close>

theory N_Semirings_Modal

imports N_Semirings_Boolean

begin

class n_diamond_semiring = n_semiring + diamond +
  assumes ndiamond_def: "|x>y = n(x * y * L)"
begin

lemma diamond_x_bot:
  "|x>bot = n(x)"
  using n_mult_bot ndiamond_def mult_assoc by auto

lemma diamond_x_1:
  "|x>1 = n(x * L)"
  by (simp add: ndiamond_def)

lemma diamond_x_L:
  "|x>L = n(x * L)"
  by (simp add: L_left_zero ndiamond_def mult_assoc)

lemma diamond_x_top:
  "|x>top = n(x * L)"
  by (metis mult_assoc n_top_L ndiamond_def top_mult_top)

lemma diamond_x_n:
  "|x>n(y) = n(x * y)"
  by (simp add: n_mult ndiamond_def)

lemma diamond_bot_y:
  "|bot>y = bot"
  by (simp add: n_bot ndiamond_def)

lemma diamond_1_y:
  "|1>y = n(y * L)"
  by (simp add: ndiamond_def)

lemma diamond_1_n:
  "|1>n(y) = n(y)"
  by (simp add: diamond_1_y n_n_L)

lemma diamond_L_y:
  "|L>y = 1"
  by (simp add: L_left_zero n_L ndiamond_def)

lemma diamond_top_y:
  "|top>y = 1"
  by (metis sup_left_top sup_right_top diamond_L_y mult_right_dist_sup n_dist_sup n_top ndiamond_def)

lemma diamond_n_y:
  "|n(x)>y = n(x) * n(y * L)"
  by (simp add: n_export ndiamond_def mult_assoc)

lemma diamond_n_bot:
  "|n(x)>bot = bot"
  by (simp add: n_bot n_mult_right_bot ndiamond_def)

lemma diamond_n_1:
  "|n(x)>1 = n(x)"
  using diamond_1_n diamond_1_y diamond_x_1 by auto

lemma diamond_n_n:
  "|n(x)>n(y) = n(x) * n(y)"
  by (simp add: diamond_x_n n_export)

lemma diamond_n_n_same:
  "|n(x)>n(x) = n(x)"
  by (simp add: diamond_n_n n_mult_idempotent)

text \<open>Theorem 23.1\<close>

lemma diamond_left_dist_sup:
  "|x \<squnion> y>z = |x>z \<squnion> |y>z"
  by (simp add: mult_right_dist_sup n_dist_sup ndiamond_def)

text \<open>Theorem 23.2\<close>

lemma diamond_right_dist_sup:
  "|x>(y \<squnion> z) = |x>y \<squnion> |x>z"
  by (simp add: mult_left_dist_sup n_dist_sup ndiamond_def semiring.distrib_right)

text \<open>Theorem 23.3\<close>

lemma diamond_associative:
  "|x * y>z = |x>(y * z)"
  by (simp add: ndiamond_def mult_assoc)

text \<open>Theorem 23.3\<close>

lemma diamond_left_mult:
  "|x * y>z = |x>|y>z"
  using n_mult_ni ndiamond_def ni_def mult_assoc by auto

lemma diamond_right_mult:
  "|x>(y * z) = |x>|y>z"
  using diamond_associative diamond_left_mult by force

lemma diamond_n_export:
  "|n(x) * y>z = n(x) * |y>z"
  by (simp add: n_export ndiamond_def mult_assoc)

lemma diamond_diamond_export:
  "||x>y>z = |x>y * |z>1"
  using diamond_n_y ndiamond_def by auto

lemma diamond_left_isotone:
  "x \<le> y \<Longrightarrow> |x>z \<le> |y>z"
  by (metis diamond_left_dist_sup le_iff_sup)

lemma diamond_right_isotone:
  "y \<le> z \<Longrightarrow> |x>y \<le> |x>z"
  by (metis diamond_right_dist_sup le_iff_sup)

lemma diamond_isotone:
  "w \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> |w>x \<le> |y>z"
  by (meson diamond_left_isotone diamond_right_isotone order_trans)

definition ndiamond_L :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<parallel> _ \<guillemotright> _" [50,90] 95)
  where "\<parallel>x\<guillemotright>y \<equiv> n(x * y) * L"

lemma ndiamond_to_L:
  "\<parallel>x\<guillemotright>y = |x>n(y) * L"
  by (simp add: diamond_x_n ndiamond_L_def)

lemma ndiamond_from_L:
  "|x>y = n(\<parallel>x\<guillemotright>(y * L))"
  by (simp add: n_n_L ndiamond_def mult_assoc ndiamond_L_def)

lemma diamond_L_ni:
  "\<parallel>x\<guillemotright>y = ni(x * y)"
  by (simp add: ni_def ndiamond_L_def)

lemma diamond_L_associative:
  "\<parallel>x * y\<guillemotright>z = \<parallel>x\<guillemotright>(y * z)"
  by (simp add: diamond_L_ni mult_assoc)

lemma diamond_L_left_mult:
  "\<parallel>x * y\<guillemotright>z = \<parallel>x\<guillemotright>\<parallel>y\<guillemotright>z"
  using diamond_L_associative diamond_L_ni ni_mult by auto

lemma diamond_L_right_mult:
  "\<parallel>x\<guillemotright>(y * z) = \<parallel>x\<guillemotright>\<parallel>y\<guillemotright>z"
  using diamond_L_associative diamond_L_left_mult by auto

lemma diamond_L_left_dist_sup:
  "\<parallel>x \<squnion> y\<guillemotright>z = \<parallel>x\<guillemotright>z \<squnion> \<parallel>y\<guillemotright>z"
  by (simp add: diamond_L_ni mult_right_dist_sup ni_dist_sup)

lemma diamond_L_x_ni:
  "\<parallel>x\<guillemotright>ni(y) = ni(x * y)"
  using n_mult_ni ni_def ndiamond_L_def by auto

lemma diamond_L_left_isotone:
  "x \<le> y \<Longrightarrow> \<parallel>x\<guillemotright>z \<le> \<parallel>y\<guillemotright>z"
  using mult_left_isotone ni_def ni_isotone ndiamond_L_def by auto

lemma diamond_L_right_isotone:
  "y \<le> z \<Longrightarrow> \<parallel>x\<guillemotright>y \<le> \<parallel>x\<guillemotright>z"
  using mult_right_isotone ni_def ni_isotone ndiamond_L_def by auto

lemma diamond_L_isotone:
  "w \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> \<parallel>w\<guillemotright>x \<le> \<parallel>y\<guillemotright>z"
  using diamond_L_ni mult_isotone ni_isotone by force

end

class n_box_semiring = n_diamond_semiring + an_semiring + box +
  assumes nbox_def: "|x]y = an(x * an(y * L) * L)"
begin

text \<open>Theorem 23.8\<close>

lemma box_diamond:
  "|x]y = an( |x>an(y * L) * L)"
  by (simp add: an_n_L nbox_def ndiamond_def)

text \<open>Theorem 23.4\<close>

lemma diamond_box:
  "|x>y = an( |x]an(y * L) * L)"
  using n_an_def n_mult nbox_def ndiamond_def mult_assoc by force

lemma box_x_bot:
  "|x]bot = an(x * L)"
  by (simp add: an_bot nbox_def)

lemma box_x_1:
  "|x]1 = an(x)"
  using an_L an_mult_an nbox_def mult_assoc by auto

lemma box_x_L:
  "|x]L = an(x)"
  using box_x_1 L_left_zero nbox_def by auto

lemma box_x_top:
  "|x]top = an(x)"
  by (metis box_diamond box_x_1 box_x_bot diamond_top_y)

lemma box_x_n:
  "|x]n(y) = an(x * an(y) * L)"
  by (simp add: an_n_L nbox_def)

lemma box_x_an:
  "|x]an(y) = an(x * y)"
  using an_mult n_an_def nbox_def by auto

lemma box_bot_y:
  "|bot]y = 1"
  by (simp add: an_bot nbox_def)

lemma box_1_y:
  "|1]y = n(y * L)"
  by (simp add: n_an_def nbox_def)

lemma box_1_n:
  "|1]n(y) = n(y)"
  using box_1_y diamond_1_n diamond_1_y by auto

lemma box_1_an:
  "|1]an(y) = an(y)"
  by (simp add: box_x_an)

lemma box_L_y:
  "|L]y = bot"
  by (simp add: L_left_zero an_L nbox_def)

lemma box_top_y:
  "|top]y = bot"
  by (simp add: box_diamond an_L diamond_top_y)

lemma box_n_y:
  "|n(x)]y = an(x) \<squnion> n(y * L)"
  using an_export_n n_an_def nbox_def mult_assoc by auto

lemma box_an_y:
  "|an(x)]y = n(x) \<squnion> n(y * L)"
  by (metis an_n_def box_n_y n_an_def)

lemma box_n_bot:
  "|n(x)]bot = an(x)"
  by (simp add: box_x_bot an_n_L)

lemma box_an_bot:
  "|an(x)]bot = n(x)"
  by (simp add: box_x_bot n_an_def)

lemma box_n_1:
  "|n(x)]1 = 1"
  using box_x_1 ani_an_L ani_n by auto

lemma box_an_1:
  "|an(x)]1 = 1"
  using box_x_1 ani_an ani_an_L by fastforce

lemma box_n_n:
  "|n(x)]n(y) = an(x) \<squnion> n(y)"
  using box_1_n box_1_y box_n_y by auto

lemma box_an_n:
  "|an(x)]n(y) = n(x) \<squnion> n(y)"
  using box_x_n an_dist_sup n_an_def n_dist_sup by auto

lemma box_n_an:
  "|n(x)]an(y) = an(x) \<squnion> an(y)"
  by (simp add: box_x_an an_export_n)

lemma box_an_an:
  "|an(x)]an(y) = n(x) \<squnion> an(y)"
  by (simp add: box_x_an an_export)

lemma box_n_n_same:
  "|n(x)]n(x) = 1"
  by (simp add: box_n_n an_complement)

lemma box_an_an_same:
  "|an(x)]an(x) = 1"
  using box_an_bot an_bot an_complement_bot nbox_def by auto

text \<open>Theorem 23.5\<close>

lemma box_left_dist_sup:
  "|x \<squnion> y]z = |x]z * |y]z"
  using an_dist_sup nbox_def semiring.distrib_right by auto

lemma box_right_dist_sup:
  "|x](y \<squnion> z) = an(x * an(y * L) * an(z * L) * L)"
  by (simp add: an_dist_sup mult_right_dist_sup nbox_def mult_assoc)

lemma box_associative:
  "|x * y]z = an(x * y * an(z * L) * L)"
  by (simp add: nbox_def)

text \<open>Theorem 23.7\<close>

lemma box_left_mult:
  "|x * y]z = |x]|y]z"
  using box_x_an nbox_def mult_assoc by auto

lemma box_right_mult:
  "|x](y * z) = an(x * an(y * z * L) * L)"
  by (simp add: nbox_def)

text \<open>Theorem 23.6\<close>

lemma box_right_mult_n_n:
  "|x](n(y) * n(z)) = |x]n(y) * |x]n(z)"
  by (smt an_dist_sup an_export_n an_n_L mult_assoc mult_left_dist_sup mult_right_dist_sup nbox_def)

lemma box_right_mult_an_n:
  "|x](an(y) * n(z)) = |x]an(y) * |x]n(z)"
  by (metis an_n_def box_right_mult_n_n)

lemma box_right_mult_n_an:
  "|x](n(y) * an(z)) = |x]n(y) * |x]an(z)"
  by (simp add: box_right_mult_an_n box_x_an box_x_n an_mult_commutative n_an_mult_commutative)

lemma box_right_mult_an_an:
  "|x](an(y) * an(z)) = |x]an(y) * |x]an(z)"
  by (metis an_dist_sup box_x_an mult_left_dist_sup)

lemma box_n_export:
  "|n(x) * y]z = an(x) \<squnion> |y]z"
  using box_left_mult box_n_an nbox_def by auto

lemma box_an_export:
  "|an(x) * y]z = n(x) \<squnion> |y]z"
  using box_an_an box_left_mult nbox_def by auto

lemma box_left_antitone:
  "y \<le> x \<Longrightarrow> |x]z \<le> |y]z"
  by (smt an_mult_commutative an_order box_diamond box_left_dist_sup le_iff_sup)

lemma box_right_isotone:
  "y \<le> z \<Longrightarrow> |x]y \<le> |x]z"
  by (metis an_antitone mult_left_isotone mult_right_isotone nbox_def)

lemma box_antitone_isotone:
  "y \<le> w \<Longrightarrow> x \<le> z \<Longrightarrow> |w]x \<le> |y]z"
  by (meson box_left_antitone box_right_isotone order.trans)

definition nbox_L :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<parallel> _ \<rbrakk> _" [50,90] 95)
  where "\<parallel>x\<rbrakk>y \<equiv> an(x * an(y) * L) * L"

lemma nbox_to_L:
  "\<parallel>x\<rbrakk>y = |x]n(y) * L"
  by (simp add: box_x_n nbox_L_def)

lemma nbox_from_L:
  "|x]y = n(\<parallel>x\<rbrakk>(y * L))"
  using an_n_def nbox_def nbox_L_def by auto

lemma diamond_x_an:
  "|x>an(y) = n(x * an(y) * L)"
  by (simp add: ndiamond_def)

lemma diamond_1_an:
  "|1>an(y) = an(y)"
  using box_1_an box_1_y diamond_1_y by auto

lemma diamond_an_y:
  "|an(x)>y = an(x) * n(y * L)"
  by (simp add: n_export_an ndiamond_def mult_assoc)

lemma diamond_an_bot:
  "|an(x)>bot = bot"
  by (simp add: an_mult_right_zero n_bot ndiamond_def)

lemma diamond_an_1:
  "|an(x)>1 = an(x)"
  using an_n_def diamond_x_1 by auto

lemma diamond_an_n:
  "|an(x)>n(y) = an(x) * n(y)"
  by (simp add: diamond_x_n n_export_an)

lemma diamond_n_an:
  "|n(x)>an(y) = n(x) * an(y)"
  using an_n_def diamond_n_y by auto

lemma diamond_an_an:
  "|an(x)>an(y) = an(x) * an(y)"
  using diamond_an_y an_n_def by auto

lemma diamond_an_an_same:
  "|an(x)>an(x) = an(x)"
  by (simp add: diamond_an_an an_mult_idempotent)

lemma diamond_an_export:
  "|an(x) * y>z = an(x) * |y>z"
  using diamond_an_an diamond_box diamond_left_mult by auto

lemma box_ani:
  "|x]y = an(x * ani(y * L))"
  by (simp add: ani_def nbox_def mult_assoc)

lemma box_x_n_ani:
  "|x]n(y) = an(x * ani(y))"
  by (simp add: box_x_n ani_def mult_assoc)

lemma box_L_ani:
  "\<parallel>x\<rbrakk>y = ani(x * ani(y))"
  using box_x_n_ani ani_def nbox_to_L by auto

lemma box_L_left_mult:
  "\<parallel>x * y\<rbrakk>z = \<parallel>x\<rbrakk>\<parallel>y\<rbrakk>z"
  using an_mult n_an_def mult_assoc nbox_L_def by auto

lemma diamond_x_an_ani:
  "|x>an(y) = n(x * ani(y))"
  by (simp add: ani_def ndiamond_def mult_assoc)

lemma box_L_left_antitone:
  "y \<le> x \<Longrightarrow> \<parallel>x\<rbrakk>z \<le> \<parallel>y\<rbrakk>z"
  by (simp add: box_L_ani ani_antitone mult_left_isotone)

lemma box_L_right_isotone:
  "y \<le> z \<Longrightarrow> \<parallel>x\<rbrakk>y \<le> \<parallel>x\<rbrakk>z"
  using ani_antitone ani_def mult_right_isotone mult_assoc nbox_L_def by auto

lemma box_L_antitone_isotone:
  "y \<le> w \<Longrightarrow> x \<le> z \<Longrightarrow> \<parallel>w\<rbrakk>x \<le> \<parallel>y\<rbrakk>z"
  using ani_antitone ani_def mult_isotone mult_assoc nbox_L_def by force

end

class n_box_omega_algebra = n_box_semiring + an_omega_algebra
begin

lemma diamond_omega:
  "|x\<^sup>\<omega>>y = |x\<^sup>\<omega>>z"
  by (simp add: n_omega_mult ndiamond_def mult_assoc)

lemma box_omega:
  "|x\<^sup>\<omega>]y = |x\<^sup>\<omega>]z"
  by (metis box_diamond diamond_omega)

lemma an_box_omega_induct:
  "|x]an(y) * n(z * L) \<le> an(y) \<Longrightarrow> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]z \<le> an(y)"
  by (smt an_dist_sup an_omega_induct an_omega_mult box_left_dist_sup box_x_an mult_assoc n_an_def nbox_def)

lemma n_box_omega_induct:
  "|x]n(y) * n(z * L) \<le> n(y) \<Longrightarrow> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]z \<le> n(y)"
  by (simp add: an_box_omega_induct n_an_def)

lemma an_box_omega_induct_an:
  "|x]an(y) * an(z) \<le> an(y) \<Longrightarrow> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(z) \<le> an(y)"
  using an_box_omega_induct an_n_def by auto

text \<open>Theorem 23.13\<close>

lemma n_box_omega_induct_n:
  "|x]n(y) * n(z) \<le> n(y) \<Longrightarrow> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]n(z) \<le> n(y)"
  using an_box_omega_induct_an n_an_def by force

lemma n_diamond_omega_induct:
  "n(y) \<le> |x>n(y) \<squnion> n(z * L) \<Longrightarrow> n(y) \<le> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>z"
  using diamond_x_n mult_right_dist_sup n_dist_sup n_omega_induct n_omega_mult ndiamond_def mult_assoc by force

lemma an_diamond_omega_induct:
  "an(y) \<le> |x>an(y) \<squnion> n(z * L) \<Longrightarrow> an(y) \<le> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>z"
  by (metis n_diamond_omega_induct an_n_def)

text \<open>Theorem 23.9\<close>

lemma n_diamond_omega_induct_n:
  "n(y) \<le> |x>n(y) \<squnion> n(z) \<Longrightarrow> n(y) \<le> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>n(z)"
  using box_1_n box_1_y n_diamond_omega_induct by auto

lemma an_diamond_omega_induct_an:
  "an(y) \<le> |x>an(y) \<squnion> an(z) \<Longrightarrow> an(y) \<le> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>an(z)"
  using an_diamond_omega_induct an_n_def by auto

lemma box_segerberg_an:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y) = an(y) * |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>](n(y) \<squnion> |x]an(y))"
proof (rule order.antisym)
  have "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y) \<le> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]|x]an(y)"
    by (smt box_left_dist_sup box_left_mult box_omega sup_right_isotone box_left_antitone mult_right_dist_sup star.right_plus_below_circ)
  hence "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y) \<le> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>](n(y) \<squnion> |x]an(y))"
    using box_right_isotone order_lesseq_imp sup.cobounded2 by blast
  thus"|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y) \<le> an(y) * |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>](n(y) \<squnion> |x]an(y))"
    by (metis le_sup_iff box_1_an box_left_antitone order_refl star_left_unfold_equal an_mult_least_upper_bound nbox_def)
next
  have "an(y) * |x](n(y) \<squnion> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y)) * (n(y) \<squnion> |x]an(y)) = |x]( |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y) * an(y)) * an(y)"
    by (smt sup_bot_left an_export an_mult_commutative box_right_mult_an_an mult_assoc mult_right_dist_sup n_complement_bot nbox_def)
  hence 1: "an(y) * |x](n(y) \<squnion> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y)) * (n(y) \<squnion> |x]an(y)) \<le> n(y) \<squnion> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y)"
    by (smt sup_assoc sup_commute sup_ge2 box_1_an box_left_dist_sup box_left_mult mult_left_dist_sup omega_unfold star_left_unfold_equal star.circ_plus_one)
  have "n(y) * |x](n(y) \<squnion> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y)) * (n(y) \<squnion> |x]an(y)) \<le> n(y) \<squnion> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y)"
    by (smt sup_ge1 an_n_def mult_left_isotone n_an_mult_left_lower_bound n_mult_left_absorb_sup nbox_def order_trans)
  thus "an(y) * |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>](n(y) \<squnion> |x]an(y)) \<le> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y)"
    using 1 by (smt an_case_split_left an_shunting_an mult_assoc n_box_omega_induct_n n_dist_sup nbox_def nbox_from_L)
qed

text \<open>Theorem 23.16\<close>

lemma box_segerberg_n:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]n(y) = n(y) * |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>](an(y) \<squnion> |x]n(y))"
  using box_segerberg_an an_n_def n_an_def by force

lemma diamond_segerberg_an:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>an(y) = an(y) \<squnion> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>(n(y) * |x>an(y))"
  by (smt an_export an_n_L box_diamond box_segerberg_an diamond_box mult_assoc n_an_def)

text \<open>Theorem 23.12\<close>

lemma diamond_segerberg_n:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>n(y) = n(y) \<squnion> |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>(an(y) * |x>n(y))"
  using diamond_segerberg_an an_n_L n_an_def by auto

text \<open>Theorem 23.11\<close>

lemma diamond_star_unfold_n:
  "|x\<^sup>\<star>>n(y) = n(y) \<squnion> |an(y) * x>|x\<^sup>\<star>>n(y)"
proof -
  have "|x\<^sup>\<star>>n(y) = n(y) \<squnion> n(y) * |x * x\<^sup>\<star>>n(y) \<squnion> |an(y) * x * x\<^sup>\<star>>n(y)"
    by (smt sup_assoc sup_commute sup_bot_right an_complement an_complement_bot diamond_an_n diamond_left_dist_sup diamond_n_export diamond_n_n_same mult_assoc mult_left_one mult_right_dist_sup star_left_unfold_equal)
  thus ?thesis
    by (metis diamond_left_mult diamond_x_n n_sup_left_absorb_mult)
qed

lemma diamond_star_unfold_an:
  "|x\<^sup>\<star>>an(y) = an(y) \<squnion> |n(y) * x>|x\<^sup>\<star>>an(y)"
  by (metis an_n_def diamond_star_unfold_n n_an_def)

text \<open>Theorem 23.15\<close>

lemma box_star_unfold_n:
  "|x\<^sup>\<star>]n(y) = n(y) * |n(y) * x]|x\<^sup>\<star>]n(y)"
  by (smt an_export an_n_L box_diamond diamond_box diamond_star_unfold_an n_an_def n_export)

lemma box_star_unfold_an:
  "|x\<^sup>\<star>]an(y) = an(y) * |an(y) * x]|x\<^sup>\<star>]an(y)"
  by (metis an_n_def box_star_unfold_n)

text \<open>Theorem 23.10\<close>

lemma diamond_omega_unfold_n:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>n(y) = n(y) \<squnion> |an(y) * x>|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>n(y)"
  by (smt sup_assoc sup_commute diamond_an_export diamond_left_dist_sup diamond_right_dist_sup diamond_star_unfold_n diamond_x_n n_omega_mult n_plus_complement_intro_n omega_unfold)

lemma diamond_omega_unfold_an:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>an(y) = an(y) \<squnion> |n(y) * x>|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>an(y)"
  by (metis an_n_def diamond_omega_unfold_n n_an_def)

text \<open>Theorem 23.14\<close>

lemma box_omega_unfold_n:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]n(y) = n(y) * |n(y) * x]|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]n(y)"
  by (smt an_export an_n_L box_diamond diamond_box diamond_omega_unfold_an n_an_def n_export)

lemma box_omega_unfold_an:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y) = an(y) * |an(y) * x]|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y)"
  by (metis an_n_def box_omega_unfold_n)

lemma box_cut_iteration_an:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]an(y) = |(an(y) * x)\<^sup>\<omega> \<squnion> (an(y) * x)\<^sup>\<star>]an(y)"
  apply (rule order.antisym)
  apply (meson semiring.add_mono an_case_split_left box_left_antitone omega_isotone order_refl star.circ_isotone)
  by (smt (z3) an_box_omega_induct_an an_mult_commutative box_omega_unfold_an nbox_def order_refl)

lemma box_cut_iteration_n:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>]n(y) = |(n(y) * x)\<^sup>\<omega> \<squnion> (n(y) * x)\<^sup>\<star>]n(y)"
  using box_cut_iteration_an n_an_def by auto

lemma diamond_cut_iteration_an:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>an(y) = |(n(y) * x)\<^sup>\<omega> \<squnion> (n(y) * x)\<^sup>\<star>>an(y)"
  using box_cut_iteration_n diamond_box n_an_def by auto

lemma diamond_cut_iteration_n:
  "|x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>n(y) = |(an(y) * x)\<^sup>\<omega> \<squnion> (an(y) * x)\<^sup>\<star>>n(y)"
  using box_cut_iteration_an an_n_L diamond_box by auto

lemma ni_diamond_omega_induct:
  "ni(y) \<le> \<parallel>x\<guillemotright>ni(y) \<squnion> ni(z) \<Longrightarrow> ni(y) \<le> \<parallel>x\<^sup>\<omega> \<squnion> x\<^sup>\<star>\<guillemotright>z"
  by (metis diamond_L_left_dist_sup diamond_L_x_ni diamond_L_ni ni_dist_sup ni_omega_induct ni_omega_mult)

lemma ani_diamond_omega_induct:
  "ani(y) \<le> \<parallel>x\<guillemotright>ani(y) \<squnion> ni(z) \<Longrightarrow> ani(y) \<le> \<parallel>x\<^sup>\<omega> \<squnion> x\<^sup>\<star>\<guillemotright>z"
  by (metis ni_ani ni_diamond_omega_induct)

lemma n_diamond_omega_L:
  "|n(x\<^sup>\<omega>) * L>y = |x\<^sup>\<omega>>y"
  using L_left_zero mult_1_right n_L n_export n_omega_mult ndiamond_def mult_assoc by auto

lemma n_diamond_loop:
  "|x\<^sup>\<Omega>>y = |x\<^sup>\<omega> \<squnion> x\<^sup>\<star>>y"
  by (metis Omega_def diamond_left_dist_sup n_diamond_omega_L)

text \<open>Theorem 24.1\<close>

lemma cut_iteration_loop:
  "|x\<^sup>\<Omega>>n(y) = |(an(y) * x)\<^sup>\<Omega>>n(y)"
  using diamond_cut_iteration_n n_diamond_loop by auto

lemma cut_iteration_while_loop:
  "|x\<^sup>\<Omega>>n(y) = |(an(y) * x)\<^sup>\<Omega> * n(y)>n(y)"
  using cut_iteration_loop diamond_left_mult diamond_n_n_same by auto

text \<open>Theorem 24.1\<close>

lemma cut_iteration_while_loop_2:
  "|x\<^sup>\<Omega>>n(y) = |an(y) \<star> x>n(y)"
  by (metis cut_iteration_while_loop an_uminus n_an_def while_Omega_def)

lemma modal_while:
  assumes "-q * -p * L \<le> x * -p * L \<and> -p \<le> -q \<squnion> -r"
    shows "-p \<le> |n((-q * x)\<^sup>\<omega>) * L \<squnion> (-q * x)\<^sup>\<star> * --q>(-r)"
proof -
  have 1: "--q * -p \<le> |-q * x>(-p) \<squnion> --q * -r"
    using assms mult_right_isotone sup.coboundedI2 tests_dual.sup_complement_intro by auto
  have "-q * -p = n(-q * -q * -p * L)"
    using an_uminus n_export_an mult_assoc mult_1_right n_L tests_dual.sup_idempotent by auto
  also have "... \<le> n(-q * x * -p * L)"
    by (metis assms n_isotone mult_right_isotone mult_assoc)
  also have "... \<le> |-q * x>(-p) \<squnion> --q * -r"
    by (simp add: ndiamond_def)
  finally have "-p \<le> |-q * x>(-p) \<squnion> --q * -r"
    using 1 by (smt sup_assoc le_iff_sup tests_dual.inf_cases sub_comm)
  thus ?thesis
    by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc n_n_L n_omega_mult ndiamond_def sub_mult_closed)
qed

lemma modal_while_loop:
  "-q * -p * L \<le> x * -p * L \<and> -p \<le> -q \<squnion> -r \<Longrightarrow> -p \<le> |(-q * x)\<^sup>\<Omega> * --q>(-r)"
  by (metis L_left_zero Omega_def modal_while mult_assoc mult_right_dist_sup)

text \<open>Theorem 24.2\<close>

lemma modal_while_loop_2:
  "-q * -p * L \<le> x * -p * L \<and> -p \<le> -q \<squnion> -r \<Longrightarrow> -p \<le> |-q \<star> x>(-r)"
  by (simp add: while_Omega_def modal_while_loop)

lemma modal_while_2:
  assumes "-p * L \<le> x * -p * L"
    shows "-p \<le> |n((-q * x)\<^sup>\<omega>) * L \<squnion> (-q * x)\<^sup>\<star> * --q>(--q)"
proof -
  have "-p \<le> |-q * x>(-p) \<squnion> --q"
    by (smt (verit, del_insts) assms an_uminus tests_dual.double_negation n_an_def n_isotone ndiamond_def diamond_an_export sup_assoc sup_commute le_iff_sup tests_dual.inf_complement_intro)
  thus ?thesis
    by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc tests_dual.sup_idempotent n_n_L n_omega_mult ndiamond_def)
qed

end

class n_modal_omega_algebra = n_box_omega_algebra +
  assumes n_star_induct: "n(x * y) \<le> n(y) \<longrightarrow> n(x\<^sup>\<star> * y) \<le> n(y)"
begin

lemma n_star_induct_sup:
  "n(z \<squnion> x * y) \<le> n(y) \<Longrightarrow> n(x\<^sup>\<star> * z) \<le> n(y)"
  by (metis an_dist_sup an_mult_least_upper_bound an_n_order n_mult_right_upper_bound n_star_induct star_L_split)

lemma n_star_induct_star:
  "n(x * y) \<le> n(y) \<Longrightarrow> n(x\<^sup>\<star>) \<le> n(y)"
  using n_star_induct n_star_mult by auto

lemma n_star_induct_iff:
  "n(x * y) \<le> n(y) \<longleftrightarrow> n(x\<^sup>\<star> * y) \<le> n(y)"
  by (metis mult_left_isotone n_isotone n_star_induct order_trans star.circ_increasing)

lemma n_star_bot:
  "n(x) = bot \<longleftrightarrow> n(x\<^sup>\<star>) = bot"
  by (metis sup_bot_right le_iff_sup mult_1_right n_one n_star_induct_iff)

lemma n_diamond_star_induct:
  "|x>n(y) \<le> n(y) \<Longrightarrow> |x\<^sup>\<star>>n(y) \<le> n(y)"
  by (simp add: diamond_x_n n_star_induct)

lemma n_diamond_star_induct_sup:
  "|x>n(y) \<squnion> n(z) \<le> n(y) \<Longrightarrow> |x\<^sup>\<star>>n(z) \<le> n(y)"
  by (simp add: diamond_x_n n_dist_sup n_star_induct_sup)

lemma n_diamond_star_induct_iff:
  "|x>n(y) \<le> n(y) \<longleftrightarrow> |x\<^sup>\<star>>n(y) \<le> n(y)"
  using diamond_x_n n_star_induct_iff by auto

lemma an_star_induct:
  "an(y) \<le> an(x * y) \<Longrightarrow> an(y) \<le> an(x\<^sup>\<star> * y)"
  using an_n_order n_star_induct by auto

lemma an_star_induct_sup:
  "an(y) \<le> an(z \<squnion> x * y) \<Longrightarrow> an(y) \<le> an(x\<^sup>\<star> * z)"
  using an_n_order n_star_induct_sup by auto

lemma an_star_induct_star:
  "an(y) \<le> an(x * y) \<Longrightarrow> an(y) \<le> an(x\<^sup>\<star>)"
  by (simp add: an_n_order n_star_induct_star)

lemma an_star_induct_iff:
  "an(y) \<le> an(x * y) \<longleftrightarrow> an(y) \<le> an(x\<^sup>\<star> * y)"
  using an_n_order n_star_induct_iff by auto

lemma an_star_one:
  "an(x) = 1 \<longleftrightarrow> an(x\<^sup>\<star>) = 1"
  by (metis an_n_equal an_bot n_star_bot n_bot)

lemma an_box_star_induct:
  "an(y) \<le> |x]an(y) \<Longrightarrow> an(y) \<le> |x\<^sup>\<star>]an(y)"
  by (simp add: an_star_induct box_x_an)

lemma an_box_star_induct_sup:
  "an(y) \<le> |x]an(y) * an(z) \<Longrightarrow> an(y) \<le> |x\<^sup>\<star>]an(z)"
  by (simp add: an_star_induct_sup an_dist_sup an_mult_commutative box_x_an)

lemma an_box_star_induct_iff:
  "an(y) \<le> |x]an(y) \<longleftrightarrow> an(y) \<le> |x\<^sup>\<star>]an(y)"
  using an_star_induct_iff box_x_an by auto

lemma box_star_segerberg_an:
  "|x\<^sup>\<star>]an(y) = an(y) * |x\<^sup>\<star>](n(y) \<squnion> |x]an(y))"
proof (rule order.antisym)
  show "|x\<^sup>\<star>]an(y) \<le> an(y) * |x\<^sup>\<star>](n(y) \<squnion> |x]an(y))"
    by (smt (verit) sup_ge2 box_1_an box_left_dist_sup box_left_mult box_right_isotone mult_right_isotone star.circ_right_unfold)
next
  have "an(y) * |x\<^sup>\<star>](n(y) \<squnion> |x]an(y)) \<le> an(y) * |x]an(y)"
    by (metis sup_bot_left an_complement_bot box_an_an box_left_antitone box_x_an mult_left_dist_sup mult_left_one mult_right_isotone star.circ_reflexive)
  thus "an(y) * |x\<^sup>\<star>](n(y) \<squnion> |x]an(y)) \<le> |x\<^sup>\<star>]an(y)"
    by (smt an_box_star_induct_sup an_case_split_left an_dist_sup an_mult_least_upper_bound box_left_antitone box_left_mult box_right_mult_an_an star.left_plus_below_circ nbox_def)
qed

lemma box_star_segerberg_n:
  "|x\<^sup>\<star>]n(y) = n(y) * |x\<^sup>\<star>](an(y) \<squnion> |x]n(y))"
  using box_star_segerberg_an an_n_def n_an_def by auto

lemma diamond_segerberg_an:
  "|x\<^sup>\<star>>an(y) = an(y) \<squnion> |x\<^sup>\<star>>(n(y) * |x>an(y))"
  by (smt an_export an_n_L box_diamond box_star_segerberg_an diamond_box mult_assoc n_an_def)

lemma diamond_star_segerberg_n:
  "|x\<^sup>\<star>>n(y) = n(y) \<squnion> |x\<^sup>\<star>>(an(y) * |x>n(y))"
  using an_n_def diamond_segerberg_an n_an_def by auto

lemma box_cut_star_iteration_an:
  "|x\<^sup>\<star>]an(y) = |(an(y) * x)\<^sup>\<star>]an(y)"
  by (smt an_box_star_induct_sup an_mult_commutative an_mult_complement_intro_an order.antisym box_an_export box_star_unfold_an nbox_def order_refl)

lemma box_cut_star_iteration_n:
  "|x\<^sup>\<star>]n(y) = |(n(y) * x)\<^sup>\<star>]n(y)"
  using box_cut_star_iteration_an n_an_def by auto

lemma diamond_cut_star_iteration_an:
  "|x\<^sup>\<star>>an(y) = |(n(y) * x)\<^sup>\<star>>an(y)"
  using box_cut_star_iteration_an diamond_box n_an_def by auto

lemma diamond_cut_star_iteration_n:
  "|x\<^sup>\<star>>n(y) = |(an(y) * x)\<^sup>\<star>>n(y)"
  using box_cut_star_iteration_an an_n_L diamond_box by auto

lemma ni_star_induct:
  "ni(x * y) \<le> ni(y) \<Longrightarrow> ni(x\<^sup>\<star> * y) \<le> ni(y)"
  using n_star_induct ni_n_order by auto

lemma ni_star_induct_sup:
  "ni(z \<squnion> x * y) \<le> ni(y) \<Longrightarrow> ni(x\<^sup>\<star> * z) \<le> ni(y)"
  by (simp add: ni_n_order n_star_induct_sup)

lemma ni_star_induct_star:
  "ni(x * y) \<le> ni(y) \<Longrightarrow> ni(x\<^sup>\<star>) \<le> ni(y)"
  using ni_n_order n_star_induct_star by auto

lemma ni_star_induct_iff:
  "ni(x * y) \<le> ni(y) \<longleftrightarrow> ni(x\<^sup>\<star> * y) \<le> ni(y)"
  using ni_n_order n_star_induct_iff by auto

lemma ni_star_bot:
  "ni(x) = bot \<longleftrightarrow> ni(x\<^sup>\<star>) = bot"
  using ni_n_bot n_star_bot by auto

lemma ni_diamond_star_induct:
  "\<parallel>x\<guillemotright>ni(y) \<le> ni(y) \<Longrightarrow> \<parallel>x\<^sup>\<star>\<guillemotright>ni(y) \<le> ni(y)"
  by (simp add: diamond_L_x_ni ni_star_induct)

lemma ni_diamond_star_induct_sup:
  "\<parallel>x\<guillemotright>ni(y) \<squnion> ni(z) \<le> ni(y) \<Longrightarrow> \<parallel>x\<^sup>\<star>\<guillemotright>ni(z) \<le> ni(y)"
  by (simp add: diamond_L_x_ni ni_dist_sup ni_star_induct_sup)

lemma ni_diamond_star_induct_iff:
  "\<parallel>x\<guillemotright>ni(y) \<le> ni(y) \<longleftrightarrow> \<parallel>x\<^sup>\<star>\<guillemotright>ni(y) \<le> ni(y)"
  using diamond_L_x_ni ni_star_induct_iff by auto

lemma ani_star_induct:
  "ani(y) \<le> ani(x * y) \<Longrightarrow> ani(y) \<le> ani(x\<^sup>\<star> * y)"
  using an_star_induct ani_an_order by blast

lemma ani_star_induct_sup:
  "ani(y) \<le> ani(z \<squnion> x * y) \<Longrightarrow> ani(y) \<le> ani(x\<^sup>\<star> * z)"
  by (simp add: an_star_induct_sup ani_an_order)

lemma ani_star_induct_star:
  "ani(y) \<le> ani(x * y) \<Longrightarrow> ani(y) \<le> ani(x\<^sup>\<star>)"
  using an_star_induct_star ani_an_order by auto

lemma ani_star_induct_iff:
  "ani(y) \<le> ani(x * y) \<longleftrightarrow> ani(y) \<le> ani(x\<^sup>\<star> * y)"
  using an_star_induct_iff ani_an_order by auto

lemma ani_star_L:
  "ani(x) = L \<longleftrightarrow> ani(x\<^sup>\<star>) = L"
  using an_star_one ani_an_L by auto

lemma ani_box_star_induct:
  "ani(y) \<le> \<parallel>x\<rbrakk>ani(y) \<Longrightarrow> ani(y) \<le> \<parallel>x\<^sup>\<star>\<rbrakk>ani(y)"
  by (metis an_ani ani_def ani_star_induct_iff n_ani box_L_ani)

lemma ani_box_star_induct_iff:
  "ani(y) \<le> \<parallel>x\<rbrakk>ani(y) \<longleftrightarrow> ani(y) \<le> \<parallel>x\<^sup>\<star>\<rbrakk>ani(y)"
  using ani_box_star_induct box_L_left_antitone order_lesseq_imp star.circ_increasing by blast

lemma ani_box_star_induct_sup:
  "ani(y) \<le> \<parallel>x\<rbrakk>ani(y) \<Longrightarrow> ani(y) \<le> ani(z) \<Longrightarrow> ani(y) \<le> \<parallel>x\<^sup>\<star>\<rbrakk>ani(z)"
  by (meson ani_box_star_induct_iff box_L_right_isotone order_trans)

end

end


(*  Title:      ZF/Order.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

Results from the book "Set Theory: an Introduction to Independence Proofs"
        by Kenneth Kunen.  Chapter 1, section 6.
Additional definitions and lemmas for reflexive orders.
*)

section\<open>Partial and Total Orderings: Basic Definitions and Properties\<close>

theory Order imports WF Perm begin

text \<open>We adopt the following convention: \<open>ord\<close> is used for
  strict orders and \<open>order\<close> is used for their reflexive
  counterparts.\<close>

definition
  part_ord :: "[i,i]=>o"                (*Strict partial ordering*)  where
   "part_ord A r == irrefl A r & trans[A](r)"

definition
  linear   :: "[i,i]=>o"                (*Strict total ordering*)  where
   "linear A r == (\<forall>x\<in>A. \<forall>y\<in>A. <x,y>:r | x=y | <y,x>:r)"

definition
  tot_ord  :: "[i,i]=>o"                (*Strict total ordering*)  where
   "tot_ord A r == part_ord A r & linear A r"

definition
  "preorder_on A r \<equiv> refl A r \<and> trans[A](r)"

definition                              (*Partial ordering*)
  "partial_order_on A r \<equiv> preorder_on A r \<and> antisym(r)"

abbreviation
  "Preorder(r) \<equiv> preorder_on (field r) r"

abbreviation
  "Partial_order(r) \<equiv> partial_order_on (field r) r"

definition
  well_ord :: "[i,i]=>o"                (*Well-ordering*)  where
   "well_ord A r == tot_ord A r & wf[A](r)"

definition
  mono_map :: "[i,i,i,i]=>i"            (*Order-preserving maps*)  where
   "mono_map A r B s ==
              {f \<in> A->B. \<forall>x\<in>A. \<forall>y\<in>A. <x,y>:r \<longrightarrow> <f`x,f`y>:s}"

definition
  ord_iso  :: "[i,i,i,i]=>i"  ("(\<langle>_, _\<rangle> \<cong>/ \<langle>_, _\<rangle>)" 51)  (*Order isomorphisms*)  where
   "\<langle>A,r\<rangle> \<cong> \<langle>B,s\<rangle> ==
              {f \<in> bij A B. \<forall>x\<in>A. \<forall>y\<in>A. <x,y>:r \<longleftrightarrow> <f`x,f`y>:s}"

definition
  pred     :: "[i,i,i]=>i"              (*Set of predecessors*)  where
   "pred A x r == {y \<in> A. <y,x>:r}"

definition
  ord_iso_map :: "[i,i,i,i]=>i"         (*Construction for linearity theorem*)  where
   "ord_iso_map A r B s ==
     \<Union>x\<in>A. \<Union>y\<in>B. \<Union>f \<in> ord_iso (pred A x r) r (pred B y s) s. {<x,y>}"

definition
  first :: "[i, i, i] => o"  where
    "first u X R == u \<in> X & (\<forall>v\<in>X. v\<noteq>u \<longrightarrow> <u,v> \<in> R)"

subsection\<open>Immediate Consequences of the Definitions\<close>

lemma part_ord_Imp_asym:
    "part_ord A r ==> asym(r \<inter> A*A)"
by (unfold part_ord_def irrefl_def trans_on_def asym_def, blast)

lemma linearE:
    "[| linear A r;  x \<in> A;  y \<in> A;
        <x,y>:r ==> P;  x=y ==> P;  <y,x>:r ==> P |]
     ==> P"
by (simp add: linear_def, blast)

(** General properties of well_ord **)

lemma well_ordI:
    "[| wf[A](r); linear A r |] ==> well_ord A r"
apply (simp add: irrefl_def part_ord_def tot_ord_def
                 trans_on_def well_ord_def wf_on_not_refl)
apply (fast elim: linearE wf_on_asym wf_on_chain3)
done

lemma well_ord_is_wf:
    "well_ord A r ==> wf[A](r)"
by (unfold well_ord_def, safe)

lemma well_ord_is_trans_on:
    "well_ord A r ==> trans[A](r)"
by (unfold well_ord_def tot_ord_def part_ord_def, safe)

lemma well_ord_is_linear: "well_ord A r ==> linear A r"
by (unfold well_ord_def tot_ord_def, blast)

(** Derived rules for pred A x r **)

lemma pred_iff: "y \<in> pred A x r \<longleftrightarrow> <y,x>:r & y \<in> A"
by (unfold pred_def, blast)

lemmas predI = conjI [THEN pred_iff [THEN iffD2]]

lemma predE: "[| y \<in> pred A x r;  [| y \<in> A; <y,x>:r |] ==> P |] ==> P"
by (simp add: pred_def)

lemma pred_subset_under: "pred A x r \<subseteq> r -`` {x}"
by (simp add: pred_def, blast)

lemma pred_subset: "pred A x r \<subseteq> A"
by (simp add: pred_def, blast)

lemma pred_pred_eq:
    "pred (pred A x r) y r = pred A x r \<inter> pred A y r"
by (simp add: pred_def, blast)

lemma trans_pred_pred_eq:
    "[| trans[A](r);  <y,x>:r;  x \<in> A;  y \<in> A |]
     ==> pred (pred A x r) y r = pred A y r"
by (unfold trans_on_def pred_def, blast)

subsection\<open>Restricting an Ordering's Domain\<close>

(** The ordering's properties hold over all subsets of its domain
    [including initial segments of the form pred A x r **)

(*Note: a relation s such that s<=r need not be a partial ordering*)
lemma part_ord_subset:
    "[| part_ord A r;  B<=A |] ==> part_ord B r"
by (unfold part_ord_def irrefl_def trans_on_def, blast)

lemma linear_subset:
    "[| linear A r;  B<=A |] ==> linear B r"
by (unfold linear_def, blast)

lemma tot_ord_subset:
    "[| tot_ord A r;  B<=A |] ==> tot_ord B r"
apply (unfold tot_ord_def)
apply (fast elim!: part_ord_subset linear_subset)
done

lemma well_ord_subset:
    "[| well_ord A r;  B<=A |] ==> well_ord B r"
apply (unfold well_ord_def)
apply (fast elim!: tot_ord_subset wf_on_subset_A)
done

(** Relations restricted to a smaller domain, by Krzysztof Grabczewski **)

lemma irrefl_Int_iff: "irrefl A (r \<inter> A*A) \<longleftrightarrow> irrefl A r"
by (unfold irrefl_def, blast)

lemma trans_on_Int_iff: "trans[A](r \<inter> A*A) \<longleftrightarrow> trans[A](r)"
by (unfold trans_on_def, blast)

lemma part_ord_Int_iff: "part_ord A (r \<inter> A*A) \<longleftrightarrow> part_ord A r"
apply (unfold part_ord_def)
apply (simp add: irrefl_Int_iff trans_on_Int_iff)
done

lemma linear_Int_iff: "linear A (r \<inter> A*A) \<longleftrightarrow> linear A r"
by (unfold linear_def, blast)

lemma tot_ord_Int_iff: "tot_ord A (r \<inter> A*A) \<longleftrightarrow> tot_ord A r"
apply (unfold tot_ord_def)
apply (simp add: part_ord_Int_iff linear_Int_iff)
done

lemma wf_on_Int_iff: "wf[A](r \<inter> A*A) \<longleftrightarrow> wf[A](r)"
apply (unfold wf_on_def wf_def, fast) (*10 times faster than blast!*)
done

lemma well_ord_Int_iff: "well_ord A (r \<inter> A*A) \<longleftrightarrow> well_ord A r"
apply (unfold well_ord_def)
apply (simp add: tot_ord_Int_iff wf_on_Int_iff)
done

subsection\<open>Empty and Unit Domains\<close>

(*The empty relation is well-founded*)
lemma wf_on_any_0: "wf[A](0)"
by (simp add: wf_on_def wf_def, fast)

subsubsection\<open>Relations over the Empty Set\<close>

lemma irrefl_0: "irrefl 0 r"
by (unfold irrefl_def, blast)

lemma trans_on_0: "trans[0](r)"
by (unfold trans_on_def, blast)

lemma part_ord_0: "part_ord 0 r"
apply (unfold part_ord_def)
apply (simp add: irrefl_0 trans_on_0)
done

lemma linear_0: "linear 0 r"
by (unfold linear_def, blast)

lemma tot_ord_0: "tot_ord 0 r"
apply (unfold tot_ord_def)
apply (simp add: part_ord_0 linear_0)
done

lemma wf_on_0: "wf[0](r)"
by (unfold wf_on_def wf_def, blast)

lemma well_ord_0: "well_ord 0 r"
apply (unfold well_ord_def)
apply (simp add: tot_ord_0 wf_on_0)
done

subsubsection\<open>The Empty Relation Well-Orders the Unit Set\<close>

text\<open>by Grabczewski\<close>

lemma tot_ord_unit: "tot_ord {a} 0"
by (simp add: irrefl_def trans_on_def part_ord_def linear_def tot_ord_def)

lemma well_ord_unit: "well_ord {a} 0"
apply (unfold well_ord_def)
apply (simp add: tot_ord_unit wf_on_any_0)
done

subsection\<open>Order-Isomorphisms\<close>

text\<open>Suppes calls them "similarities"\<close>

(** Order-preserving (monotone) maps **)

lemma mono_map_is_fun: "f \<in> mono_map A r B s ==> f \<in> A->B"
by (simp add: mono_map_def)

lemma mono_map_is_inj:
    "[| linear A r;  wf[B](s);  f \<in> mono_map A r B s |] ==> f \<in> inj A B"
apply (unfold mono_map_def inj_def, clarify)
apply (erule_tac x=w and y=x in linearE, assumption+)
apply (force intro: apply_type dest: wf_on_not_refl)+
done

lemma ord_isoI:
    "[| f \<in> bij A B;
        !!x y. [| x \<in> A; y \<in> A |] ==> <x, y> \<in> r \<longleftrightarrow> <f`x, f`y> \<in> s |]
     ==> f \<in> ord_iso A r B s"
by (simp add: ord_iso_def)

lemma ord_iso_is_mono_map:
    "f \<in> ord_iso A r B s ==> f \<in> mono_map A r B s"
apply (simp add: ord_iso_def mono_map_def)
apply (blast dest!: bij_is_fun)
done

lemma ord_iso_is_bij:
    "f \<in> ord_iso A r B s ==> f \<in> bij A B"
by (simp add: ord_iso_def)

(*Needed?  But ord_iso_converse is!*)
lemma ord_iso_apply:
    "[| f \<in> ord_iso A r B s;  <x,y>: r;  x \<in> A;  y \<in> A |] ==> <f`x, f`y> \<in> s"
by (simp add: ord_iso_def)

lemma ord_iso_converse:
    "[| f \<in> ord_iso A r B s;  <x,y>: s;  x \<in> B;  y \<in> B |]
     ==> <converse(f) ` x, converse(f) ` y> \<in> r"
apply (simp add: ord_iso_def, clarify)
apply (erule bspec [THEN bspec, THEN iffD2])
apply (erule asm_rl bij_converse_bij [THEN bij_is_fun, THEN apply_type])+
apply (auto simp add: right_inverse_bij)
done

(** Symmetry and Transitivity Rules **)

(*Reflexivity of similarity*)
lemma ord_iso_refl: "id(A): ord_iso A r A r"
by (rule id_bij [THEN ord_isoI], simp)

(*Symmetry of similarity*)
lemma ord_iso_sym: "f \<in> ord_iso A r B s ==> converse(f): ord_iso B s A r"
apply (simp add: ord_iso_def)
apply (auto simp add: right_inverse_bij bij_converse_bij
                      bij_is_fun [THEN apply_funtype])
done

(*Transitivity of similarity*)
lemma mono_map_trans:
    "[| g \<in> mono_map A r B s;  f \<in> mono_map B s C t |]
     ==> (f O g): mono_map A r C t"
apply (unfold mono_map_def)
apply (auto simp add: comp_fun)
done

(*Transitivity of similarity: the order-isomorphism relation*)
lemma ord_iso_trans:
    "[| g \<in> ord_iso A r B s;  f \<in> ord_iso B s C t |]
     ==> (f O g): ord_iso A r C t"
apply (unfold ord_iso_def, clarify)
apply (frule bij_is_fun [of f])
apply (frule bij_is_fun [of g])
apply (auto simp add: comp_bij)
done

(** Two monotone maps can make an order-isomorphism **)

lemma mono_ord_isoI:
    "[| f \<in> mono_map A r B s;  g \<in> mono_map B s A r;
        f O g = id(B);  g O f = id(A) |] ==> f \<in> ord_iso A r B s"
apply (simp add: ord_iso_def mono_map_def, safe)
apply (intro fg_imp_bijective, auto)
apply (subgoal_tac "<g` (f`x), g` (f`y) > \<in> r")
apply (simp add: comp_eq_id_iff [THEN iffD1])
apply (blast intro: apply_funtype)
done

lemma well_ord_mono_ord_isoI:
     "[| well_ord A r;  well_ord B s;
         f \<in> mono_map A r B s;  converse(f): mono_map B s A r |]
      ==> f \<in> ord_iso A r B s"
apply (intro mono_ord_isoI, auto)
apply (frule mono_map_is_fun [THEN fun_is_rel])
apply (erule converse_converse [THEN subst], rule left_comp_inverse)
apply (blast intro: left_comp_inverse mono_map_is_inj well_ord_is_linear
                    well_ord_is_wf)+
done

(** Order-isomorphisms preserve the ordering's properties **)

lemma part_ord_ord_iso:
    "[| part_ord B s;  f \<in> ord_iso A r B s |] ==> part_ord A r"
apply (simp add: part_ord_def irrefl_def trans_on_def ord_iso_def)
apply (fast intro: bij_is_fun [THEN apply_type])
done

lemma linear_ord_iso:
    "[| linear B s;  f \<in> ord_iso A r B s |] ==> linear A r"
apply (simp add: linear_def ord_iso_def, safe)
apply (drule_tac x1 = "f`x" and x = "f`y" in bspec [THEN bspec])
apply (safe elim!: bij_is_fun [THEN apply_type])
apply (drule_tac t = "%x. converse f ` x" in subst_context)
apply (simp add: left_inverse_bij)
done

lemma wf_on_ord_iso:
    "[| wf[B](s);  f \<in> ord_iso A r B s |] ==> wf[A](r)"
apply (simp add: wf_on_def wf_def ord_iso_def, safe)
apply (drule_tac x = "{f`z. z \<in> Z \<inter> A}" in spec)
apply (safe intro!: equalityI)
apply (blast dest!: equalityD1 intro: bij_is_fun [THEN apply_type])+
done

lemma well_ord_ord_iso:
    "[| well_ord B s;  f \<in> ord_iso A r B s |] ==> well_ord A r"
apply (unfold well_ord_def tot_ord_def)
apply (fast elim!: part_ord_ord_iso linear_ord_iso wf_on_ord_iso)
done

subsection\<open>Main results of Kunen, Chapter 1 section 6\<close>

(*Inductive argument for Kunen's Lemma 6.1, etc.
  Simple proof from Halmos, page 72*)
lemma well_ord_iso_subset_lemma:
     "[| well_ord A r;  f \<in> ord_iso A r A' r;  A'<= A;  y \<in> A |]
      ==> ~ <f`y, y>: r"
apply (simp add: well_ord_def ord_iso_def)
apply (elim conjE CollectE)
apply (rule_tac a=y in wf_on_induct, assumption+)
apply (blast dest: bij_is_fun [THEN apply_type])
done

(*Kunen's Lemma 6.1 \<in> there's no order-isomorphism to an initial segment
                     of a well-ordering*)
lemma well_ord_iso_predE:
     "[| well_ord A r;  f \<in> ord_iso A r (pred A x r) r;  x \<in> A |] ==> P"
apply (insert well_ord_iso_subset_lemma [of A r f "pred A x r" x])
apply (simp add: pred_subset)
(*Now we know  f`x < x *)
apply (drule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
(*Now we also know @{term"f`x \<in> pred A x r"}: contradiction! *)
apply (simp add: well_ord_def pred_def)
done

(*Simple consequence of Lemma 6.1*)
lemma well_ord_iso_pred_eq:
     "[| well_ord A r;  f \<in> ord_iso (pred A a r) r (pred A c r) r;
         a \<in> A;  c \<in> A |] ==> a=c"
apply (frule well_ord_is_trans_on)
apply (frule well_ord_is_linear)
apply (erule_tac x=a and y=c in linearE, assumption+)
apply (drule ord_iso_sym)
(*two symmetric cases*)
apply (auto elim!: well_ord_subset [OF _ pred_subset, THEN well_ord_iso_predE]
            intro!: predI
            simp add: trans_pred_pred_eq)
done

(*Does not assume r is a wellordering!*)
lemma ord_iso_image_pred:
     "[|f \<in> ord_iso A r B s;  a \<in> A|] ==> f `` pred A a r = pred B (f`a) s"
apply (unfold ord_iso_def pred_def)
apply (erule CollectE)
apply (simp (no_asm_simp) add: image_fun [OF bij_is_fun Collect_subset])
apply (rule equalityI)
apply (safe elim!: bij_is_fun [THEN apply_type])
apply (rule RepFun_eqI)
apply (blast intro!: right_inverse_bij [symmetric])
apply (auto simp add: right_inverse_bij  bij_is_fun [THEN apply_funtype])
done

lemma ord_iso_restrict_image:
     "[| f \<in> ord_iso A r B s;  C<=A |]
      ==> restrict f C \<in> ord_iso C r (f``C) s"
apply (simp add: ord_iso_def)
apply (blast intro: bij_is_inj restrict_bij)
done

(*But in use, A and B may themselves be initial segments.  Then use
  trans_pred_pred_eq to simplify the pred(pred...) terms.  See just below.*)
lemma ord_iso_restrict_pred:
   "[| f \<in> ord_iso A r B s;   a \<in> A |]
    ==> restrict f (pred A a r) \<in> ord_iso (pred A a r) r (pred B (f`a) s) s"
apply (simp add: ord_iso_image_pred [symmetric])
apply (blast intro: ord_iso_restrict_image elim: predE)
done

(*Tricky; a lot of forward proof!*)
lemma well_ord_iso_preserving:
     "[| well_ord A r;  well_ord B s;  <a,c>: r;
         f \<in> ord_iso (pred A a r) r (pred B b s) s;
         g \<in> ord_iso (pred A c r) r (pred B d s) s;
         a \<in> A;  c \<in> A;  b \<in> B;  d \<in> B |] ==> <b,d>: s"
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], (erule asm_rl predI predE)+)
apply (subgoal_tac "b = g`a")
apply (simp (no_asm_simp))
apply (rule well_ord_iso_pred_eq, auto)
apply (frule ord_iso_restrict_pred, (erule asm_rl predI)+)
apply (simp add: well_ord_is_trans_on trans_pred_pred_eq)
apply (erule ord_iso_sym [THEN ord_iso_trans], assumption)
done

(*See Halmos, page 72*)
lemma well_ord_iso_unique_lemma:
     "[| well_ord A r;
         f \<in> ord_iso A r B s;  g \<in> ord_iso A r B s;  y \<in> A |]
      ==> ~ <g`y, f`y> \<in> s"
apply (frule well_ord_iso_subset_lemma)
apply (rule_tac f = "converse (f) " and g = g in ord_iso_trans)
apply auto
apply (blast intro: ord_iso_sym)
apply (frule ord_iso_is_bij [of f])
apply (frule ord_iso_is_bij [of g])
apply (frule ord_iso_converse)
apply (blast intro!: bij_converse_bij
             intro: bij_is_fun apply_funtype)+
apply (erule notE)
apply (simp add: left_inverse_bij bij_is_fun comp_fun_apply [of _ A B])
done

(*Kunen's Lemma 6.2: Order-isomorphisms between well-orderings are unique*)
lemma well_ord_iso_unique: "[| well_ord A r;
         f \<in> ord_iso A r B s;  g \<in> ord_iso A r B s |] ==> f = g"
apply (rule fun_extension)
apply (erule ord_iso_is_bij [THEN bij_is_fun])+
apply (subgoal_tac "f`x \<in> B & g`x \<in> B & linear B s")
 apply (simp add: linear_def)
 apply (blast dest: well_ord_iso_unique_lemma)
apply (blast intro: ord_iso_is_bij bij_is_fun apply_funtype
                    well_ord_is_linear well_ord_ord_iso ord_iso_sym)
done

subsection\<open>Towards Kunen's Theorem 6.3: Linearity of the Similarity Relation\<close>

lemma ord_iso_map_subset: "ord_iso_map A r B s \<subseteq> A*B"
by (unfold ord_iso_map_def, blast)

lemma domain_ord_iso_map: "domain(ord_iso_map A r B s) \<subseteq> A"
by (unfold ord_iso_map_def, blast)

lemma range_ord_iso_map: "range(ord_iso_map A r B s) \<subseteq> B"
by (unfold ord_iso_map_def, blast)

lemma converse_ord_iso_map:
    "converse(ord_iso_map A r B s) = ord_iso_map B s A r"
apply (unfold ord_iso_map_def)
apply (blast intro: ord_iso_sym)
done

lemma function_ord_iso_map:
    "well_ord B s ==> function(ord_iso_map A r B s)"
apply (unfold ord_iso_map_def function_def)
apply (blast intro: well_ord_iso_pred_eq ord_iso_sym ord_iso_trans)
done

lemma ord_iso_map_fun: "well_ord B s ==> ord_iso_map A r B s
           \<in> domain(ord_iso_map A r B s) -> range(ord_iso_map A r B s)"
by (simp add: Pi_iff function_ord_iso_map
                 ord_iso_map_subset [THEN domain_times_range])

lemma ord_iso_map_mono_map:
    "[| well_ord A r;  well_ord B s |]
     ==> ord_iso_map A r B s
           \<in> mono_map (domain (ord_iso_map A r B s)) r
                      (range (ord_iso_map A r B s)) s"
apply (unfold mono_map_def)
apply (simp (no_asm_simp) add: ord_iso_map_fun)
apply safe
apply (subgoal_tac "x \<in> A & ya:A & y \<in> B & yb:B")
 apply (simp add: apply_equality [OF _  ord_iso_map_fun])
 apply (unfold ord_iso_map_def)
 apply (blast intro: well_ord_iso_preserving, blast)
done

lemma ord_iso_map_ord_iso:
    "[| well_ord A r;  well_ord B s |] ==> ord_iso_map A r B s
           \<in> ord_iso (domain (ord_iso_map A r B s)) r
                     (range (ord_iso_map A r B s)) s"
apply (rule well_ord_mono_ord_isoI)
   prefer 4
   apply (rule converse_ord_iso_map [THEN subst])
   apply (simp add: ord_iso_map_mono_map
                    ord_iso_map_subset [THEN converse_converse])
apply (blast intro!: domain_ord_iso_map range_ord_iso_map
             intro: well_ord_subset ord_iso_map_mono_map)+
done

(*One way of saying that domain(ord_iso_map A r B s) is downwards-closed*)
lemma domain_ord_iso_map_subset:
     "[| well_ord A r;  well_ord B s;
         a \<in> A;  a \<notin> domain (ord_iso_map A r B s) |]
      ==>  domain (ord_iso_map A r B s) \<subseteq> pred A a r"
apply (unfold ord_iso_map_def)
apply (safe intro!: predI)
(*Case analysis on  xa vs a in r *)
apply (simp (no_asm_simp))
apply (frule_tac A = A in well_ord_is_linear)
apply (rename_tac b y f)
apply (erule_tac x=b and y=a in linearE, assumption+)
(*Trivial case: b=a*)
apply clarify
apply blast
(*Harder case: <a, xa>: r*)
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type],
       (erule asm_rl predI predE)+)
apply (frule ord_iso_restrict_pred)
 apply (simp add: pred_iff)
apply (simp split: split_if_asm
          add: well_ord_is_trans_on trans_pred_pred_eq domain_UN domain_Union, blast)
done

(*For the 4-way case analysis in the main result*)
lemma domain_ord_iso_map_cases:
     "[| well_ord A r;  well_ord B s |]
      ==> domain(ord_iso_map A r B s) = A |
          (\<exists>x\<in>A. domain(ord_iso_map A r B s) = pred A x r)"
apply (frule well_ord_is_wf)
apply (unfold wf_on_def wf_def)
apply (drule_tac x = "A-domain (ord_iso_map A r B s)" in spec)
apply safe
(*The first case: the domain equals A*)
apply (rule domain_ord_iso_map [THEN equalityI])
apply (erule Diff_eq_0_iff [THEN iffD1])
(*The other case: the domain equals an initial segment*)
apply (blast del: domainI subsetI
             elim!: predE
             intro!: domain_ord_iso_map_subset
             intro: subsetI)+
done

(*As above, by duality*)
lemma range_ord_iso_map_cases:
    "[| well_ord A r;  well_ord B s |]
     ==> range(ord_iso_map A r B s) = B |
         (\<exists>y\<in>B. range(ord_iso_map A r B s) = pred B y s)"
apply (rule converse_ord_iso_map [THEN subst])
apply (simp add: domain_ord_iso_map_cases)
done

text\<open>Kunen's Theorem 6.3: Fundamental Theorem for Well-Ordered Sets\<close>
theorem well_ord_trichotomy:
   "[| well_ord A r;  well_ord B s |]
    ==> ord_iso_map A r B s \<in> ord_iso A r B s |
        (\<exists>x\<in>A. ord_iso_map A r B s \<in> ord_iso (pred A x r) r B s) |
        (\<exists>y\<in>B. ord_iso_map A r B s \<in> ord_iso A r (pred B y s) s)"
apply (frule_tac B = B in domain_ord_iso_map_cases, assumption)
apply (frule_tac B = B in range_ord_iso_map_cases, assumption)
apply (drule ord_iso_map_ord_iso, assumption)
apply (elim disjE bexE)
   apply (simp_all add: bexI)
apply (rule wf_on_not_refl [THEN notE])
  apply (erule well_ord_is_wf)
 apply assumption
apply (subgoal_tac "<x,y>: ord_iso_map A r B s ")
 apply (drule rangeI)
 apply (simp add: pred_def)
apply (unfold ord_iso_map_def, blast)
done

subsection\<open>Miscellaneous Results by Krzysztof Grabczewski\<close>

(** Properties of converse(r) **)

lemma irrefl_converse: "irrefl A r ==> irrefl A (converse r)"
by (unfold irrefl_def, blast)

lemma trans_on_converse: "trans[A](r) ==> trans[A](converse(r))"
by (unfold trans_on_def, blast)

lemma part_ord_converse: "part_ord A r ==> part_ord A (converse r)"
apply (unfold part_ord_def)
apply (blast intro!: irrefl_converse trans_on_converse)
done

lemma linear_converse: "linear A r ==> linear A (converse r)"
by (unfold linear_def, blast)

lemma tot_ord_converse: "tot_ord A r ==> tot_ord A (converse r)"
apply (unfold tot_ord_def)
apply (blast intro!: part_ord_converse linear_converse)
done

(** By Krzysztof Grabczewski.
    Lemmas involving the first element of a well ordered set **)

lemma first_is_elem: "first b B r ==> b \<in> B"
by (unfold first_def, blast)

lemma well_ord_imp_ex1_first:
        "[| well_ord A r; B<=A; B\<noteq>0 |] ==> (\<exists>!b. first b B r)"
apply (unfold well_ord_def wf_on_def wf_def first_def)
apply (elim conjE allE disjE, blast)
apply (erule bexE)
apply (rule_tac a = x in ex1I, auto)
apply (unfold tot_ord_def linear_def, blast)
done

lemma the_first_in:
     "[| well_ord A r; B<=A; B\<noteq>0 |] ==> (THE b. first b B r) \<in> B"
apply (drule well_ord_imp_ex1_first, assumption+)
apply (rule first_is_elem)
apply (erule theI)
done

subsection \<open>Lemmas for the Reflexive Orders\<close>

lemma subset_vimage_vimage_iff:
  "[| Preorder(r); A \<subseteq> field(r); B \<subseteq> field(r) |] ==>
  r -`` A \<subseteq> r -`` B \<longleftrightarrow> (\<forall>a\<in>A. \<exists>b\<in>B. <a, b> \<in> r)"
  apply (auto simp: subset_def preorder_on_def refl_def vimage_def image_def)
   apply blast
  unfolding trans_on_def
  apply (erule_tac P = "(\<lambda>x. \<forall>y\<in>field(r).
          \<forall>z\<in>field(r). \<langle>x, y\<rangle> \<in> r \<longrightarrow> \<langle>y, z\<rangle> \<in> r \<longrightarrow> \<langle>x, z\<rangle> \<in> r)" for r in rev_ballE)
    (* instance obtained from proof term generated by best *)
   apply best
  apply blast
  done

lemma subset_vimage1_vimage1_iff:
  "[| Preorder(r); a \<in> field(r); b \<in> field(r) |] ==>
  r -`` {a} \<subseteq> r -`` {b} \<longleftrightarrow> <a, b> \<in> r"
  by (simp add: subset_vimage_vimage_iff)

lemma Refl_antisym_eq_Image1_Image1_iff:
  "[| refl (field r) r; antisym(r); a \<in> field(r); b \<in> field(r) |] ==>
  r `` {a} = r `` {b} \<longleftrightarrow> a = b"
  apply rule
   apply (frule equality_iffD)
   apply (drule equality_iffD)
   apply (simp add: antisym_def refl_def)
   apply best
  apply (simp add: antisym_def refl_def)
  done

lemma Partial_order_eq_Image1_Image1_iff:
  "[| Partial_order(r); a \<in> field(r); b \<in> field(r) |] ==>
  r `` {a} = r `` {b} \<longleftrightarrow> a = b"
  by (simp add: partial_order_on_def preorder_on_def
    Refl_antisym_eq_Image1_Image1_iff)

lemma Refl_antisym_eq_vimage1_vimage1_iff:
  "[| refl (field r) r; antisym(r); a \<in> field(r); b \<in> field(r) |] ==>
  r -`` {a} = r -`` {b} \<longleftrightarrow> a = b"
  apply rule
   apply (frule equality_iffD)
   apply (drule equality_iffD)
   apply (simp add: antisym_def refl_def)
   apply best
  apply (simp add: antisym_def refl_def)
  done

lemma Partial_order_eq_vimage1_vimage1_iff:
  "[| Partial_order(r); a \<in> field(r); b \<in> field(r) |] ==>
  r -`` {a} = r -`` {b} \<longleftrightarrow> a = b"
  by (simp add: partial_order_on_def preorder_on_def
    Refl_antisym_eq_vimage1_vimage1_iff)

end


(*  Title:      HOL/Induct/Tree.thy
    Author:     Stefan Berghofer,  TU Muenchen
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Infinitely branching trees\<close>

theory Tree
imports Main
begin

datatype 'a tree =
    Atom 'a
  | Branch "nat \<Rightarrow> 'a tree"

primrec map_tree :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a tree \<Rightarrow> 'b tree"
where
  "map_tree f (Atom a) = Atom (f a)"
| "map_tree f (Branch ts) = Branch (\<lambda>x. map_tree f (ts x))"

lemma tree_map_compose: "map_tree g (map_tree f t) = map_tree (g \<circ> f) t"
  by (induct t) simp_all

primrec exists_tree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a tree \<Rightarrow> bool"
where
  "exists_tree P (Atom a) = P a"
| "exists_tree P (Branch ts) = (\<exists>x. exists_tree P (ts x))"

lemma exists_map:
  "(\<And>x. P x \<Longrightarrow> Q (f x)) \<Longrightarrow>
    exists_tree P ts \<Longrightarrow> exists_tree Q (map_tree f ts)"
  by (induct ts) auto

subsection\<open>The Brouwer ordinals, as in ZF/Induct/Brouwer.thy.\<close>

datatype brouwer = Zero | Succ brouwer | Lim "nat \<Rightarrow> brouwer"

text \<open>Addition of ordinals\<close>
primrec add :: "brouwer \<Rightarrow> brouwer \<Rightarrow> brouwer"
where
  "add i Zero = i"
| "add i (Succ j) = Succ (add i j)"
| "add i (Lim f) = Lim (\<lambda>n. add i (f n))"

text \<open>Multiplication of ordinals\<close>
primrec mult :: "brouwer \<Rightarrow> brouwer \<Rightarrow> brouwer"
where
  "mult i Zero = Zero"
| "mult i (Succ j) = add (mult i j) i"
| "mult i (Lim f) = Lim (\<lambda>n. mult i (f n))"

lemma add_mult_distrib: "mult i (add j k) = add (mult i j) (mult i k)"
  by (induct k) (auto simp add: add_assoc)

lemma mult_assoc: "mult (mult i j) k = mult i (mult j k)"
  by (induct k) (auto simp add: add_mult_distrib)

text \<open>We could probably instantiate some axiomatic type classes and use
  the standard infix operators.\<close>

subsection \<open>A WF Ordering for The Brouwer ordinals (Michael Compton)\<close>

text \<open>To use the function package we need an ordering on the Brouwer
  ordinals.  Start with a predecessor relation and form its transitive
  closure.\<close>

definition brouwer_pred :: "(brouwer \<times> brouwer) set"
  where "brouwer_pred = (\<Union>i. {(m, n). n = Succ m \<or> (\<exists>f. n = Lim f \<and> m = f i)})"

definition brouwer_order :: "(brouwer \<times> brouwer) set"
  where "brouwer_order = brouwer_pred^+"

lemma wf_brouwer_pred: "wf brouwer_pred"
  unfolding wf_def brouwer_pred_def
  apply clarify
  apply (induct_tac x)
  apply blast+
  done

lemma wf_brouwer_order[simp]: "wf brouwer_order"
  unfolding brouwer_order_def
  by (rule wf_trancl[OF wf_brouwer_pred])

lemma [simp]: "(f n, Lim f) \<in> brouwer_order"
  by (auto simp add: brouwer_order_def brouwer_pred_def)

text \<open>Example of a general function\<close>
function add2 :: "brouwer \<Rightarrow> brouwer \<Rightarrow> brouwer"
where
  "add2 i Zero = i"
| "add2 i (Succ j) = Succ (add2 i j)"
| "add2 i (Lim f) = Lim (\<lambda>n. add2 i (f n))"
by pat_completeness auto
termination by (relation "inv_image brouwer_order snd") auto

lemma add2_assoc: "add2 (add2 i j) k = add2 i (add2 j k)"
  by (induct k) auto

end


theory E3_5
  imports Main
begin

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
S0 : "S []" |
S1 : "S w \<Longrightarrow> S (a # w @ [b])" |
S2 : "S w \<Longrightarrow> S v \<Longrightarrow> S (w @ v)"

inductive T :: "alpha list \<Rightarrow> bool" where
T0 : "T []" |
T1 : "T w \<Longrightarrow> T v \<Longrightarrow> T (w @ [a] @ v @ [b])"

lemma T_cat [simp] : "T v \<Longrightarrow> T w \<Longrightarrow> T (w @ v)"
  apply (induction rule : T.induct)
  apply simp
  by (metis T.simps append.assoc)

lemma "S w = T w"
  apply (rule)
  apply (induction rule : S.induct)
  apply (rule T0)
  apply auto
  apply (metis T.simps append_Cons append_Nil)
  apply (induction rule : T.induct)
  apply (rule S0)
  by (simp add: S1 S2)

end


(*<*)
theory Untyped_Lambda_Calculus
imports Nameless_Representation_Of_Terms
begin
(*>*)

section {* Untyped Lambda-Calculus *}
text {* \label{sec:untyped-lambda-calculus} *}

text {*
The untyped lambda calculus is the first core calculus we formalize. It imports the theory on the
nameless representation of terms (Section~\ref{sec:nameless-rep-of-terms}), which formalizes the
representation used for the syntax of the language. We complete the definitions, by providing the
semantics, and we prove the determinacy of evaluation, the relation between values and normal form,
the uniqueness of normal form and the potentially non-terminating nature of evaluation.
*}

subsection {* Definitions *}

text {*
In the pure $\lambda$-calculus, only function abstractions are considered values:
*}

inductive is_value_UL :: "ulterm \<Rightarrow> bool" where
  "is_value_UL (ULAbs t)"

text {*
Variables are not part of this definition because they are a way to refer to a specific
$\lambda$-abstraction. Since abstractions are themselves values, we do not need to consider their
bound variables. The only ones we could consider as values are the free variables, i.e. variables
referring to non-existing $\lambda$-abstractions. In the following examples, every occurrence of
@{term w} is free:

\begin{displaymath}
  w \qquad (\lambda x. \ x) \ w \qquad (\lambda x. \lambda y. \lambda z. \ w \ x \ y \ z)
\end{displaymath}

There is no consensus on how the semantics should handle such situations. By excluding them from the
set of values, the semantics described in the book defines that such terms are meaningless. This
decision is consistent with many programming languages where the use of an undefined identifier
leads to an error, either at compile-time or at run-time.

The single-step evaluation relation is defined, in the book, with the following inference rules
where $[x \mapsto s] \ t$ is the replacement of variable $x$ by $s$ in $t$:
\setcounter{equation}{0}
\begin{gather}
  \inferrule {t_1 \implies t_1'}{t_1 \ t_2 \implies t_1' \ t_2} \\[0.8em]
  \inferrule {t_2 \implies t_2'}{v_1 \ t_2 \implies v_1 \ t_2'} \\[0.8em]
  \inferrule {}{(\lambda x. \ t_{12}) \ v_2 \implies [x \mapsto v_2] \ t_{12}}
\end{gather}

The first rule states that the left side of an application must be reduced first, the second rule
states that the right side of an application must be reduced second and the third rule states that
an application consists of replacing both the $\lambda$-abstraction and the argument by the
$\lambda$-abstraction's body where the substitution has been performed. We translate these rules
with the following inductive definition:
*}

inductive eval1_UL :: "ulterm \<Rightarrow> ulterm \<Rightarrow> bool" where
  eval1_ULApp1:
    "eval1_UL t1 t1' \<Longrightarrow> eval1_UL (ULApp t1 t2) (ULApp t1' t2)" |
  eval1_ULApp2:
    "is_value_UL v1 \<Longrightarrow> eval1_UL t2 t2' \<Longrightarrow> eval1_UL (ULApp v1 t2)
      (ULApp v1 t2')" |
  eval1_ULApp_ULAbs:
    "is_value_UL v2 \<Longrightarrow> eval1_UL (ULApp (ULAbs t12) v2)
      (shift_UL (-1) 0 (subst_UL 0 (shift_UL 1 0 v2) t12))"

text {*
Apart from the explicit assumption on the nature of @{term v1}, the only difference is the
substitution in the third rule. This is the reason that motivated us to formalize the nameless
representation of terms in the first place. The book uses a high level definition of substitution
where name clashes are not considered. We replace this higher level operation by our concrete
substitution operation on de Bruijn indices. We begin by shifting up by on the concrete argument
because, conceptually, it \emph{enters} the function abstraction. We then perform the proper
substitution of the function's variable, i.e. of index zero. Finally, we shift down every variable
of the resulting body to account for the removed $\lambda$-abstraction.

The multi-step evaluation relation and the normal form definitions follow the usual pattern:
*}

inductive eval_UL :: "ulterm \<Rightarrow> ulterm \<Rightarrow> bool" where
  eval_UL_base:
    "eval_UL t t" |
  eval_UL_step:
    "eval1_UL t t' \<Longrightarrow> eval_UL t' t'' \<Longrightarrow> eval_UL t t''"

definition is_normal_form_UL :: "ulterm \<Rightarrow> bool" where
  "is_normal_form_UL t \<longleftrightarrow> (\<forall>t'. \<not> eval1_UL t t')"

subsection {* Theorems *}

text {*
In the book, this chapter consists mainly of the presentation of the $\lambda$-calculus, of which we
gave a short introduction in the background section (Section~\ref{sec:background-lambda-calculus}),
and does not contains meaningful theorems. Nevertheless, we revisit the properties
introduced with the arithmetic expressions language (Section~\ref{sec:untyped-arith-expr}) and
either prove that they are still theorems or disprove them.
*}

(* Theorem 3.5.4 for Untyped Lambda Calculus *)

text {*
The determinacy of the single-step evaluation still holds:
*}

theorem eval1_UL_determinacy:
  "eval1_UL t t' \<Longrightarrow> eval1_UL t t'' \<Longrightarrow> t' = t''"
proof (induction t t' arbitrary: t'' rule: eval1_UL.induct)
  case (eval1_ULApp1 t1 t1' t2)
  from eval1_ULApp1.hyps eval1_ULApp1.prems show ?case
    by (auto elim: eval1_UL.cases is_value_UL.cases intro: eval1_ULApp1.IH)
next
  case (eval1_ULApp2 t1 t2 t2')
  from eval1_ULApp2.hyps eval1_ULApp2.prems show ?case
    by (auto elim: eval1_UL.cases is_value_UL.cases intro: eval1_ULApp2.IH)
next
  case (eval1_ULApp_ULAbs v2 t12)
  thus ?case by (auto elim: eval1_UL.cases simp: is_value_UL.simps)
qed

(* Definition 3.5.6 for Untyped Lambda Calculus *)

text {*
Every value is in normal form:
*}

(* Theorem 3.5.7 for Untyped Lambda Calculus *)

theorem value_imp_normal_form:
  "is_value_UL t \<Longrightarrow> is_normal_form_UL t"
by (auto elim: is_value_UL.cases eval1_UL.cases simp: is_normal_form_UL_def)

(* Theorem 3.5.8 does not hold for Untyped Lambda calculus *)
text {*
Meanwhile, the converse of the preceding theorem is not true since variables are in normal form but
are not values:
*}

theorem normal_form_does_not_imp_value:
  "\<exists>t. is_normal_form_UL t \<and> \<not> is_value_UL t" (is "\<exists>t. ?P t")
proof
  have a: "\<And>n. is_normal_form_UL (ULVar n)"
    by (auto simp: is_normal_form_UL_def elim: eval1_UL.cases)
  have b: "\<And>n. \<not> is_value_UL (ULVar n)"
    by (auto simp: is_normal_form_UL_def elim: is_value_UL.cases)
  from a b show "\<And>n. ?P (ULVar n)" by simp
qed

(* Corollary 3.5.11 for Untyped Lambda Calculus *)

text {*
The uniqueness of normal form still holds:
*}

corollary uniqueness_of_normal_form:
  "eval_UL t u \<Longrightarrow> eval_UL t u' \<Longrightarrow> is_normal_form_UL u \<Longrightarrow> is_normal_form_UL u' \<Longrightarrow> u = u'"
by (induction t u rule: eval_UL.induct)
  (metis eval_UL.cases is_normal_form_UL_def eval1_UL_determinacy)+

(* Theorem 3.5.12 does not hold for Untyped Lambda calculus *)

text {*
This time, the evaluation relation could be non-terminating. A typical example of term whose
evaluation does not terminate is the self-application combinator
($\omega \: \equiv \: \lambda x. \ x \ x$) applied to itself, resulting in a term called $\Omega$:
*}

(*<*)
lemma eval1_UL_ULVarD: "eval1_UL (ULVar x) t \<Longrightarrow> P"
  by (induction "ULVar x" t rule: eval1_UL.induct)

lemma eval1_UL_ULAbsD: "eval1_UL (ULAbs x) t \<Longrightarrow> P"
  by (induction "ULAbs x" t rule: eval1_UL.induct)
(*>*)

definition \<omega> :: ulterm where
  "\<omega> \<equiv> ULAbs (ULApp (ULVar 0) (ULVar 0))"

definition \<Omega> :: ulterm where
  "\<Omega> \<equiv> ULApp \<omega> \<omega>"

text {*
A single step of evaluation will result in the same term:
*}

lemma eval1_UL_\<Omega>:
  "eval1_UL \<Omega> t \<Longrightarrow> \<Omega> = t"
by (induction \<Omega> t rule: eval1_UL.induct)
  (auto elim: eval1_UL_ULAbsD simp: \<omega>_def \<Omega>_def)

text {*
Since the single-step evaluation is equivalent to the identity, the multi-step evaluation relation
will loop infinitely (e.g. $\Omega \to \Omega \to \dots$):
*}

lemma eval_UL_\<Omega>:
  "eval_UL \<Omega> t \<Longrightarrow> \<Omega> = t"
by (induction \<Omega> t rule: eval_UL.induct) (blast dest: eval1_UL_\<Omega>)+

lemma
  "eval_UL \<Omega> \<Omega>"
by (rule eval_UL.intros)

text {*
Based on this simple example, we can show that there exists some terms which cannot be reduce to a
normal form:
*}

theorem eval_does_not_always_terminate:
  "\<exists>t. \<forall>t'. eval_UL t t' \<longrightarrow> \<not> is_normal_form_UL t'" (is "\<exists>t. \<forall>t'. ?P t t'")
proof
  show "\<forall>t'. ?P \<Omega> t'"
    by (auto dest!: eval_UL_\<Omega>)
      (auto
        intro: eval1_UL.intros is_value_UL.intros
        simp: \<omega>_def \<Omega>_def is_normal_form_UL_def)
qed

(*<*)
end
(*>*)


header {* The ``sturm'' proof method *}

(* Author: Manuel Eberl <eberlm@in.tum.de> *)
theory Sturm_Method
imports Sturm_Theorem
begin

subsection {* Preliminary lemmas *}

text {*
  In this subsection, we prove lemmas that reduce root counting and
  related statements to simple, computable expressions using the
  @{term "count_roots"} function family.
*}

lemma poly_card_roots_less_leq:
  "card {x. a < x \<and> x \<le> b \<and> poly p x = 0} = count_roots_between p a b"
  by (simp add: count_roots_between_correct)

lemma poly_card_roots_leq_leq:
  "card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
       ( count_roots_between p a b +
      (if (a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0) then 1 else 0))"
proof (cases "(a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0)")
  case False
    note False' = this
    thus ?thesis
    proof (cases "p = 0")
      case False
        with False' have "poly p a \<noteq> 0 \<or> a > b" by auto
        hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
               {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
        by (auto simp: less_eq_real_def)
        thus ?thesis using poly_card_roots_less_leq assms False'
            by (auto split: split_if_asm)
    next
      case True
        have "{x. a \<le> x \<and> x \<le> b} = {a..b}"
             "{x. a < x \<and> x \<le> b} = {a<..b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x \<le> b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ioc infinite_Icc)
        with True False show ?thesis
            using count_roots_between_correct by (simp add: )
    qed
next
  case True
    note True' = this
    have fin: "finite {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0}"
    proof (cases "p = 0")
      case True
        with True' have "a = b" by simp
        hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} = {b}" using True by auto
        thus ?thesis by simp
    next
      case False
        from poly_roots_finite[OF this] show ?thesis by fast
    qed
    with True have "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
        insert a {x. a < x \<and> x \<le> b \<and> poly p x = 0}" by auto
    hence "card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
           Suc (card {x. a < x \<and> x \<le> b \<and> poly p x = 0})" using fin by force
    thus ?thesis using True count_roots_between_correct by simp
qed

lemma poly_card_roots_less_less:
  "card {x. a < x \<and> x < b \<and> poly p x = 0} =
      ( count_roots_between p a b -
              (if poly p b = 0 \<and> a < b \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p b = 0 \<and> a < b \<and> p \<noteq> 0")
  case False
    note False' = this
    show ?thesis
    proof (cases "p = 0")
      case True
        have [simp]: "{x. a < x \<and> x < b} = {a<..<b}"
                     "{x. a < x \<and> x \<le> b} = {a<..b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a < x \<and> x < b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ioo infinite_Ioc)
        with True False' assms show ?thesis
            by (auto simp: count_roots_between_correct)
    next
      case False
        with False' have "{x. a < x \<and> x < b \<and> poly p x = 0} =
                          {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis using poly_card_roots_less_leq assms False by auto
  qed
next
  case True
    with poly_roots_finite
        have fin: "finite {x. a < x \<and> x < b \<and> poly p x = 0}" by fast
    from True have "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
        insert b {x. a < x \<and> x < b \<and> poly p x = 0}" by auto
    hence "Suc (card {x. a < x \<and> x < b \<and> poly p x = 0}) =
           card {x. a < x \<and> x \<le> b \<and> poly p x = 0}" using fin by force
    also note count_roots_between_correct[symmetric]
    finally show ?thesis using True by simp
qed

lemma poly_card_roots_leq_less:
  "card {x::real. a \<le> x \<and> x < b \<and> poly p x = 0} =
      ( count_roots_between p a b +
      (if p \<noteq> 0 \<and> a < b \<and> poly p a = 0 then 1 else 0) -
      (if p \<noteq> 0 \<and> a < b \<and> poly p b = 0 then 1 else 0))"
proof (cases "p = 0 \<or> a \<ge> b")
  case True
    note True' = this
    show ?thesis
    proof (cases "a \<ge> b")
      case False
        hence "{x. a < x \<and> x \<le> b} = {a<..b}"
              "{x. a \<le> x \<and> x < b} = {a..<b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x < b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ico infinite_Ioc)
        with False True' show ?thesis
            by (simp add: count_roots_between_correct)
    next
      case True
        with True' have "{x. a \<le> x \<and> x < b \<and> poly p x = 0} =
                          {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis using poly_card_roots_less_leq True by simp
  qed
next
  case False
    let ?A = "{x. a \<le> x \<and> x < b \<and> poly p x = 0}"
    let ?B = "{x. a < x \<and> x \<le> b \<and> poly p x = 0}"
    let ?C = "{x. x = b \<and> poly p x = 0}"
    let ?D = "{x. x = a \<and> poly p a = 0}"
    have CD_if: "?C = (if poly p b = 0 then {b} else {})"
                "?D = (if poly p a = 0 then {a} else {})" by auto
    from False poly_roots_finite
        have [simp]: "finite ?A" "finite ?B" "finite ?C" "finite ?D"
            by (fast, fast, simp_all)

    from False have "?A = (?B \<union> ?D) - ?C" by (auto simp: less_eq_real_def)
    with False have "card ?A = card ?B + (if poly p a = 0 then 1 else 0) -
                       (if poly p b = 0 then 1 else 0)" by (auto simp: CD_if)
    also note count_roots_between_correct[symmetric]
    finally show ?thesis using False by simp
qed

lemma poly_card_roots:
  "card {x::real. poly p x = 0} = count_roots p"
  using assms count_roots_correct by simp

lemma poly_no_roots:
  "(\<forall>x. poly p x \<noteq> 0) \<longleftrightarrow> ( p \<noteq> 0 \<and> count_roots p = 0)"
    by (auto simp: count_roots_correct dest: poly_roots_finite)

lemma poly_pos:
  "(\<forall>x. poly p x > 0) \<longleftrightarrow> (
        p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots p = 0)"
  by (simp only: Let_def poly_pos poly_no_roots, blast)

lemma poly_card_roots_greater:
  "card {x::real. x > a \<and> poly p x = 0} = count_roots_above p a"
  using assms count_roots_above_correct by simp

lemma poly_card_roots_leq:
  "card {x::real. x \<le> a \<and> poly p x = 0} = count_roots_below p a"
  using assms  count_roots_below_correct by simp

lemma poly_card_roots_geq:
  "card {x::real. x \<ge> a \<and> poly p x = 0} = (
      count_roots_above p a + (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p a = 0 \<and> p \<noteq> 0")
  case False
    hence "card {x. x \<ge> a \<and> poly p x = 0} = card {x. x > a \<and> poly p x = 0}"
    proof (cases rule: disjE)
      assume "p = 0"
      have "\<not>finite {a<..<a+1}"
        by (metis infinite_Ioo less_add_one)
      moreover have "{a<..<a+1} \<subseteq> {x. x \<ge> a \<and> poly p x = 0}"
                    "{a<..<a+1} \<subseteq> {x. x > a \<and> poly p x = 0}"
          using `p = 0` by auto
      ultimately have "\<not>finite {x. x \<ge> a \<and> poly p x = 0}"
                     "\<not>finite {x. x > a \<and> poly p x = 0}"
          by (auto dest: finite_subset[of "{a<..<a+1}"])
      thus ?thesis by simp
    next
      assume "poly p a \<noteq> 0"
      hence "{x. x \<ge> a \<and> poly p x = 0} = {x. x > a \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis by simp
    qed auto
    thus ?thesis using assms False
        by (auto intro: poly_card_roots_greater)
next
  case True
    hence "finite {x. x > a \<and> poly p x = 0}" using poly_roots_finite by force
    moreover have "{x. x \<ge> a \<and> poly p x = 0} =
                       insert a {x. x > a \<and> poly p x = 0}" using True by auto
    ultimately have "card {x. x \<ge> a \<and> poly p x = 0} =
                         Suc (card {x. x > a \<and> poly p x = 0})"
        using card_insert_disjoint by auto
    thus ?thesis using assms True by (auto intro: poly_card_roots_greater)
qed

lemma poly_card_roots_less:
  "card {x::real. x < a \<and> poly p x = 0} =
       (count_roots_below p a - (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p a = 0 \<and> p \<noteq> 0")
  case False
    hence "card {x. x < a \<and> poly p x = 0} = card {x. x \<le> a \<and> poly p x = 0}"
    proof (cases rule: disjE)
      assume "p = 0"
      have "\<not>finite {a - 1<..<a}"
        by (metis infinite_Ioo diff_add_cancel less_add_one)
      moreover have "{a - 1<..<a} \<subseteq> {x. x \<le> a \<and> poly p x = 0}"
                    "{a - 1<..<a} \<subseteq> {x. x < a \<and> poly p x = 0}"
          using `p = 0` by auto
      ultimately have "\<not>finite {x. x \<le> a \<and> poly p x = 0}"
                     "\<not>finite {x. x < a \<and> poly p x = 0}"
          by (auto dest: finite_subset[of "{a - 1<..<a}"])
      thus ?thesis by simp
    next
      assume "poly p a \<noteq> 0"
      hence "{x. x < a \<and> poly p x = 0} = {x. x \<le> a \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis by simp
    qed auto
    thus ?thesis using assms False
        by (auto intro: poly_card_roots_leq)
next
  case True
    hence "finite {x. x < a \<and> poly p x = 0}" using poly_roots_finite by force
    moreover have "{x. x \<le> a \<and> poly p x = 0} =
                       insert a {x. x < a \<and> poly p x = 0}" using True by auto
    ultimately have "Suc (card {x. x < a \<and> poly p x = 0}) =
                     (card {x. x \<le> a \<and> poly p x = 0})"
        using card_insert_disjoint by auto
    also note count_roots_below_correct[symmetric]
    finally show ?thesis using assms True by simp
qed

lemma poly_no_roots_less_leq:
  "(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> count_roots_between p a b = 0)))"
  by (auto simp: count_roots_between_correct card_eq_0_iff not_le
           dest: poly_roots_finite)

lemma poly_pos_between_less_leq:
  "(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p b > 0 \<and> count_roots_between p a b = 0)))"
  by (simp only: poly_pos_between_less_leq Let_def
                 poly_no_roots_less_leq, blast)

lemma poly_no_roots_leq_leq:
  "(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a > b \<or> (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b = 0)))"
apply (intro iffI)
apply (force simp add: count_roots_between_correct card_eq_0_iff)
apply (elim conjE disjE, simp, intro allI)
apply (rename_tac x, case_tac "x = a")
apply (auto simp add: count_roots_between_correct card_eq_0_iff
            dest: poly_roots_finite)
done

lemma poly_pos_between_leq_leq:
  "(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a > b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and>
                count_roots_between p a b = 0)))"
by (simp only: poly_pos_between_leq_leq Let_def poly_no_roots_leq_leq, force)

lemma poly_no_roots_less_less:
  "(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> p \<noteq> 0 \<and> count_roots_between p a b =
       (if poly p b = 0 then 1 else 0)))"
proof
  case goal1
    note A = this
    thus ?case
    proof (cases "a \<ge> b", simp)
      case goal1
      with A have [simp]: "p \<noteq> 0" using dense[of a b] by auto
      have B: "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
                {x. a < x \<and> x < b \<and> poly p x = 0} \<union>
                (if poly p b = 0 then {b} else {})" using goal1 by auto
      have "count_roots_between p a b =
                 card {x. a < x \<and> x < b \<and> poly p x = 0} +
                (if poly p b = 0 then 1 else 0)"
         by (subst count_roots_between_correct, subst B, subst card_Un_disjoint,
             rule finite_subset[OF _ poly_roots_finite], blast, simp_all)
      also from A have "{x. a < x \<and> x < b \<and> poly p x = 0} = {}" by simp
      finally show ?thesis by auto
    qed
next
  case goal2
    hence "card {x. a < x \<and> x < b \<and> poly p x = 0} = 0"
        by (subst poly_card_roots_less_less, auto simp: count_roots_between_def)
    thus ?case using goal2
        by (cases "p = 0", simp, subst (asm) card_eq_0_iff,
            auto dest: poly_roots_finite)
qed

lemma poly_pos_between_less_less:
  "(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p ((a+b)/2) > 0 \<and>
       count_roots_between p a b = (if poly p b = 0 then 1 else 0))))"
  by (simp only: poly_pos_between_less_less Let_def
                 poly_no_roots_less_less, blast)

lemma poly_no_roots_leq_less:
  "(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b =
       (if a < b \<and> poly p b = 0 then 1 else 0)))"
proof
  case goal1
    hence "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by simp
    thus ?case using goal1 by (subst (asm) poly_no_roots_less_less, auto)
next
  case goal2
    hence "(b \<le> a \<or> p \<noteq> 0 \<and> count_roots_between p a b =
               (if poly p b = 0 then 1 else 0))" by auto
    thus ?case using goal2 unfolding Let_def
        by (subst (asm) poly_no_roots_less_less[symmetric, unfolded Let_def],
        auto split: split_if_asm simp: less_eq_real_def)
qed

lemma poly_pos_between_leq_less:
  "(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and> count_roots_between p a b =
        (if a < b \<and> poly p b = 0 then 1 else 0))))"
 by (simp only: poly_pos_between_leq_less Let_def
                poly_no_roots_leq_less, force)

lemma poly_no_roots_greater:
  "(\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ((p \<noteq> 0 \<and> count_roots_above p a = 0))"
proof-
  have "\<forall>x. \<not> a < x \<Longrightarrow> False" by (metis gt_ex)
  thus ?thesis by (auto simp: count_roots_above_correct card_eq_0_iff
                        intro: poly_roots_finite )
qed

lemma poly_pos_greater:
  "(\<forall>x. x > a \<longrightarrow> poly p x > 0) \<longleftrightarrow> (
       p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots_above p a = 0)"
  unfolding Let_def
  by (subst poly_pos_greater, subst poly_no_roots_greater, force)

lemma poly_no_roots_leq:
  "(\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ( (p \<noteq> 0 \<and> count_roots_below p a = 0))"
    by (auto simp: Let_def count_roots_below_correct card_eq_0_iff
             intro: poly_roots_finite)

lemma poly_pos_leq:
  "(\<forall>x. x \<le> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ( p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a = 0)"
  by (simp only: poly_pos_leq Let_def poly_no_roots_leq, blast)

lemma poly_no_roots_geq:
  "(\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ( (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0))"
proof
  case goal1
  hence "\<forall>x>a. poly p x \<noteq> 0" by simp
  thus ?case using goal1 by (subst (asm) poly_no_roots_greater, auto)
next
  case goal2
  hence "(p \<noteq> 0 \<and> count_roots_above p a = 0)" by simp
  thus ?case using goal2
      by (subst (asm) poly_no_roots_greater[symmetric, unfolded Let_def],
          auto simp: less_eq_real_def)
qed

lemma poly_pos_geq:
  "(\<forall>x. x \<ge> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   (p \<noteq> 0 \<and> poly_inf p = 1 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0)"
  by (simp only: poly_pos_geq Let_def poly_no_roots_geq, blast)

lemma poly_no_roots_less:
  "(\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ((p \<noteq> 0 \<and> count_roots_below p a = (if poly p a = 0 then 1 else 0)))"
proof
  case goal1
  hence "{x. x \<le> a \<and> poly p x = 0} = (if poly p a = 0 then {a} else {})"
      by (auto simp: less_eq_real_def)
  moreover have "\<forall>x. \<not> x < a \<Longrightarrow> False" by (metis lt_ex)
  ultimately show ?case using goal1 by (auto simp: count_roots_below_correct)
next
  case goal2
  have A: "{x. x \<le> a \<and> poly p x = 0} = {x. x < a \<and> poly p x = 0} \<union>
            (if poly p a = 0 then {a} else {})" by (auto simp: less_eq_real_def)
  have "count_roots_below p a = card {x. x < a \<and> poly p x = 0} +
            (if poly p a = 0 then 1 else 0)" using goal2
      by (subst count_roots_below_correct, subst A, subst card_Un_disjoint,
          auto intro: poly_roots_finite)
  with goal2 have "card {x. x < a \<and> poly p x = 0} = 0" by simp
  thus ?case using goal2
      by (subst (asm) card_eq_0_iff, auto intro: poly_roots_finite)
qed

lemma poly_pos_less:
  "(\<forall>x. x < a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   (p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a =
       (if poly p a = 0 then 1 else 0))"
  by (simp only: poly_pos_less Let_def poly_no_roots_less, blast)

lemmas sturm_card_substs = poly_card_roots poly_card_roots_less_leq
    poly_card_roots_leq_less poly_card_roots_less_less poly_card_roots_leq_leq
    poly_card_roots_less poly_card_roots_leq poly_card_roots_greater
    poly_card_roots_geq

lemmas sturm_prop_substs = poly_no_roots poly_no_roots_less_leq
    poly_no_roots_leq_leq poly_no_roots_less_less poly_no_roots_leq_less
    poly_no_roots_leq poly_no_roots_less poly_no_roots_geq
    poly_no_roots_greater
    poly_pos poly_pos_greater poly_pos_geq poly_pos_less poly_pos_leq
    poly_pos_between_leq_less poly_pos_between_less_leq
    poly_pos_between_leq_leq poly_pos_between_less_less

subsection {* Reification *}

text {*
  This subsection defines a number of equations to automatically convert
  statements about roots of polynomials into a canonical form so that they
  can be proven using the above substitutions.
*}

definition "PR_TAG x \<equiv> x"

lemma sturm_id_PR_prio0:
  "{x::real. P x} = {x::real. (PR_TAG P) x}"
  "(\<forall>x::real. f x < g x) = (\<forall>x::real. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. P x) = (\<forall>x::real. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma sturm_id_PR_prio1:
  "{x::real. x < a \<and> P x} = {x::real. x < a \<and> (PR_TAG P) x}"
  "{x::real. x \<le> a \<and> P x} = {x::real. x \<le> a \<and> (PR_TAG P) x}"
  "{x::real. x \<ge> b \<and> P x} = {x::real. x \<ge> b \<and> (PR_TAG P) x}"
  "{x::real. x > b \<and> P x} = {x::real. x > b \<and> (PR_TAG P) x}"
  "(\<forall>x::real < a. f x < g x) = (\<forall>x::real < a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real \<le> a. f x < g x) = (\<forall>x::real \<le> a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real > a. f x < g x) = (\<forall>x::real > a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real \<ge> a. f x < g x) = (\<forall>x::real \<ge> a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real < a. P x) = (\<forall>x::real < a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real > a. P x) = (\<forall>x::real > a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real \<le> a. P x) = (\<forall>x::real \<le> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real \<ge> a. P x) = (\<forall>x::real \<ge> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma sturm_id_PR_prio2:
  "{x::real. x > a \<and> x \<le> b \<and> P x} =
       {x::real. x > a \<and> x \<le> b \<and> PR_TAG P x}"
  "{x::real. x \<ge> a \<and> x \<le> b \<and> P x} =
       {x::real. x \<ge> a \<and> x \<le> b \<and> PR_TAG P x}"
  "{x::real. x \<ge> a \<and> x < b \<and> P x} =
       {x::real. x \<ge> a \<and> x < b \<and> PR_TAG P x}"
  "{x::real. x > a \<and> x < b \<and> P x} =
       {x::real. x > a \<and> x < b \<and> PR_TAG P x}"
  "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a < x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> P x) =
       (\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> P x) =
       (\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> P x) =
       (\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> P x) =
       (\<forall>x::real. a < x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma PR_TAG_intro_prio0:
  fixes P :: "real \<Rightarrow> bool" and f :: "real \<Rightarrow> real"
  shows
  "PR_TAG P = P' \<Longrightarrow> PR_TAG (\<lambda>x. \<not>(\<not>P x)) = P'"
  "\<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. P x \<and> Q x) = (\<lambda>x. poly (gcd p q) x = 0)" and
 " \<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. P x \<or> Q x) = (\<lambda>x. poly (p*q) x = 0)" and

  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x = g x) = (\<lambda>x. poly (p-q) x = 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> g x) = (\<lambda>x. poly (p-q) x \<noteq> 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x < g x) = (\<lambda>x. poly (q-p) x > 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> g x) = (\<lambda>x. poly (q-p) x \<ge> 0)"

  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. -f x) = (\<lambda>x. poly (-p) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x + g x) = (\<lambda>x. poly (p+q) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x - g x) = (\<lambda>x. poly (p-q) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * g x) = (\<lambda>x. poly (p*q) x)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n) = (\<lambda>x. poly (p^n) x)"
  "PR_TAG (\<lambda>x. poly p x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. x::real) = (\<lambda>x. poly [:0,1:] x)"
  "PR_TAG (\<lambda>x. a::real) = (\<lambda>x. poly [:a:] x)"
  by (simp_all add: PR_TAG_def poly_eq_0_iff_dvd field_simps)

lemma PR_TAG_intro_prio1:
  fixes f :: "real \<Rightarrow> real"
  shows
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x = 0) = (\<lambda>x. poly p x = 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> 0) = (\<lambda>x. poly p x \<noteq> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 = f x) = (\<lambda>x. poly p x = 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 \<noteq> f x) = (\<lambda>x. poly p x \<noteq> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<ge> 0) = (\<lambda>x. poly p x \<ge> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x > 0) = (\<lambda>x. poly p x > 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> 0) = (\<lambda>x. poly (-p) x \<ge> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x < 0) = (\<lambda>x. poly (-p) x > 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
       PR_TAG (\<lambda>x. 0 \<le> f x) = (\<lambda>x. poly (-p) x \<le> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
       PR_TAG (\<lambda>x. 0 < f x) = (\<lambda>x. poly (-p) x < 0)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. a * f x) = (\<lambda>x. poly (smult a p) x)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * a) = (\<lambda>x. poly (smult a p) x)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x / a) = (\<lambda>x. poly (smult (inverse a) p) x)"
  "PR_TAG (\<lambda>x. x^n :: real) = (\<lambda>x. poly (monom 1 n) x)"
using assms by (simp_all add: PR_TAG_def field_simps poly_monom)

lemma PR_TAG_intro_prio2:
  "PR_TAG (\<lambda>x. 1 / b) = (\<lambda>x. inverse b)"
  "PR_TAG (\<lambda>x. a / b) = (\<lambda>x. a / b)"
  "PR_TAG (\<lambda>x. a / b * x^n :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
  "PR_TAG (\<lambda>x. x^n * a / b :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
  "PR_TAG (\<lambda>x. a * x^n :: real) = (\<lambda>x. poly (monom a n) x)"
  "PR_TAG (\<lambda>x. x^n * a :: real) = (\<lambda>x. poly (monom a n) x)"
  "PR_TAG (\<lambda>x. x^n / a :: real) = (\<lambda>x. poly (monom (inverse a) n) x)"
(* TODO: can this be done more efficiently? I should think so. *)
  "PR_TAG (\<lambda>x. f x^(Suc (Suc 0)) :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * f x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n * f x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * (f x)^n :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^(m+n) :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^m * (f x)^n :: real) = (\<lambda>x. poly p x)"
using assms by (simp_all add: PR_TAG_def field_simps poly_monom power_add)

lemma sturm_meta_spec: "(\<And>x::real. P x) \<Longrightarrow> P x" by simp
lemma sturm_imp_conv:
  "(a < x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
  "(a \<le> x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
  "(a < x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
  "(a \<le> x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
  "(x < b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
  "(x < b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
  "(x \<le> b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
  "(x \<le> b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
  by auto

subsection {* Setup for the ``sturm'' method *}

ML_file "sturm.ML"

method_setup sturm = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Sturm.sturm_tac ctxt true))
*}

end