(*  Title:      HOL/Computational_Algebra/Polynomial_FPS.thy
    Author:     Manuel Eberl, TU München
*)

section \<open>Converting polynomials to formal power series\<close>

theory Polynomial_FPS
  imports Polynomial Formal_Power_Series
begin

context
  includes fps_notation
begin

definition fps_of_poly where
  "fps_of_poly p = Abs_fps (coeff p)"

lemma fps_of_poly_eq_iff: "fps_of_poly p = fps_of_poly q \<longleftrightarrow> p = q"
  by (simp add: fps_of_poly_def poly_eq_iff fps_eq_iff)

lemma fps_of_poly_nth [simp]: "fps_of_poly p $ n = coeff p n"
  by (simp add: fps_of_poly_def)

lemma fps_of_poly_const: "fps_of_poly [:c:] = fps_const c"
proof (subst fps_eq_iff, clarify)
  fix n :: nat show "fps_of_poly [:c:] $ n = fps_const c $ n"
    by (cases n) (auto simp: fps_of_poly_def)
qed

lemma fps_of_poly_0 [simp]: "fps_of_poly 0 = 0"
  by (subst fps_const_0_eq_0 [symmetric], subst fps_of_poly_const [symmetric]) simp

lemma fps_of_poly_1 [simp]: "fps_of_poly 1 = 1"
  by (simp add: fps_eq_iff)

lemma fps_of_poly_1' [simp]: "fps_of_poly [:1:] = 1"
  by (subst fps_const_1_eq_1 [symmetric], subst fps_of_poly_const [symmetric])
     (simp add: one_poly_def)

lemma fps_of_poly_numeral [simp]: "fps_of_poly (numeral n) = numeral n"
  by (simp add: numeral_fps_const fps_of_poly_const [symmetric] numeral_poly)

lemma fps_of_poly_numeral' [simp]: "fps_of_poly [:numeral n:] = numeral n"
  by (simp add: numeral_fps_const fps_of_poly_const [symmetric] numeral_poly)

lemma fps_of_poly_fps_X [simp]: "fps_of_poly [:0, 1:] = fps_X"
  by (auto simp add: fps_of_poly_def fps_eq_iff coeff_pCons split: nat.split)

lemma fps_of_poly_add: "fps_of_poly (p + q) = fps_of_poly p + fps_of_poly q"
  by (simp add: fps_of_poly_def plus_poly.rep_eq fps_plus_def)

lemma fps_of_poly_diff: "fps_of_poly (p - q) = fps_of_poly p - fps_of_poly q"
  by (simp add: fps_of_poly_def minus_poly.rep_eq fps_minus_def)

lemma fps_of_poly_uminus: "fps_of_poly (-p) = -fps_of_poly p"
  by (simp add: fps_of_poly_def uminus_poly.rep_eq fps_uminus_def)

lemma fps_of_poly_mult: "fps_of_poly (p * q) = fps_of_poly p * fps_of_poly q"
  by (simp add: fps_of_poly_def fps_times_def fps_eq_iff coeff_mult atLeast0AtMost)

lemma fps_of_poly_smult:
  "fps_of_poly (smult c p) = fps_const c * fps_of_poly p"
  using fps_of_poly_mult[of "[:c:]" p] by (simp add: fps_of_poly_mult fps_of_poly_const)

lemma fps_of_poly_sum: "fps_of_poly (sum f A) = sum (\<lambda>x. fps_of_poly (f x)) A"
  by (cases "finite A", induction rule: finite_induct) (simp_all add: fps_of_poly_add)

lemma fps_of_poly_sum_list: "fps_of_poly (sum_list xs) = sum_list (map fps_of_poly xs)"
  by (induction xs) (simp_all add: fps_of_poly_add)

lemma fps_of_poly_prod: "fps_of_poly (prod f A) = prod (\<lambda>x. fps_of_poly (f x)) A"
  by (cases "finite A", induction rule: finite_induct) (simp_all add: fps_of_poly_mult)

lemma fps_of_poly_prod_list: "fps_of_poly (prod_list xs) = prod_list (map fps_of_poly xs)"
  by (induction xs) (simp_all add: fps_of_poly_mult)

lemma fps_of_poly_pCons:
  "fps_of_poly (pCons (c :: 'a :: semiring_1) p) = fps_const c + fps_of_poly p * fps_X"
  by (subst fps_mult_fps_X_commute [symmetric], intro fps_ext)
     (auto simp: fps_of_poly_def coeff_pCons split: nat.split)

lemma fps_of_poly_pderiv: "fps_of_poly (pderiv p) = fps_deriv (fps_of_poly p)"
  by (intro fps_ext) (simp add: fps_of_poly_nth coeff_pderiv)

lemma fps_of_poly_power: "fps_of_poly (p ^ n) = fps_of_poly p ^ n"
  by (induction n) (simp_all add: fps_of_poly_mult)

lemma fps_of_poly_monom: "fps_of_poly (monom (c :: 'a :: comm_ring_1) n) = fps_const c * fps_X ^ n"
  by (intro fps_ext) simp_all

lemma fps_of_poly_monom': "fps_of_poly (monom (1 :: 'a :: comm_ring_1) n) = fps_X ^ n"
  by (simp add: fps_of_poly_monom)

lemma fps_of_poly_div:
  assumes "(q :: 'a :: field poly) dvd p"
  shows   "fps_of_poly (p div q) = fps_of_poly p / fps_of_poly q"
proof (cases "q = 0")
  case False
  from False fps_of_poly_eq_iff[of q 0] have nz: "fps_of_poly q \<noteq> 0" by simp
  from assms have "p = (p div q) * q" by simp
  also have "fps_of_poly \<dots> = fps_of_poly (p div q) * fps_of_poly q"
    by (simp add: fps_of_poly_mult)
  also from nz have "\<dots> / fps_of_poly q = fps_of_poly (p div q)"
    by (intro nonzero_mult_div_cancel_right) (auto simp: fps_of_poly_0)
  finally show ?thesis ..
qed simp

lemma fps_of_poly_divide_numeral:
  "fps_of_poly (smult (inverse (numeral c :: 'a :: field)) p) = fps_of_poly p / numeral c"
proof -
  have "smult (inverse (numeral c)) p = [:inverse (numeral c):] * p" by simp
  also have "fps_of_poly \<dots> = fps_of_poly p / numeral c"
    by (subst fps_of_poly_mult) (simp add: numeral_fps_const fps_of_poly_pCons)
  finally show ?thesis by simp
qed

lemma subdegree_fps_of_poly:
  assumes "p \<noteq> 0"
  defines "n \<equiv> Polynomial.order 0 p"
  shows   "subdegree (fps_of_poly p) = n"
proof (rule subdegreeI)
  from assms have "monom 1 n dvd p" by (simp add: monom_1_dvd_iff)
  thus zero: "fps_of_poly p $ i = 0" if "i < n" for i
    using that by (simp add: monom_1_dvd_iff')

  from assms have "\<not>monom 1 (Suc n) dvd p"
    by (auto simp: monom_1_dvd_iff simp del: power_Suc)
  then obtain k where k: "k \<le> n" "fps_of_poly p $ k \<noteq> 0"
    by (auto simp: monom_1_dvd_iff' less_Suc_eq_le)
  with zero[of k] have "k = n" by linarith
  with k show "fps_of_poly p $ n \<noteq> 0" by simp
qed

lemma fps_of_poly_dvd:
  assumes "p dvd q"
  shows   "fps_of_poly (p :: 'a :: field poly) dvd fps_of_poly q"
proof (cases "p = 0 \<or> q = 0")
  case False
  with assms fps_of_poly_eq_iff[of p 0] fps_of_poly_eq_iff[of q 0] show ?thesis
    by (auto simp: fps_dvd_iff subdegree_fps_of_poly dvd_imp_order_le)
qed (insert assms, auto)

lemmas fps_of_poly_simps =
  fps_of_poly_0 fps_of_poly_1 fps_of_poly_numeral fps_of_poly_const fps_of_poly_fps_X
  fps_of_poly_add fps_of_poly_diff fps_of_poly_uminus fps_of_poly_mult fps_of_poly_smult
  fps_of_poly_sum fps_of_poly_sum_list fps_of_poly_prod fps_of_poly_prod_list
  fps_of_poly_pCons fps_of_poly_pderiv fps_of_poly_power fps_of_poly_monom
  fps_of_poly_divide_numeral

lemma fps_of_poly_pcompose:
  assumes "coeff q 0 = (0 :: 'a :: idom)"
  shows   "fps_of_poly (pcompose p q) = fps_compose (fps_of_poly p) (fps_of_poly q)"
  using assms by (induction p rule: pCons_induct)
                 (auto simp: pcompose_pCons fps_of_poly_simps fps_of_poly_pCons
                             fps_compose_add_distrib fps_compose_mult_distrib)

lemmas reify_fps_atom =
  fps_of_poly_0 fps_of_poly_1' fps_of_poly_numeral' fps_of_poly_const fps_of_poly_fps_X

text \<open>
  The following simproc can reduce the equality of two polynomial FPSs two equality of the
  respective polynomials. A polynomial FPS is one that only has finitely many non-zero
  coefficients and can therefore be written as \<^term>\<open>fps_of_poly p\<close> for some
  polynomial \<open>p\<close>.

  This may sound trivial, but it covers a number of annoying side conditions like
  \<^term>\<open>1 + fps_X \<noteq> 0\<close> that would otherwise not be solved automatically.
\<close>

ML \<open>

(* TODO: Support for division *)
signature POLY_FPS = sig

val reify_conv : conv
val eq_conv : conv
val eq_simproc : cterm -> thm option

end

structure Poly_Fps = struct

fun const_binop_conv s conv ct =
  case Thm.term_of ct of
    (Const (s', _) $ _ $ _) =>
      if s = s' then
        Conv.binop_conv conv ct
      else
        raise CTERM ("const_binop_conv", [ct])
  | _ => raise CTERM ("const_binop_conv", [ct])

fun reify_conv ct =
  let
    val rewr = Conv.rewrs_conv o map (fn thm => thm RS @{thm eq_reflection})
    val un = Conv.arg_conv reify_conv
    val bin = Conv.binop_conv reify_conv
  in
    case Thm.term_of ct of
      (Const (\<^const_name>\<open>fps_of_poly\<close>, _) $ _) => ct |> Conv.all_conv
    | (Const (\<^const_name>\<open>Groups.plus\<close>, _) $ _ $ _) => ct |> (
        bin then_conv rewr @{thms fps_of_poly_add [symmetric]})
    | (Const (\<^const_name>\<open>Groups.uminus\<close>, _) $ _) => ct |> (
        un then_conv rewr @{thms fps_of_poly_uminus [symmetric]})
    | (Const (\<^const_name>\<open>Groups.minus\<close>, _) $ _ $ _) => ct |> (
        bin then_conv rewr @{thms fps_of_poly_diff [symmetric]})
    | (Const (\<^const_name>\<open>Groups.times\<close>, _) $ _ $ _) => ct |> (
        bin then_conv rewr @{thms fps_of_poly_mult [symmetric]})
    | (Const (\<^const_name>\<open>Rings.divide\<close>, _) $ _ $ (Const (\<^const_name>\<open>Num.numeral\<close>, _) $ _))
        => ct |> (Conv.fun_conv (Conv.arg_conv reify_conv)
             then_conv rewr @{thms fps_of_poly_divide_numeral [symmetric]})
    | (Const (\<^const_name>\<open>Power.power\<close>, _) $ Const (\<^const_name>\<open>fps_X\<close>,_) $ _) => ct |> (
        rewr @{thms fps_of_poly_monom' [symmetric]})
    | (Const (\<^const_name>\<open>Power.power\<close>, _) $ _ $ _) => ct |> (
        Conv.fun_conv (Conv.arg_conv reify_conv)
        then_conv rewr @{thms fps_of_poly_power [symmetric]})
    | _ => ct |> (
        rewr @{thms reify_fps_atom [symmetric]})
  end

fun eq_conv ct =
  case Thm.term_of ct of
    (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ _ $ _) => ct |> (
      Conv.binop_conv reify_conv
      then_conv Conv.rewr_conv @{thm fps_of_poly_eq_iff[THEN eq_reflection]})
  | _ => raise CTERM ("poly_fps_eq_conv", [ct])

val eq_simproc = try eq_conv

end
\<close>

simproc_setup poly_fps_eq ("(f :: 'a fps) = g") = \<open>K (K Poly_Fps.eq_simproc)\<close>

lemma fps_of_poly_linear: "fps_of_poly [:a,1 :: 'a :: field:] = fps_X + fps_const a"
  by simp

lemma fps_of_poly_linear': "fps_of_poly [:1,a :: 'a :: field:] = 1 + fps_const a * fps_X"
  by simp

lemma fps_of_poly_cutoff [simp]:
  "fps_of_poly (poly_cutoff n p) = fps_cutoff n (fps_of_poly p)"
  by (simp add: fps_eq_iff coeff_poly_cutoff)

lemma fps_of_poly_shift [simp]: "fps_of_poly (poly_shift n p) = fps_shift n (fps_of_poly p)"
  by (simp add: fps_eq_iff coeff_poly_shift)

definition poly_subdegree :: "'a::zero poly \<Rightarrow> nat" where
  "poly_subdegree p = subdegree (fps_of_poly p)"

lemma coeff_less_poly_subdegree:
  "k < poly_subdegree p \<Longrightarrow> coeff p k = 0"
  unfolding poly_subdegree_def using nth_less_subdegree_zero[of k "fps_of_poly p"] by simp

(* TODO: Move ? *)
definition prefix_length :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
  "prefix_length P xs = length (takeWhile P xs)"

primrec prefix_length_aux :: "('a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> nat" where
  "prefix_length_aux P acc [] = acc"
| "prefix_length_aux P acc (x#xs) = (if P x then prefix_length_aux P (Suc acc) xs else acc)"

lemma prefix_length_aux_correct: "prefix_length_aux P acc xs = prefix_length P xs + acc"
  by (induction xs arbitrary: acc) (simp_all add: prefix_length_def)

lemma prefix_length_code [code]: "prefix_length P xs = prefix_length_aux P 0 xs"
  by (simp add: prefix_length_aux_correct)

lemma prefix_length_le_length: "prefix_length P xs \<le> length xs"
  by (induction xs) (simp_all add: prefix_length_def)

lemma prefix_length_less_length: "(\<exists>x\<in>set xs. \<not>P x) \<Longrightarrow> prefix_length P xs < length xs"
  by (induction xs) (simp_all add: prefix_length_def)

lemma nth_prefix_length:
  "(\<exists>x\<in>set xs. \<not>P x) \<Longrightarrow> \<not>P (xs ! prefix_length P xs)"
  by (induction xs) (simp_all add: prefix_length_def)

lemma nth_less_prefix_length:
  "n < prefix_length P xs \<Longrightarrow> P (xs ! n)"
  by (induction xs arbitrary: n)
     (auto simp: prefix_length_def nth_Cons split: if_splits nat.splits)
(* END TODO *)

lemma poly_subdegree_code [code]: "poly_subdegree p = prefix_length ((=) 0) (coeffs p)"
proof (cases "p = 0")
  case False
  note [simp] = this
  define n where "n = prefix_length ((=) 0) (coeffs p)"
  from False have "\<exists>k. coeff p k \<noteq> 0" by (auto simp: poly_eq_iff)
  hence ex: "\<exists>x\<in>set (coeffs p). x \<noteq> 0" by (auto simp: coeffs_def)
  hence n_less: "n < length (coeffs p)" and nonzero: "coeffs p ! n \<noteq> 0"
    unfolding n_def by (auto intro!: prefix_length_less_length nth_prefix_length)
  show ?thesis unfolding poly_subdegree_def
  proof (intro subdegreeI)
    from n_less have "fps_of_poly p $ n = coeffs p ! n"
      by (subst coeffs_nth) (simp_all add: degree_eq_length_coeffs)
    with nonzero show "fps_of_poly p $ prefix_length ((=) 0) (coeffs p) \<noteq> 0"
      unfolding n_def by simp
  next
    fix k assume A: "k < prefix_length ((=) 0) (coeffs p)"
    also have "\<dots> \<le> length (coeffs p)" by (rule prefix_length_le_length)
    finally show "fps_of_poly p $ k = 0"
      using nth_less_prefix_length[OF A]
      by (simp add: coeffs_nth degree_eq_length_coeffs)
  qed
qed (simp_all add: poly_subdegree_def prefix_length_def)

end

end


section\<open>Repeat finitely Until it Stabilizes\<close>
theory Repeat_Stabilize
imports Main
begin

text\<open>Repeating something a number of times\<close>

text\<open>Iterating a function at most @{term n} times (first parameter) until it stabilizes.\<close>
fun repeat_stabilize :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "repeat_stabilize 0 _ v = v" |
  "repeat_stabilize (Suc n) f v = (let v_new = f v in if v = v_new then v else repeat_stabilize n f v_new)"

lemma repeat_stabilize_funpow: "repeat_stabilize n f v = (f^^n) v"
  proof(induction n arbitrary: v)
  case (Suc n)
    have "f v = v \<Longrightarrow> (f^^n) v = v" by(induction n) simp_all
    with Suc show ?case by(simp add: Let_def funpow_swap1)
  qed(simp)

lemma repeat_stabilize_induct: "(P m) \<Longrightarrow> (\<And>m. P m \<Longrightarrow> P (f m)) \<Longrightarrow> P (repeat_stabilize n f m)"
  apply(simp add: repeat_stabilize_funpow)
  apply(induction n)
   by(simp)+

end


theory pexp imports Main
begin

datatype aop
  = Ad
  | Su
  | Mu
  | Di

datatype aexp
  = N int
  | V string
  | Op aexp aop aexp

definition Add (infixl \<open>\<^bold>+\<close> 211) where \<open>a \<^bold>+ b \<equiv> Op a Ad b\<close>
definition Sub (infixl \<open>\<^bold>-\<close> 210) where \<open>a \<^bold>- b \<equiv> Op a Su b\<close>
definition Mul (infixl \<open>\<^bold>*\<close> 216) where \<open>a \<^bold>* b \<equiv> Op a Mu b\<close>
definition Div (infixl \<open>\<^bold>:\<close> 215) where \<open>a \<^bold>: b \<equiv> Op a Di b\<close>

notation (input) insert (infixr \<open>\<^bold>\<rightarrow>\<close> 160)

primrec aopsem :: \<open>int \<Rightarrow> int \<Rightarrow> aop \<Rightarrow> int\<close> where
  \<open>aopsem x y Ad = x + y\<close> |
  \<open>aopsem x y Su = x - y\<close> |
  \<open>aopsem x y Mu = x * y\<close> |
  \<open>aopsem x y Di = x div y\<close>

primrec asem (\<open>_\<lparr> _ \<rparr>\<close> [102,102] 102) where
  \<open>asem i (N v) = v\<close> |
  \<open>asem i (V x) = i x\<close> |
  \<open>asem i (Op a p b) = aopsem (asem i a) (asem i b) p\<close>

lemma addsem[simp]: \<open>asem i (a \<^bold>+ b) = (asem i a) + (asem i b)\<close> unfolding Add_def by simp
lemma supsem[simp]: \<open>asem i (a \<^bold>- b) = (asem i a) - (asem i b)\<close> unfolding Sub_def by simp
lemma mulsem[simp]: \<open>asem i (a \<^bold>* b) = (asem i a) * (asem i b)\<close> unfolding Mul_def by simp
lemma divsem[simp]: \<open>asem i (a \<^bold>: b) = (asem i a) div (asem i b)\<close> unfolding Div_def by simp

datatype acomp
  = Eq
  | Lt

datatype pexp
  = Neg pexp (\<open>\<^bold>\<not>_\<close> [199] 200)
  | Con pexp pexp (infixl \<open>\<^bold>\<and>\<close> 150)
  | Uni string pexp (\<open>\<^bold>\<forall> _. _\<close> [102,102] 102)
  | A aexp acomp aexp

definition Eql (infix \<open>\<^bold>=\<close> 205) where \<open>a \<^bold>= b \<equiv> A a Eq b\<close>
definition Ltn (infix \<open>\<^bold><\<close> 205) where \<open>a \<^bold>< b \<equiv> A a Lt b\<close>

definition Dis (infixl \<open>\<^bold>\<or>\<close> 140) where \<open>a \<^bold>\<or> b \<equiv> \<^bold>\<not>(\<^bold>\<not>a \<^bold>\<and> \<^bold>\<not>b)\<close>
definition Imp (infixr \<open>\<^bold>\<longrightarrow>\<close> 120) where \<open>a \<^bold>\<longrightarrow> b \<equiv> \<^bold>\<not>(a \<^bold>\<and> \<^bold>\<not>b)\<close>
definition Tru (\<open>\<^bold>\<top>\<close>) where \<open>\<^bold>\<top> \<equiv> (N 0) \<^bold>= (N 0)\<close>
definition Fls (\<open>\<^bold>\<bottom>\<close>) where \<open>\<^bold>\<bottom> \<equiv> \<^bold>\<not>\<^bold>\<top>\<close>
definition Exi (\<open>\<^bold>\<exists> _. _\<close> [101,101] 100) where \<open>\<^bold>\<exists> x. p \<equiv> \<^bold>\<not>(\<^bold>\<forall> x. \<^bold>\<not>p)\<close>

definition Leq (infix \<open>\<^bold>\<le>\<close> 205) where \<open>a \<^bold>\<le> b \<equiv> a \<^bold>< b \<^bold>\<or> a \<^bold>= b\<close>
definition Gtn (infix \<open>\<^bold>>\<close> 205) where \<open>a \<^bold>> b \<equiv> \<^bold>\<not>a \<^bold>< b \<^bold>\<and> \<^bold>\<not>a \<^bold>= b\<close>
definition Geq (infix \<open>\<^bold>\<ge>\<close> 205) where \<open>a \<^bold>\<ge> b \<equiv> \<^bold>\<not>a \<^bold>< b\<close>

primrec acompsem :: \<open>int \<Rightarrow> int \<Rightarrow> acomp \<Rightarrow> bool\<close> where
  \<open>acompsem x y Eq = (x = y)\<close> |
  \<open>acompsem x y Lt = (x < y)\<close>

primrec psem (infix \<open>\<^bold>\<Turnstile>\<close> 101) where
  \<open>psem i (Neg p) = (\<not>psem i p)\<close> |
  \<open>psem i (Con p q) = (psem i p \<and> psem i q)\<close> |
  \<open>psem i (Uni x p) = (\<forall> v. psem (i(x := v)) p)\<close> |
  \<open>psem i (A a c b) = acompsem (asem i a) (asem i b) c\<close>

term \<open>i \<^bold>\<Turnstile> N 3 \<^bold>> V x\<close>

lemma eqlsem[simp]: \<open>psem i (a \<^bold>= b) = (asem i a = asem i b)\<close> unfolding Eql_def by simp
lemma ltnsem[simp]: \<open>psem i (a \<^bold>< b) = (asem i a < asem i b)\<close> unfolding Ltn_def by simp
lemma dissem[simp]: \<open>psem i (a \<^bold>\<or> b) = (psem i a \<or> psem i b)\<close> unfolding Dis_def by simp
lemma impsem[simp]: \<open>psem i (a \<^bold>\<longrightarrow> b) = (psem i a \<longrightarrow> psem i b)\<close> unfolding Imp_def by simp
lemma trusem[simp]: \<open>psem i \<^bold>\<top>\<close> unfolding Tru_def Eql_def by simp
lemma flssem[simp]: \<open>\<not>psem i \<^bold>\<bottom>\<close> unfolding Fls_def by simp
lemma leqsem[simp]: \<open>psem i (a \<^bold>\<le> b) = (asem i a \<le> asem i b)\<close> unfolding Leq_def by force
lemma gtnsem[simp]: \<open>psem i (a \<^bold>> b) = (asem i a > asem i b)\<close> unfolding Gtn_def by force
lemma geqsem[simp]: \<open>psem i (a \<^bold>\<ge> b) = (asem i a \<ge> asem i b)\<close> unfolding Geq_def by force
lemma exisem[simp]: \<open>psem i (\<^bold>\<exists> x. p) = (\<exists> v. psem (i(x := v)) p)\<close> unfolding Exi_def by force

section \<open>free variables and substitution\<close>

primrec aexp_fv where
  \<open>aexp_fv (N v) = {}\<close> |
  \<open>aexp_fv (V y) = {y}\<close> |
  \<open>aexp_fv (Op b p c) = aexp_fv b \<union> aexp_fv c\<close>

lemma aexp_fv_finite: \<open>finite (aexp_fv a)\<close>
  by (induct a) auto

primrec pexp_fv where
  \<open>pexp_fv (Neg p) = pexp_fv p\<close> |
  \<open>pexp_fv (Con p q) = pexp_fv p \<union> pexp_fv q\<close> |
  \<open>pexp_fv (Uni y p) = pexp_fv p - {y}\<close> |
  \<open>pexp_fv (A b p c) = aexp_fv b \<union> aexp_fv c\<close>

lemma exi_fv[simp]: \<open>pexp_fv (\<^bold>\<exists> v. p) = pexp_fv p - {v}\<close> unfolding Exi_def by auto
lemma dis_fv[simp]: \<open>pexp_fv (a \<^bold>\<or> b) = (pexp_fv a \<union> pexp_fv b)\<close> unfolding Dis_def by auto
lemma imp_fv[simp]: \<open>pexp_fv (a \<^bold>\<longrightarrow> b) = (pexp_fv a \<union> pexp_fv b)\<close> unfolding Imp_def by auto
lemma tru_fv[simp]: \<open>pexp_fv \<^bold>\<top> = {}\<close> unfolding Tru_def Eql_def by simp
lemma fls_fv[simp]: \<open>pexp_fv \<^bold>\<bottom> = {}\<close> unfolding Fls_def by simp

lemma pexp_fv_finite: \<open>finite (pexp_fv b)\<close>
  using aexp_fv_finite by (induct b) auto

definition \<open>fresh ss \<equiv> SOME s. s \<notin> ss\<close>

lemma fresh_finite: \<open>finite (s :: string set) \<Longrightarrow> fresh s \<notin> s\<close>
  unfolding fresh_def by (metis ex_new_if_finite infinite_UNIV_listI tfl_some)

lemma fresh_fv: \<open>fresh (aexp_fv a) \<notin> aexp_fv a\<close> \<open>fresh (pexp_fv b) \<notin> pexp_fv b\<close>
  using fresh_finite by (simp_all add: aexp_fv_finite pexp_fv_finite)

primrec asubst where
  \<open>asubst x a (N v) = N v\<close> |
  \<open>asubst x a (V y) = (if x = y then a else V y)\<close> |
  \<open>asubst x a (Op b p c) = Op (asubst x a b) p (asubst x a c)\<close>

lemma addsubst[simp]: \<open>asubst x a (v \<^bold>+ w) = (asubst x a v \<^bold>+ asubst x a w)\<close> unfolding Add_def by simp
lemma supsubst[simp]: \<open>asubst x a (v \<^bold>- w) = (asubst x a v \<^bold>- asubst x a w)\<close> unfolding Sub_def by simp
lemma mulsubst[simp]: \<open>asubst x a (v \<^bold>* w) = (asubst x a v \<^bold>* asubst x a w)\<close> unfolding Mul_def by simp
lemma dovsubst[simp]: \<open>asubst x a (v \<^bold>: w) = (asubst x a v \<^bold>: asubst x a w)\<close> unfolding Div_def by simp

lemma asubst_iff_asem: \<open>asem i (asubst x a b) = asem (i(x := asem i a)) b\<close>
  by (induct b) auto

primrec pexp_size where
  \<open>pexp_size (Neg p) = (1 :: nat) + pexp_size p\<close> |
  \<open>pexp_size (Con p q) = 1 + pexp_size p + pexp_size q\<close> |
  \<open>pexp_size (Uni v p) = 1 + pexp_size p\<close> |
  \<open>pexp_size (A v c w) = 1\<close>

function (domintros) psubst where
  \<open>psubst x a (Neg p) = \<^bold>\<not>psubst x a p\<close> |
  \<open>psubst x a (Con p q) = psubst x a p \<^bold>\<and> psubst x a q\<close> |
  \<open>psubst x a (Uni y p) = (
    if x = y
    then Uni y p
    else (
      if y \<in> aexp_fv a
      then (let y' = fresh (x \<^bold>\<rightarrow> aexp_fv a \<union> pexp_fv p) in Uni y' (psubst x a (psubst y (V y') p)))
      else Uni y (psubst x a p)))\<close> |
  \<open>psubst x a (A v c w) = A (asubst x a v) c (asubst x a w)\<close>
  by pat_completeness auto
termination
proof (relation \<open>measure (\<lambda> (_,_,p). pexp_size p)\<close>,clarify)
  fix x :: string
  fix a :: aexp
  fix y p xa
  assume \<open>psubst_dom (y, V xa, p)\<close>
  then have \<open>pexp_size p = pexp_size (psubst y (V xa) p)\<close>
  proof (induction p)
    case (3 x a y p)
    then show ?case
      by (metis (full_types) pexp_size.simps(3) psubst.psimps(3))
  qed (auto simp add: psubst.psimps)
  then show \<open>((x, a, psubst y (V xa) p), x, a, \<^bold>\<forall> y. p) \<in> measure (\<lambda> (_,_,p). pexp_size p)\<close>
    using in_measure by auto
qed auto

lemma psubst_preserves_pexp_size: \<open>pexp_size p = pexp_size (psubst x a p)\<close>
proof (induct p rule: psubst.induct)
  case (3 x a y p)
  then show ?case
    by (metis pexp_size.simps(3) psubst.simps(3))
qed (auto simp add: psubst.psimps)

lemma pexp_size_gt_0: \<open>pexp_size p > 0\<close>
  by (induct p) auto

lemma ltnsubst[simp]: \<open>psubst x a (v \<^bold>< w) = (asubst x a v \<^bold>< asubst x a w)\<close> unfolding Ltn_def by simp
lemma eqlsubst[simp]: \<open>psubst x a (v \<^bold>= w) = (asubst x a v \<^bold>= asubst x a w)\<close> unfolding Eql_def by simp
lemma dissubst[simp]: \<open>psubst x a (v \<^bold>\<or> w) = (psubst x a v \<^bold>\<or> psubst x a w)\<close>
  unfolding Dis_def by simp
lemma impsubst[simp]: \<open>psubst x a (v \<^bold>\<longrightarrow> w) = (psubst x a v \<^bold>\<longrightarrow> psubst x a w)\<close>
  unfolding Imp_def by simp
lemma trusubst[simp]: \<open>psubst x a \<^bold>\<top> = \<^bold>\<top>\<close> unfolding Tru_def by simp
lemma flssubst[simp]: \<open>psubst x a \<^bold>\<bottom> = \<^bold>\<bottom>\<close> unfolding Fls_def by simp
lemma exisubst[simp]: \<open>psubst x a (\<^bold>\<exists> y. p) = (
  if x = y
    then Exi y p
    else (
      if y \<in> aexp_fv a
      then (let y' = fresh (x \<^bold>\<rightarrow> aexp_fv a \<union> pexp_fv p) in Exi y' (psubst x a (psubst y (V y') p)))
      else Exi y (psubst x a p)))\<close>
  unfolding Exi_def by (metis pexp_fv.simps(1) psubst.simps(1) psubst.simps(3))
lemma leqsubst[simp]: \<open>psubst x a (v \<^bold>\<le> w) = (asubst x a v \<^bold>\<le> asubst x a w)\<close> unfolding Leq_def by simp
lemma gtnsubst[simp]: \<open>psubst x a (v \<^bold>> w) = (asubst x a v \<^bold>> asubst x a w)\<close> unfolding Gtn_def by simp
lemma geqsubst[simp]: \<open>psubst x a (v \<^bold>\<ge> w) = (asubst x a v \<^bold>\<ge> asubst x a w)\<close> unfolding Geq_def by simp

lemma agreeing_i_aexp: \<open>y \<notin> aexp_fv a \<Longrightarrow> asem i a = asem (i(y := j)) a\<close>
  by (induct a) auto

lemma agreeing_i_pexp: \<open>y \<notin> pexp_fv p \<Longrightarrow> psem i p = psem (i(y := j)) p\<close>
proof (induct p arbitrary: i)
  case (Uni x p)
  then show ?case
  proof (cases \<open>x = y\<close>)
    case True
    then show ?thesis
      by (metis psem.simps(3) fun_upd_upd)
  next
    case False
    then show ?thesis
      using Uni by (metis pexp_fv.simps(3) psem.simps(3) fun_upd_twist member_remove remove_def)
  qed
next
  case (A x1a x2 x3)
  then show ?case
    using agreeing_i_aexp by (metis UnI1 UnI2 pexp_fv.simps(4) psem.simps(4))
qed auto

lemma psubst_iff_psem: \<open>psem i (psubst x a p) = psem (i(x := asem i a)) p\<close>
proof (induct \<open>pexp_size p\<close> arbitrary: i x a p rule: less_induct)
  case less
  then show ?case
  proof (cases p)
    case (Uni y p)
    then show ?thesis
    proof (cases \<open>x = y\<close>)
      case True
      then have \<open>psem i (psubst x a (\<^bold>\<forall> x. p)) = psem (i(x := asem i a)) (\<^bold>\<forall> y. p)\<close>
        by simp
      then show ?thesis
        using True Uni by blast
    next
      case False
      then have *:\<open>x \<noteq> y\<close> .
      show ?thesis
      proof (cases \<open>y \<in> aexp_fv a\<close>)
        case True
        let ?y = \<open>fresh (x \<^bold>\<rightarrow> aexp_fv a \<union> pexp_fv p)\<close>
        have \<open>x \<noteq> ?y\<close>
          using fresh_finite
          by (metis Un_upper1 aexp_fv_finite pexp_fv_finite finite.insertI finite_UnI insertI1
              subset_iff)
        have \<open>y \<noteq> ?y\<close>
          using True fresh_finite
          by (metis UnCI aexp_fv_finite pexp_fv_finite finite.simps finite_Un insertI2)
        have \<open>?y \<notin> pexp_fv p\<close>
          using fresh_finite by (meson UnI2 aexp_fv_finite pexp_fv_finite finite.insertI finite_UnI)
        have \<open>?y \<notin> aexp_fv a\<close>
          using fresh_finite
          by (meson UnCI aexp_fv_finite pexp_fv_finite finite_UnI finite_insert insertCI)
        then have 1: \<open>\<forall> v. asem (i(?y := v)) a = asem i a\<close>
          using agreeing_i_aexp by simp
        from True * have \<open>psubst x a (\<^bold>\<forall> y. p) = \<^bold>\<forall> ?y. psubst x a (psubst y (V ?y) p)\<close>
          by (meson psubst.simps(3))
        then have \<open>psem i (psubst x a (\<^bold>\<forall> y. p)) = psem i (\<^bold>\<forall> ?y. psubst x a (psubst y (V ?y) p))\<close>
          by simp
        moreover have \<open>... = (\<forall> v. psem (i(?y := v)) (psubst x a (psubst y (V ?y) p)))\<close>
          by simp
        moreover have \<open>... = (\<forall> v. psem ((i(?y := v))(x := asem i a)) (psubst y (V ?y) p))\<close>
          using Uni less psubst_preserves_pexp_size 1 by simp
        moreover have \<open>... = (\<forall> v. psem (((i(?y := v))(x := asem i a))(y := v)) p)\<close>
          using \<open>x \<noteq> ?y\<close> Uni * less by simp
        moreover have \<open>... = (\<forall> v. psem (((i(x := asem i a))(y := v))(?y := v)) p)\<close>
          using \<open>x \<noteq> ?y\<close> \<open>y \<noteq> ?y\<close> \<open>x \<noteq> y\<close> by (simp add: fun_upd_twist)
        moreover have \<open>... = (\<forall> v. psem ((i(x := asem i a))(y := v)) p)\<close>
          using \<open>?y \<notin> pexp_fv p\<close> agreeing_i_pexp by simp
        moreover have \<open>... = psem (i(x := asem i a)) (\<^bold>\<forall> y. p)\<close>
          by simp
        ultimately show ?thesis
          using Uni by presburger
      next
        case False
        then have \<open>psem i (psubst x a (\<^bold>\<forall> y. p)) = psem i (\<^bold>\<forall> y. psubst x a p)\<close>
          using * by simp
        moreover have \<open>... = (\<forall> j. psem (i(y := j)) (psubst x a p))\<close>
          by simp
        moreover have \<open>... = (\<forall> j. psem ((i(y := j))(x := asem (i(y := j)) a)) p)\<close>
          using Uni less psubst_preserves_pexp_size by simp
        moreover have \<open>... = (\<forall> j. psem ((i(y := j))(x := asem i a)) p)\<close>
          using False agreeing_i_aexp by simp
        moreover have \<open>... = (\<forall> j. psem ((i(x := asem i a))(y := j)) p)\<close>
          using * by (simp add: fun_upd_twist)
        moreover have \<open>... = psem (i(x := asem i a)) (\<^bold>\<forall> y. p)\<close>
          by simp
        ultimately show ?thesis
          using Uni by blast
      qed
    qed
  next
    case (A x41 x42 x43)
    from asubst_iff_asem this show ?thesis
      by (metis psem.simps(4) psubst.simps(4))
  qed auto
qed

lemma no_new_fv_asubst: \<open>aexp_fv (asubst x a' a) \<subseteq> aexp_fv a' \<union> aexp_fv a\<close>
  by (induct a) auto
lemma no_new_fv_psubst: \<open>pexp_fv (psubst x a p) \<subseteq> aexp_fv a \<union> pexp_fv p\<close>
proof (induct p rule: psubst.induct)
  case (3 x a y p)
  then show ?case
  proof (cases \<open>x = y\<close>)
    case True
    then show ?thesis
      using 3 by auto
  next
    case False
    then have \<open>x \<noteq> y\<close> .
    show ?thesis
    proof (cases \<open>y \<in> aexp_fv a\<close>)
      case True
      let ?xa = \<open>fresh (x \<^bold>\<rightarrow> aexp_fv a \<union> pexp_fv p)\<close>
      from True have \<open>pexp_fv (psubst x a (psubst y (V ?xa) p)) \<subseteq> insert ?xa (aexp_fv a \<union> pexp_fv p)\<close>
        using 3 \<open>x \<noteq> y\<close> by auto
      moreover have \<open>psubst x a (\<^bold>\<forall> y. p) = \<^bold>\<forall> ?xa. psubst x a (psubst y (V ?xa) p)\<close>
        using \<open>x \<noteq> y\<close> True by (meson psubst.simps(3))
      ultimately show ?thesis
        using Diff_empty True by auto
    next
      case False
      then show ?thesis
        using 3 \<open>x \<noteq> y\<close> by auto
    qed
  qed
next
  case (4 x a v c w)
  then show ?case
    using no_new_fv_asubst by auto
qed auto

lemma pexp_size_leq_1: \<open>pexp_size b \<ge> 1\<close>
  by (induct b) auto

lemma elem_asubst_fv:
  \<open>x \<in> aexp_fv a \<Longrightarrow> aexp_fv (asubst x b a) = (aexp_fv a - {x}) \<union> aexp_fv b\<close>
  \<open>x \<notin> aexp_fv a \<Longrightarrow> aexp_fv (asubst x b a) = aexp_fv a\<close>
  by (induct a) auto

lemma elem_psubst_fv:
  \<open>x \<in> pexp_fv p \<Longrightarrow> pexp_fv (psubst x a p) = (pexp_fv p - {x}) \<union> aexp_fv a\<close>
  \<open>x \<notin> pexp_fv p \<Longrightarrow> pexp_fv (psubst x a p) = pexp_fv p\<close>
proof (induct x a p rule: psubst.induct)
  case (3 x a y p)
  let ?a1 = \<open>x \<in> pexp_fv (\<^bold>\<forall> y. p)\<close>
  let ?a2 = \<open>x \<notin> pexp_fv (\<^bold>\<forall> y. p)\<close>
  let ?g1 = \<open>pexp_fv (psubst x a (\<^bold>\<forall> y. p)) = pexp_fv (\<^bold>\<forall> y. p) - {x} \<union> aexp_fv a\<close>
  let ?g2 = \<open>pexp_fv (psubst x a (\<^bold>\<forall> y. p)) = pexp_fv (\<^bold>\<forall> y. p)\<close>
  consider
    \<open>x = y\<close> |
    \<open>x \<noteq> y \<and> y \<notin> aexp_fv a\<close> |
    \<open>x \<noteq> y \<and> y \<in> aexp_fv a \<and> y \<in> pexp_fv p\<close> |
    \<open>x \<noteq> y \<and> y \<in> aexp_fv a \<and> y \<notin> pexp_fv p\<close> by auto
  then have \<open>(?a1 \<longrightarrow> ?g1) \<and> (?a2 \<longrightarrow> ?g2)\<close>
  proof (cases; rule conjI; clarify)
    assume *: \<open>x \<noteq> y\<close> \<open>y \<in> aexp_fv a\<close>
    let ?f = \<open>fresh (x \<^bold>\<rightarrow> aexp_fv a \<union> pexp_fv p)\<close>
    have sub_p_def: \<open>psubst x a (\<^bold>\<forall> y. p) = \<^bold>\<forall> ?f. psubst x a (psubst y (V ?f) p)\<close>
      using * by (meson psubst.simps(3))
    have f1: \<open>?f \<notin> aexp_fv a\<close>
      using fresh_finite by (meson UnI1 aexp_fv_finite pexp_fv_finite finite.insertI finite_UnI insertI2)
    have f2: \<open>?f \<notin> pexp_fv p\<close>
      using fresh_finite by (metis UnCI aexp_fv_finite pexp_fv_finite finite_Un finite_insert)
    have f3: \<open>x \<noteq> ?f\<close>
      using fresh_finite by (metis UnCI aexp_fv_finite pexp_fv_finite finite_Un finite_insert insertCI)
    {
      assume \<open>y \<in> pexp_fv p\<close>
      with 3 * have **: \<open>pexp_fv (psubst y (V ?f) p) = pexp_fv p - {y} \<union> {?f}\<close> by force
      {
        assume ?a1
        with 3 * ** sub_p_def have \<open>pexp_fv (psubst x a (\<^bold>\<forall> y. p)) = ((pexp_fv p - {y} \<union> {?f}) - {x} \<union> aexp_fv a) - {?f}\<close>
          by auto
        with f1 f2 have \<open>pexp_fv (psubst x a (\<^bold>\<forall> y. p)) = (pexp_fv p - {x} \<union> aexp_fv a)\<close>
          using * by force
        then show ?g1
          by fastforce
      next
        assume a: ?a2
        with f3 have \<open>pexp_fv (psubst x a (psubst y (V ?f) p)) = pexp_fv p - {y} \<union> {?f}\<close>
          using 3(4) * ** by force
        with sub_p_def f2 fresh_finite *(2) f1 show ?g2
          by auto
      }
    next
      assume \<open>y \<notin> pexp_fv p\<close>
      with 3 * have **: \<open>pexp_fv (psubst y (V ?f) p) = pexp_fv p\<close> by metis
      {
        assume ?a1
        with 3 * sub_p_def ** f1 f2 *(2) show ?g1
          by auto
      next
        assume ?a2
        with f2 f3 3(4) * ** \<open>y \<notin> pexp_fv p\<close> sub_p_def show ?g2
          by auto
      }
    }
  qed (use 3 in auto)
  then show \<open>?a1 \<Longrightarrow> ?g1\<close> \<open>?a2 \<Longrightarrow> ?g2\<close>
    by auto
next
  case (4 x a v c w)
  {
    case 1
    then consider
      \<open>x \<in> aexp_fv v \<and> x \<in> aexp_fv w\<close> |
      \<open>x \<in> aexp_fv v \<and> x \<notin> aexp_fv w\<close> |
      \<open>x \<notin> aexp_fv v \<and> x \<in> aexp_fv w\<close> by auto
    then show ?case
      using elem_asubst_fv by cases auto
  next
    case 2
    then show ?case
      using elem_asubst_fv by simp
  }
qed auto

lemma subset_psubst_fv: \<open>pexp_fv p \<subseteq> pexp_fv q \<Longrightarrow> pexp_fv (psubst x a p) \<subseteq> pexp_fv (psubst x a q)\<close>
  using elem_psubst_fv by (metis dis_fv dissubst sup.absorb_iff1)

end


(*   Title: HOL/ex/Ballot.thy
     Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com>
     Author: Johannes Hölzl <hoelzl@in.tum.de>
*)

section \<open>Bertrand's Ballot Theorem\<close>

theory Ballot
imports
  Complex_Main
  "HOL-Library.FuncSet"
begin

subsection \<open>Preliminaries\<close>

lemma card_bij':
  assumes "f \<in> A \<rightarrow> B" "\<And>x. x \<in> A \<Longrightarrow> g (f x) = x"
    and "g \<in> B \<rightarrow> A" "\<And>x. x \<in> B \<Longrightarrow> f (g x) = x"
  shows "card A = card B"
  apply (rule bij_betw_same_card)
  apply (rule bij_betwI)
  apply fact+
  done

subsection \<open>Formalization of Problem Statement\<close>

subsubsection \<open>Basic Definitions\<close>

datatype vote = A | B

definition
  "all_countings a b = card {f \<in> {1 .. a + b} \<rightarrow>\<^sub>E {A, B}.
      card {x \<in> {1 .. a + b}. f x = A} = a \<and> card {x \<in> {1 .. a + b}. f x = B} = b}"

definition
  "valid_countings a b =
    card {f\<in>{1..a+b} \<rightarrow>\<^sub>E {A, B}.
      card {x\<in>{1..a+b}. f x = A} = a \<and> card {x\<in>{1..a+b}. f x = B} = b \<and>
      (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > card {x\<in>{1..m}. f x = B})}"

subsubsection \<open>Equivalence with Set Cardinality\<close>

lemma Collect_on_transfer:
  assumes "rel_set R X Y"
  shows "rel_fun (rel_fun R (=)) (rel_set R) (\<lambda>P. {x\<in>X. P x}) (\<lambda>P. {y\<in>Y. P y})"
  using assms unfolding rel_fun_def rel_set_def by fast

lemma rel_fun_trans:
  "rel_fun P Q g g' \<Longrightarrow> rel_fun R P f f' \<Longrightarrow> rel_fun R Q (\<lambda>x. g (f x)) (\<lambda>y. g' (f' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_trans2:
  "rel_fun P1 (rel_fun P2 Q) g g' \<Longrightarrow> rel_fun R P1 f1 f1' \<Longrightarrow> rel_fun R P2 f2 f2' \<Longrightarrow>
    rel_fun R Q (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g' (f1' y) (f2' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_trans2':
  "rel_fun R (=) f1 f1' \<Longrightarrow> rel_fun R (=) f2 f2' \<Longrightarrow>
    rel_fun R (=) (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g (f1' y) (f2' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_const: "rel_fun R (=) (\<lambda>x. a) (\<lambda>y. a)"
  by auto

lemma rel_fun_conj:
  "rel_fun R (=) f f' \<Longrightarrow> rel_fun R (=) g g' \<Longrightarrow> rel_fun R (=) (\<lambda>x. f x \<and> g x) (\<lambda>y. f' y \<and> g' y)"
  by (auto simp: rel_fun_def)

lemma rel_fun_ball:
  "(\<And>i. i \<in> I \<Longrightarrow> rel_fun R (=) (f i) (f' i)) \<Longrightarrow> rel_fun R (=) (\<lambda>x. \<forall>i\<in>I. f i x) (\<lambda>y. \<forall>i\<in>I. f' i y)"
  by (auto simp: rel_fun_def rel_set_def)

lemma
  shows all_countings_set: "all_countings a b = card {V\<in>Pow {0..<a+b}. card V = a}"
      (is "_ = card ?A")
    and valid_countings_set: "valid_countings a b =
      card {V\<in>Pow {0..<a+b}. card V = a \<and> (\<forall>m\<in>{1..a+b}. card ({0..<m} \<inter> V) > m - card ({0..<m} \<inter> V))}"
      (is "_ = card ?V")
proof -
  define P where "P j i \<longleftrightarrow> i < a + b \<and> j = Suc i" for j i
  have unique_P: "bi_unique P" and total_P: "\<And>m. m \<le> a + b \<Longrightarrow> rel_set P {1..m} {0..<m}"
    by (auto simp add: bi_unique_def rel_set_def P_def Suc_le_eq gr0_conv_Suc)
  have rel_fun_P: "\<And>R f g. (\<And>i. i < a+b \<Longrightarrow> R (f  (Suc i)) (g i)) \<Longrightarrow> rel_fun P R f g"
    by (simp add: rel_fun_def P_def)

  define R where "R f V \<longleftrightarrow>
    V \<subseteq> {0..<a+b} \<and> f \<in> extensional {1..a+b} \<and> (\<forall>i<a+b. i \<in> V \<longleftrightarrow> f (Suc i) = A)" for f V
  { fix f g :: "nat \<Rightarrow> vote" assume "f \<in> extensional {1..a + b}" "g \<in> extensional {1..a + b}"
    moreover assume "\<forall>i<a + b. (f (Suc i) = A) = (g (Suc i) = A)"
    then have "\<forall>i<a + b. f (Suc i) = g (Suc i)"
      by (metis vote.nchotomy)
    ultimately have "f i = g i" for i
      by (cases "i \<in> {1..a+b}") (auto simp: extensional_def Suc_le_eq gr0_conv_Suc) }
  then have unique_R: "bi_unique R"
    by (auto simp: bi_unique_def R_def)

  have "f \<in> extensional {1..a + b} \<Longrightarrow> \<exists>V\<in>Pow {0..<a + b}. R f V" for f
    by (intro bexI[of _ "{i. i < a+b \<and> f (Suc i) = A}"]) (auto simp add: R_def PiE_def)
  moreover have "V \<in> Pow {0..<a + b} \<Longrightarrow> \<exists>f\<in>extensional {1..a+b}. R f V" for V
    by (intro bexI[of _ "\<lambda>i\<in>{1..a+b}. if i - 1 \<in> V then A else B"]) (auto simp add: R_def PiE_def)
  ultimately have total_R: "rel_set R (extensional {1..a+b}) (Pow {0..<a+b})"
    by (auto simp: rel_set_def)

  have P: "rel_fun R (rel_fun P (=)) (\<lambda>f x. f x = A) (\<lambda>V y. y \<in> V)"
    by (auto simp: P_def R_def Suc_le_eq gr0_conv_Suc rel_fun_def)

  have eq_B: "x = B \<longleftrightarrow> x \<noteq> A" for x
    by (cases x; simp)

  { fix f and m :: nat
    have "card {x\<in>{1..m}. f x = B} = card ({1..m} - {x\<in>{1..m}. f x = A})"
      by (simp add: eq_B set_diff_eq cong: conj_cong)
    also have "\<dots> = m - card {x\<in>{1..m}. f x = A}"
      by (subst card_Diff_subset) auto
    finally have "card {x\<in>{1..m}. f x = B} = m - card {x\<in>{1..m}. f x = A}" . }
  note card_B = this

  note transfers = rel_fun_const card_transfer[THEN rel_funD, OF unique_R] rel_fun_conj rel_fun_ball
    Collect_on_transfer[THEN rel_funD, OF total_R] Collect_on_transfer[THEN rel_funD, OF total_P]
    rel_fun_trans[OF card_transfer, OF unique_P] rel_fun_trans[OF Collect_on_transfer[OF total_P]]
    rel_fun_trans2'[where g="(=)"] rel_fun_trans2'[where g="(<)"] rel_fun_trans2'[where g="(-)"]

  have "all_countings a b = card {f \<in> extensional {1..a + b}. card {x \<in> {1..a + b}. f x = A} = a}"
    using card_B by (simp add: all_countings_def PiE_iff vote.nchotomy cong: conj_cong)
  also have "\<dots> = card {V\<in>Pow {0..<a+b}. card ({x\<in>{0 ..< a + b}. x \<in> V}) = a}"
    by (intro P order_refl transfers)
  finally show "all_countings a b = card ?A"
    unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)

  have "valid_countings a b = card {f\<in>extensional {1..a+b}.
      card {x\<in>{1..a+b}. f x = A} = a \<and> (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > m - card {x\<in>{1..m}. f x = A})}"
    using card_B by (simp add: valid_countings_def PiE_iff vote.nchotomy cong: conj_cong)
  also have "\<dots> = card {V\<in>Pow {0..<a+b}. card {x\<in>{0..<a+b}. x\<in>V} = a \<and>
    (\<forall>m\<in>{1..a+b}. card {x\<in>{0..<m}. x\<in>V} > m - card {x\<in>{0..<m}. x\<in>V})}"
    by (intro P order_refl transfers) auto
  finally show "valid_countings a b = card ?V"
    unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)
qed

lemma all_countings: "all_countings a b = (a + b) choose a"
  unfolding all_countings_set by (simp add: n_subsets)

subsection \<open>Facts About \<^term>\<open>valid_countings\<close>\<close>

subsubsection \<open>Non-Recursive Cases\<close>

lemma card_V_eq_a: "V \<subseteq> {0..<a} \<Longrightarrow> card V = a \<longleftrightarrow> V = {0..<a}"
  using card_subset_eq[of "{0..<a}" V] by auto

lemma valid_countings_a_0: "valid_countings a 0 = 1"
  by (simp add: valid_countings_set card_V_eq_a cong: conj_cong)

lemma valid_countings_eq_zero:
  "a \<le> b \<Longrightarrow> 0 < b \<Longrightarrow> valid_countings a b = 0"
  by (auto simp add: valid_countings_set Int_absorb1 intro!: bexI[of _ "a + b"])

lemma Ico_subset_finite: "i \<subseteq> {a ..< b::nat} \<Longrightarrow> finite i"
  by (auto dest: finite_subset)

lemma Icc_Suc2: "a \<le> b \<Longrightarrow> {a..Suc b} = insert (Suc b) {a..b}"
  by auto

lemma Ico_Suc2: "a \<le> b \<Longrightarrow> {a..<Suc b} = insert b {a..<b}"
  by auto

lemma valid_countings_Suc_Suc:
  assumes "b < a"
  shows "valid_countings (Suc a) (Suc b) = valid_countings a (Suc b) + valid_countings (Suc a) b"
proof -
  let ?l = "Suc (a + b)"
  let ?Q = "\<lambda>V c. \<forall>m\<in>{1..c}. m - card ({0..<m} \<inter> V) < card ({0..<m} \<inter> V)"
  let ?V = "\<lambda>P. {V. (V \<in> Pow {0..<Suc ?l} \<and> P V) \<and> card V = Suc a \<and> ?Q V (Suc ?l)}"
  have "valid_countings (Suc a) (Suc b) = card (?V (\<lambda>V. ?l \<notin> V)) + card (?V (\<lambda>V. ?l \<in> V))"
    unfolding valid_countings_set
    by (subst card_Un_disjoint[symmetric]) (auto simp add: set_eq_iff intro!: arg_cong[where f=card])
  also have "card (?V (\<lambda>V. ?l \<in> V)) = valid_countings a (Suc b)"
    unfolding valid_countings_set
  proof (rule card_bij'[where f="\<lambda>V. V - {?l}" and g="insert ?l"])
    have *: "\<And>m V. m \<in> {1..a + Suc b} \<Longrightarrow> {0..<m} \<inter> (V - {?l}) = {0..<m} \<inter> V"
      by auto
    show "(\<lambda>V. V - {?l}) \<in> ?V (\<lambda>V. ?l \<in> V) \<rightarrow> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)}"
      by (auto simp: Ico_subset_finite *)
    { fix V assume V: "V \<subseteq> {0..<?l}"
      then have "finite V" "?l \<notin> V" "{0..<Suc ?l} \<inter> V = V"
        by (auto dest: finite_subset)
      with V have "card (insert ?l V) = Suc (card V)"
        "card ({0..<m} \<inter> insert ?l V) = (if m = Suc ?l then Suc (card V) else card ({0..<m} \<inter> V))"
        if "m \<le> Suc ?l" for m
        using that by auto }
    then show "insert ?l \<in> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)} \<rightarrow> ?V (\<lambda>V. ?l \<in> V)"
      using \<open>b < a\<close> by auto
  qed auto
  also have "card (?V (\<lambda>V. ?l \<notin> V)) = valid_countings (Suc a) b"
    unfolding valid_countings_set
  proof (intro arg_cong[where f="\<lambda>P. card {x. P x}"] ext conj_cong)
    fix V assume "V \<in> Pow {0..<Suc a + b}" and [simp]: "card V = Suc a"
    then have [simp]: "V \<subseteq> {0..<Suc ?l}"
      by auto
    show "?Q V (Suc ?l) = ?Q V (Suc a + b)"
      using \<open>b<a\<close> by (simp add: Int_absorb1 Icc_Suc2)
  qed (auto simp: subset_eq less_Suc_eq)
  finally show ?thesis
    by simp
qed

lemma valid_countings:
  "(a + b) * valid_countings a b = (a - b) * ((a + b) choose a)"
proof (induct a arbitrary: b)
  case 0 show ?case
    by (cases b) (simp_all add: valid_countings_eq_zero)
next
  case (Suc a) note Suc_a = this
  show ?case
  proof (induct b)
    case (Suc b) note Suc_b = this
    show ?case
    proof cases
      assume "a \<le> b" then show ?thesis
        by (simp add: valid_countings_eq_zero)
    next
      assume "\<not> a \<le> b"
      then have "b < a" by simp

      have "Suc a * (a - Suc b) + (Suc a - b) * Suc b =
        (Suc a * a - Suc a * Suc b) + (Suc a * Suc b - Suc b * b)"
        by (simp add: algebra_simps)
      also have "\<dots> = (Suc a * a + (Suc a * Suc b - Suc b * b)) - Suc a * Suc b"
        using \<open>b<a\<close> by (intro add_diff_assoc2 mult_mono) auto
      also have "\<dots> = (Suc a * a + Suc a * Suc b) - Suc b * b - Suc a * Suc b"
        using \<open>b<a\<close> by (intro arg_cong2[where f="(-)"] add_diff_assoc mult_mono) auto
      also have "\<dots> = (Suc a * Suc (a + b)) - (Suc b * Suc (a + b))"
        by (simp add: algebra_simps)
      finally have rearrange: "Suc a * (a - Suc b) + (Suc a - b) * Suc b = (Suc a - Suc b) * Suc (a + b)"
        unfolding diff_mult_distrib by simp

      have "(Suc a * Suc (a + b)) * ((Suc a + Suc b) * valid_countings (Suc a) (Suc b)) =
        (Suc a + Suc b) * Suc a * ((a + Suc b) * valid_countings a (Suc b) + (Suc a + b) * valid_countings (Suc a) b)"
        unfolding valid_countings_Suc_Suc[OF \<open>b < a\<close>] by (simp add: field_simps)
      also have "... = (Suc a + Suc b) * ((a - Suc b) * (Suc a * (Suc (a + b) choose a)) +
        (Suc a - b) * (Suc a * (Suc (a + b) choose Suc a)))"
        unfolding Suc_a Suc_b by (simp add: field_simps)
      also have "... = (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc (Suc a + b) * (Suc a + b choose a))"
        unfolding Suc_times_binomial_add by (simp add: field_simps)
      also have "... = Suc a * (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc a + Suc b choose Suc a)"
        unfolding Suc_times_binomial_eq by (simp add: field_simps)
      also have "... = (Suc a * Suc (a + b)) * ((Suc a - Suc b) * (Suc a + Suc b choose Suc a))"
        unfolding rearrange by (simp only: mult_ac)
      finally show ?thesis
        unfolding mult_cancel1 by simp
    qed
  qed (simp add: valid_countings_a_0)
qed

lemma valid_countings_eq[code]:
  "valid_countings a b = (if a + b = 0 then 1 else ((a - b) * ((a + b) choose a)) div (a + b))"
  by (simp add: valid_countings[symmetric] valid_countings_a_0)

subsection \<open>Relation Between \<^term>\<open>valid_countings\<close> and \<^term>\<open>all_countings\<close>\<close>

lemma main_nat: "(a + b) * valid_countings a b = (a - b) * all_countings a b"
  unfolding valid_countings all_countings ..

lemma main_real:
  assumes "b < a"
  shows "valid_countings a b = (a - b) / (a + b) * all_countings a b"
using assms
proof -
  from main_nat[of a b] \<open>b < a\<close> have
    "(real a + real b) * real (valid_countings a b) = (real a - real b) * real (all_countings a b)"
    by (simp only: of_nat_add[symmetric] of_nat_mult[symmetric]) auto
  from this \<open>b < a\<close> show ?thesis
    by (subst mult_left_cancel[of "real a + real b", symmetric]) auto
qed

lemma
  "valid_countings a b = (if a \<le> b then (if b = 0 then 1 else 0) else (a - b) / (a + b) * all_countings a b)"
proof (cases "a \<le> b")
  case False
    from this show ?thesis by (simp add: main_real)
next
  case True
    from this show ?thesis
      by (auto simp add: valid_countings_a_0 all_countings valid_countings_eq_zero)
qed

subsubsection \<open>Executable Definition\<close>

declare all_countings_def [code del]
declare all_countings[code]

value "all_countings 1 0"
value "all_countings 0 1"
value "all_countings 1 1"
value "all_countings 2 1"
value "all_countings 1 2"
value "all_countings 2 4"
value "all_countings 4 2"

subsubsection \<open>Executable Definition\<close>

declare valid_countings_def [code del]

value "valid_countings 1 0"
value "valid_countings 0 1"
value "valid_countings 1 1"
value "valid_countings 2 1"
value "valid_countings 1 2"
value "valid_countings 2 4"
value "valid_countings 4 2"

end


(*  Title:      HOL/Proofs/Extraction/Util.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Auxiliary lemmas used in program extraction examples\<close>

theory Util
imports MainRLT
begin

text \<open>Decidability of equality on natural numbers.\<close>

lemma nat_eq_dec: "\<And>n::nat. m = n \<or> m \<noteq> n"
  apply (induct m)
  apply (case_tac n)
  apply (case_tac [3] n)
  apply (simp only: nat.simps, iprover?)+
  done

text \<open>
  Well-founded induction on natural numbers, derived using the standard
  structural induction rule.
\<close>

lemma nat_wf_ind:
  assumes R: "\<And>x::nat. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x"
  shows "P z"
proof (rule R)
  show "\<And>y. y < z \<Longrightarrow> P y"
  proof (induct z)
    case 0
    then show ?case by simp
  next
    case (Suc n y)
    from nat_eq_dec show ?case
    proof
      assume ny: "n = y"
      have "P n"
        by (rule R) (rule Suc)
      with ny show ?case by simp
    next
      assume "n \<noteq> y"
      with Suc have "y < n" by simp
      then show ?case by (rule Suc)
    qed
  qed
qed

text \<open>Bounded search for a natural number satisfying a decidable predicate.\<close>

lemma search:
  assumes dec: "\<And>x::nat. P x \<or> \<not> P x"
  shows "(\<exists>x<y. P x) \<or> \<not> (\<exists>x<y. P x)"
proof (induct y)
  case 0
  show ?case by simp
next
  case (Suc z)
  then show ?case
  proof
    assume "\<exists>x<z. P x"
    then obtain x where le: "x < z" and P: "P x" by iprover
    from le have "x < Suc z" by simp
    with P show ?case by iprover
  next
    assume nex: "\<not> (\<exists>x<z. P x)"
    from dec show ?case
    proof
      assume P: "P z"
      have "z < Suc z" by simp
      with P show ?thesis by iprover
    next
      assume nP: "\<not> P z"
      have "\<not> (\<exists>x<Suc z. P x)"
      proof
        assume "\<exists>x<Suc z. P x"
        then obtain x where le: "x < Suc z" and P: "P x" by iprover
        have "x < z"
        proof (cases "x = z")
          case True
          with nP and P show ?thesis by simp
        next
          case False
          with le show ?thesis by simp
        qed
        with P have "\<exists>x<z. P x" by iprover
        with nex show False ..
      qed
      then show ?case by iprover
    qed
  qed
qed

end


section {* Predicate Calculus Laws *}

theory utp_pred_laws
  imports utp_pred
begin

subsection {* Propositional Logic *}

text {* Showing that predicates form a Boolean Algebra (under the predicate operators as opposed to
  the lattice operators) gives us many useful laws. *}

interpretation boolean_algebra diff_upred not_upred conj_upred "op \<le>" "op <"
  disj_upred false_upred true_upred
  by (unfold_locales; pred_auto)

lemma taut_true [simp]: "`true`"
  by (pred_auto)

lemma taut_false [simp]: "`false` = False"
  by (pred_auto)

lemma upred_eval_taut:
  "`P\<lbrakk>\<guillemotleft>b\<guillemotright>/&\<Sigma>\<rbrakk>` = \<lbrakk>P\<rbrakk>\<^sub>eb"
  by (pred_auto)

lemma refBy_order: "P \<sqsubseteq> Q = `Q \<Rightarrow> P`"
  by (pred_auto)

lemma conj_idem [simp]: "((P::'\<alpha> upred) \<and> P) = P"
  by (pred_auto)

lemma disj_idem [simp]: "((P::'\<alpha> upred) \<or> P) = P"
  by (pred_auto)

lemma conj_comm: "((P::'\<alpha> upred) \<and> Q) = (Q \<and> P)"
  by (pred_auto)

lemma disj_comm: "((P::'\<alpha> upred) \<or> Q) = (Q \<or> P)"
  by (pred_auto)

lemma conj_subst: "P = R \<Longrightarrow> ((P::'\<alpha> upred) \<and> Q) = (R \<and> Q)"
  by (pred_auto)

lemma conj_assoc:"(((P::'\<alpha> upred) \<and> Q) \<and> S) = (P \<and> (Q \<and> S))"
  by (pred_auto)

lemma disj_assoc:"(((P::'\<alpha> upred) \<or> Q) \<or> S) = (P \<or> (Q \<or> S))"
  by (pred_auto)

lemma conj_disj_abs:"((P::'\<alpha> upred) \<and> (P \<or> Q)) = P"
  by (pred_auto)

lemma disj_conj_abs:"((P::'\<alpha> upred) \<or> (P \<and> Q)) = P"
  by (pred_auto)

lemma conj_disj_distr:"((P::'\<alpha> upred) \<and> (Q \<or> R)) = ((P \<and> Q) \<or> (P \<and> R))"
  by (pred_auto)

lemma disj_conj_distr:"((P::'\<alpha> upred) \<or> (Q \<and> R)) = ((P \<or> Q) \<and> (P \<or> R))"
  by (pred_auto)

lemma true_disj_zero [simp]:
  "(P \<or> true) = true" "(true \<or> P) = true"
  by (pred_auto)+

lemma true_conj_zero [simp]:
  "(P \<and> false) = false" "(false \<and> P) = false"
  by (pred_auto)+

lemma imp_vacuous [simp]: "(false \<Rightarrow> u) = true"
  by (pred_auto)

lemma imp_true [simp]: "(p \<Rightarrow> true) = true"
  by (pred_auto)

lemma true_imp [simp]: "(true \<Rightarrow> p) = p"
  by (pred_auto)

lemma impl_mp1 [simp]: "(P \<and> (P \<Rightarrow> Q)) = (P \<and> Q)"
  by (pred_auto)

lemma impl_mp2 [simp]: "((P \<Rightarrow> Q) \<and> P) = (Q \<and> P)"
  by (pred_auto)

lemma impl_adjoin: "((P \<Rightarrow> Q) \<and> R) = ((P \<and> R \<Rightarrow> Q \<and> R) \<and> R)"
  by (pred_auto)

lemma impl_refine_intro:
  "\<lbrakk> Q\<^sub>1 \<sqsubseteq> P\<^sub>1; P\<^sub>2 \<sqsubseteq> (P\<^sub>1 \<and> Q\<^sub>2) \<rbrakk> \<Longrightarrow> (P\<^sub>1 \<Rightarrow> P\<^sub>2) \<sqsubseteq> (Q\<^sub>1 \<Rightarrow> Q\<^sub>2)"
  by (pred_auto)

lemma spec_refine:
  "Q \<sqsubseteq> (P \<and> R) \<Longrightarrow> (P \<Rightarrow> Q) \<sqsubseteq> R"
  by (rel_auto)

lemma impl_disjI: "\<lbrakk> `P \<Rightarrow> R`; `Q \<Rightarrow> R` \<rbrakk> \<Longrightarrow> `(P \<or> Q) \<Rightarrow> R`"
  by (rel_auto)

lemma conditional_iff:
  "(P \<Rightarrow> Q) = (P \<Rightarrow> R) \<longleftrightarrow> `P \<Rightarrow> (Q \<Leftrightarrow> R)`"
  by (pred_auto)

lemma p_and_not_p [simp]: "(P \<and> \<not> P) = false"
  by (pred_auto)

lemma p_or_not_p [simp]: "(P \<or> \<not> P) = true"
  by (pred_auto)

lemma p_imp_p [simp]: "(P \<Rightarrow> P) = true"
  by (pred_auto)

lemma p_iff_p [simp]: "(P \<Leftrightarrow> P) = true"
  by (pred_auto)

lemma p_imp_false [simp]: "(P \<Rightarrow> false) = (\<not> P)"
  by (pred_auto)

lemma not_conj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<and> Q)) = ((\<not> P) \<or> (\<not> Q))"
  by (pred_auto)

lemma not_disj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<or> Q)) = ((\<not> P) \<and> (\<not> Q))"
  by (pred_auto)

lemma conj_disj_not_abs [simp]: "((P::'\<alpha> upred) \<and> ((\<not>P) \<or> Q)) = (P \<and> Q)"
  by (pred_auto)

lemma subsumption1:
  "`P \<Rightarrow> Q` \<Longrightarrow> (P \<or> Q) = Q"
  by (pred_auto)

lemma subsumption2:
  "`Q \<Rightarrow> P` \<Longrightarrow> (P \<or> Q) = P"
  by (pred_auto)

lemma neg_conj_cancel1: "(\<not> P \<and> (P \<or> Q)) = (\<not> P \<and> Q :: '\<alpha> upred)"
  by (pred_auto)

lemma neg_conj_cancel2: "(\<not> Q \<and> (P \<or> Q)) = (\<not> Q \<and> P :: '\<alpha> upred)"
  by (pred_auto)

lemma double_negation [simp]: "(\<not> \<not> (P::'\<alpha> upred)) = P"
  by (pred_auto)

lemma true_not_false [simp]: "true \<noteq> false" "false \<noteq> true"
  by (pred_auto)+

lemma closure_conj_distr: "([P]\<^sub>u \<and> [Q]\<^sub>u) = [P \<and> Q]\<^sub>u"
  by (pred_auto)

lemma closure_imp_distr: "`[P \<Rightarrow> Q]\<^sub>u \<Rightarrow> [P]\<^sub>u \<Rightarrow> [Q]\<^sub>u`"
  by (pred_auto)

lemma true_iff [simp]: "(P \<Leftrightarrow> true) = P"
  by (pred_auto)

lemma taut_iff_eq:
  "`P \<Leftrightarrow> Q` \<longleftrightarrow> (P = Q)"
  by (pred_auto)

lemma impl_alt_def: "(P \<Rightarrow> Q) = (\<not> P \<or> Q)"
  by (pred_auto)

subsection {* Lattice laws *}

lemma uinf_or:
  fixes P Q :: "'\<alpha> upred"
  shows "(P \<sqinter> Q) = (P \<or> Q)"
  by (pred_auto)

lemma usup_and:
  fixes P Q :: "'\<alpha> upred"
  shows "(P \<squnion> Q) = (P \<and> Q)"
  by (pred_auto)

lemma UINF_alt_def:
  "(\<Sqinter> i | A(i) \<bullet> P(i)) = (\<Sqinter> i \<bullet> A(i) \<and> P(i))"
  by (rel_auto)

lemma USUP_true [simp]: "(\<Squnion> P | F(P) \<bullet> true) = true"
  by (pred_auto)

lemma UINF_mem_UNIV [simp]: "(\<Sqinter> x\<in>UNIV \<bullet> P(x)) = (\<Sqinter> x \<bullet> P(x))"
  by (pred_auto)

lemma USUP_mem_UNIV [simp]: "(\<Squnion> x\<in>UNIV \<bullet> P(x)) = (\<Squnion> x \<bullet> P(x))"
  by (pred_auto)

lemma USUP_false [simp]: "(\<Squnion> i \<bullet> false) = false"
  by (pred_simp)

lemma UINF_true [simp]: "(\<Sqinter> i \<bullet> true) = true"
  by (pred_simp)

lemma UINF_mem_true [simp]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter> i\<in>A \<bullet> true) = true"
  by (pred_auto)

lemma UINF_false [simp]: "(\<Sqinter> i | P(i) \<bullet> false) = false"
  by (pred_auto)

lemma UINF_cong_eq:
  "\<lbrakk> \<And> x. P\<^sub>1(x) = P\<^sub>2(x); \<And> x. `P\<^sub>1(x) \<Rightarrow> Q\<^sub>1(x) =\<^sub>u Q\<^sub>2(x)` \<rbrakk> \<Longrightarrow>
        (\<Sqinter> x | P\<^sub>1(x) \<bullet> Q\<^sub>1(x)) = (\<Sqinter> x | P\<^sub>2(x) \<bullet> Q\<^sub>2(x))"
 by (unfold UINF_def, pred_simp, metis)

lemma UINF_as_Sup: "(\<Sqinter> P \<in> \<P> \<bullet> P) = \<Sqinter> \<P>"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Sup"])
  apply (auto)
done

lemma UINF_as_Sup_collect: "(\<Sqinter>P\<in>A \<bullet> f(P)) = (\<Sqinter>P\<in>A. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image)
done

lemma UINF_as_Sup_collect': "(\<Sqinter>P \<bullet> f(P)) = (\<Sqinter>P. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: full_SetCompr_eq)
done

lemma UINF_as_Sup_image: "(\<Sqinter> P | \<guillemotleft>P\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> f(P)) = \<Sqinter> (f ` A)"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Sup"])
  apply (auto)
done

lemma USUP_as_Inf: "(\<Squnion> P \<in> \<P> \<bullet> P) = \<Squnion> \<P>"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Inf"])
  apply (auto)
done

lemma USUP_as_Inf_collect: "(\<Squnion>P\<in>A \<bullet> f(P)) = (\<Squnion>P\<in>A. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image)
done

lemma USUP_as_Inf_collect': "(\<Squnion>P \<bullet> f(P)) = (\<Squnion>P. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: full_SetCompr_eq)
done

lemma USUP_as_Inf_image: "(\<Squnion> P \<in> \<P> \<bullet> f(P)) = \<Squnion> (f ` \<P>)"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Inf"])
  apply (auto)
done

lemma USUP_image_eq [simp]: "USUP (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Squnion> i\<in>A \<bullet> g(f(i)))"
  by (pred_simp, rule_tac cong[of Inf Inf], auto)

lemma UINF_image_eq [simp]: "UINF (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Sqinter> i\<in>A \<bullet> g(f(i)))"
  by (pred_simp, rule_tac cong[of Sup Sup], auto)

lemma subst_continuous [usubst]: "\<sigma> \<dagger> (\<Sqinter> A) = (\<Sqinter> {\<sigma> \<dagger> P | P. P \<in> A})"
  by (simp add: UINF_as_Sup[THEN sym] usubst setcompr_eq_image)

lemma not_UINF: "(\<not> (\<Sqinter> i\<in>A\<bullet> P(i))) = (\<Squnion> i\<in>A\<bullet> \<not> P(i))"
  by (pred_auto)

lemma not_USUP: "(\<not> (\<Squnion> i\<in>A\<bullet> P(i))) = (\<Sqinter> i\<in>A\<bullet> \<not> P(i))"
  by (pred_auto)

lemma UINF_empty [simp]: "(\<Sqinter> i \<in> {} \<bullet> P(i)) = false"
  by (pred_auto)

lemma UINF_insert [simp]: "(\<Sqinter> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<sqinter> (\<Sqinter> i\<in>xs \<bullet> P(i)))"
  apply (pred_simp)
  apply (subst Sup_insert[THEN sym])
  apply (rule_tac cong[of Sup Sup])
  apply (auto)
done

lemma USUP_empty [simp]: "(\<Squnion> i \<in> {} \<bullet> P(i)) = true"
  by (pred_auto)

lemma USUP_insert [simp]: "(\<Squnion> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<squnion> (\<Squnion> i\<in>xs \<bullet> P(i)))"
  apply (pred_simp)
  apply (subst Inf_insert[THEN sym])
  apply (rule_tac cong[of Inf Inf])
  apply (auto)
done

lemma conj_UINF_dist:
  "(P \<and> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<and> F(Q))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma disj_UINF_dist:
  "S \<noteq> {} \<Longrightarrow> (P \<or> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<or> F(Q))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma conj_USUP_dist:
  "S \<noteq> {} \<Longrightarrow> (P \<and> (\<Squnion> Q\<in>S \<bullet> F(Q))) = (\<Squnion> Q\<in>S \<bullet> P \<and> F(Q))"
  by (subst uexpr_eq_iff, auto simp add: conj_upred_def USUP.rep_eq inf_uexpr.rep_eq bop.rep_eq lit.rep_eq)

lemma USUP_conj_USUP: "((\<Squnion> P \<in> A \<bullet> F(P)) \<and> (\<Squnion> P \<in> A \<bullet> G(P))) = (\<Squnion> P \<in> A \<bullet> F(P) \<and> G(P))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma UINF_all_cong:
  assumes "\<And> P. F(P) = G(P)"
  shows "(\<Sqinter> P \<bullet> F(P)) = (\<Sqinter> P \<bullet> G(P))"
  by (simp add: UINF_as_Sup_collect assms)

lemma UINF_cong:
  assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
  shows "(\<Sqinter> P\<in>A \<bullet> F(P)) = (\<Sqinter> P\<in>A \<bullet> G(P))"
  by (simp add: UINF_as_Sup_collect assms)

lemma USUP_all_cong:
  assumes "\<And> P. F(P) = G(P)"
  shows "(\<Squnion> P \<bullet> F(P)) = (\<Squnion> P \<bullet> G(P))"
  by (simp add: assms)

lemma USUP_cong:
  assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
  shows "(\<Squnion> P\<in>A \<bullet> F(P)) = (\<Squnion> P\<in>A \<bullet> G(P))"
  by (simp add: USUP_as_Inf_collect assms)

lemma UINF_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Sqinter> P\<in>B \<bullet> F(P)) \<sqsubseteq> (\<Sqinter> P\<in>A \<bullet> F(P))"
  by (simp add: SUP_subset_mono UINF_as_Sup_collect)

lemma USUP_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Squnion> P\<in>A \<bullet> F(P)) \<sqsubseteq> (\<Squnion> P\<in>B \<bullet> F(P))"
  by (simp add: INF_superset_mono USUP_as_Inf_collect)

lemma UINF_impl: "(\<Sqinter> P\<in>A \<bullet> F(P) \<Rightarrow> G(P)) = ((\<Squnion> P\<in>A \<bullet> F(P)) \<Rightarrow> (\<Sqinter> P\<in>A \<bullet> G(P)))"
  by (pred_auto)

lemma UINF_all_nats [simp]:
  fixes P :: "nat \<Rightarrow> '\<alpha> upred"
  shows "(\<Sqinter> n \<bullet> \<Sqinter> i\<in>{0..n} \<bullet> P(i)) = (\<Sqinter> i\<in>{0..} \<bullet> P(i))"
  by (pred_auto)

lemma UINF_refines':
  assumes "\<And> i. P \<sqsubseteq> Q(i)"
  shows "P \<sqsubseteq> (\<Sqinter> i \<bullet> Q(i))"
  using assms
  apply (rel_auto) using Sup_le_iff by fastforce

subsection {* Equality laws *}

lemma eq_upred_refl [simp]: "(x =\<^sub>u x) = true"
  by (pred_auto)

lemma eq_upred_sym: "(x =\<^sub>u y) = (y =\<^sub>u x)"
  by (pred_auto)

lemma eq_cong_left:
  assumes "vwb_lens x" "$x \<sharp> Q" "$x\<acute> \<sharp> Q" "$x \<sharp> R" "$x\<acute> \<sharp> R"
  shows "(($x\<acute> =\<^sub>u $x \<and> Q) = ($x\<acute> =\<^sub>u $x \<and> R)) \<longleftrightarrow> (Q = R)"
  using assms
  by (pred_simp, (meson mwb_lens_def vwb_lens_mwb weak_lens_def)+)

lemma conj_eq_in_var_subst:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "vwb_lens x"
  shows "(P \<and> $x =\<^sub>u v) = (P\<lbrakk>v/$x\<rbrakk> \<and> $x =\<^sub>u v)"
  using assms
  by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)

lemma conj_eq_out_var_subst:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "vwb_lens x"
  shows "(P \<and> $x\<acute> =\<^sub>u v) = (P\<lbrakk>v/$x\<acute>\<rbrakk> \<and> $x\<acute> =\<^sub>u v)"
  using assms
  by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)

lemma conj_pos_var_subst:
  assumes "vwb_lens x"
  shows "($x \<and> Q) = ($x \<and> Q\<lbrakk>true/$x\<rbrakk>)"
  using assms
  by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma conj_neg_var_subst:
  assumes "vwb_lens x"
  shows "(\<not> $x \<and> Q) = (\<not> $x \<and> Q\<lbrakk>false/$x\<rbrakk>)"
  using assms
  by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma upred_eq_true [simp]: "(p =\<^sub>u true) = p"
  by (pred_auto)

lemma upred_eq_false [simp]: "(p =\<^sub>u false) = (\<not> p)"
  by (pred_auto)

lemma upred_true_eq [simp]: "(true =\<^sub>u p) = p"
  by (pred_auto)

lemma upred_false_eq [simp]: "(false =\<^sub>u p) = (\<not> p)"
  by (pred_auto)

lemma conj_var_subst:
  assumes "vwb_lens x"
  shows "(P \<and> var x =\<^sub>u v) = (P\<lbrakk>v/x\<rbrakk> \<and> var x =\<^sub>u v)"
  using assms
  by (pred_simp, (metis (full_types) vwb_lens_def wb_lens.get_put)+)

subsection {* HOL Variable Quantifiers *}

lemma shEx_unbound [simp]: "(\<^bold>\<exists> x \<bullet> P) = P"
  by (pred_auto)

lemma shEx_bool [simp]: "shEx P = (P True \<or> P False)"
  by (pred_simp, metis (full_types))

lemma shEx_commute: "(\<^bold>\<exists> x \<bullet> \<^bold>\<exists> y \<bullet> P x y) = (\<^bold>\<exists> y \<bullet> \<^bold>\<exists> x \<bullet> P x y)"
  by (pred_auto)

lemma shEx_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shEx P = shEx Q"
  by (pred_auto)

lemma shAll_unbound [simp]: "(\<^bold>\<forall> x \<bullet> P) = P"
  by (pred_auto)

lemma shAll_bool [simp]: "shAll P = (P True \<and> P False)"
  by (pred_simp, metis (full_types))

lemma shAll_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shAll P = shAll Q"
  by (pred_auto)

text {* Quantifier lifting *}

named_theorems uquant_lift

lemma shEx_lift_conj_1 [uquant_lift]:
  "((\<^bold>\<exists> x \<bullet> P(x)) \<and> Q) = (\<^bold>\<exists> x \<bullet> P(x) \<and> Q)"
  by (pred_auto)

lemma shEx_lift_conj_2 [uquant_lift]:
  "(P \<and> (\<^bold>\<exists> x \<bullet> Q(x))) = (\<^bold>\<exists> x \<bullet> P \<and> Q(x))"
  by (pred_auto)

subsection {* Case Splitting *}

lemma eq_split_subst:
  assumes "vwb_lens x"
  shows "(P = Q) \<longleftrightarrow> (\<forall> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>)"
  using assms
  by (pred_auto, metis vwb_lens_wb wb_lens.source_stability)

lemma eq_split_substI:
  assumes "vwb_lens x" "\<And> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>"
  shows "P = Q"
  using assms(1) assms(2) eq_split_subst by blast

lemma taut_split_subst:
  assumes "vwb_lens x"
  shows "`P` \<longleftrightarrow> (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
  using assms
  by (pred_auto, metis vwb_lens_wb wb_lens.source_stability)

lemma eq_split:
  assumes "`P \<Rightarrow> Q`" "`Q \<Rightarrow> P`"
  shows "P = Q"
  using assms
  by (pred_auto)

lemma subst_bool_split:
  assumes "vwb_lens x"
  shows "`P` = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
proof -
  from assms have "`P` = (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
    by (subst taut_split_subst[of x], auto)
  also have "... = (`P\<lbrakk>\<guillemotleft>True\<guillemotright>/x\<rbrakk>` \<and> `P\<lbrakk>\<guillemotleft>False\<guillemotright>/x\<rbrakk>`)"
    by (metis (mono_tags, lifting))
  also have "... = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
    by (pred_auto)
  finally show ?thesis .
qed

lemma subst_eq_replace:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(p\<lbrakk>u/x\<rbrakk> \<and> u =\<^sub>u v) = (p\<lbrakk>v/x\<rbrakk> \<and> u =\<^sub>u v)"
  by (pred_auto)

subsection {* UTP Quantifiers *}

lemma exists_twice: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> \<exists> x \<bullet> P) = (\<exists> x \<bullet> P)"
  by (pred_auto)

lemma all_twice: "mwb_lens x \<Longrightarrow> (\<forall> x \<bullet> \<forall> x \<bullet> P) = (\<forall> x \<bullet> P)"
  by (pred_auto)

lemma exists_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> P)"
  by (pred_auto)

lemma all_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> P)"
  by (pred_auto)

lemma ex_commute:
  assumes "x \<bowtie> y"
  shows "(\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma all_commute:
  assumes "x \<bowtie> y"
  shows "(\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> \<forall> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma ex_equiv:
  assumes "x \<approx>\<^sub>L y"
  shows "(\<exists> x \<bullet> P) = (\<exists> y \<bullet> P)"
  using assms
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))

lemma all_equiv:
  assumes "x \<approx>\<^sub>L y"
  shows "(\<forall> x \<bullet> P) = (\<forall> y \<bullet> P)"
  using assms
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))

lemma ex_zero:
  "(\<exists> &\<emptyset> \<bullet> P) = P"
  by (pred_auto)

lemma all_zero:
  "(\<forall> &\<emptyset> \<bullet> P) = P"
  by (pred_auto)

lemma ex_plus:
  "(\<exists> y;x \<bullet> P) = (\<exists> x \<bullet> \<exists> y \<bullet> P)"
  by (pred_auto)

lemma all_plus:
  "(\<forall> y;x \<bullet> P) = (\<forall> x \<bullet> \<forall> y \<bullet> P)"
  by (pred_auto)

lemma closure_all:
  "[P]\<^sub>u = (\<forall> &\<Sigma> \<bullet> P)"
  by (pred_auto)

lemma unrest_as_exists:
  "vwb_lens x \<Longrightarrow> (x \<sharp> P) \<longleftrightarrow> ((\<exists> x \<bullet> P) = P)"
  by (pred_simp, metis vwb_lens.put_eq)

lemma ex_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> (\<exists> x \<bullet> Q)"
  by (pred_auto)

lemma ex_weakens: "wb_lens x \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> P"
  by (pred_simp, metis wb_lens.get_put)

lemma all_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<forall> x \<bullet> P) \<sqsubseteq> (\<forall> x \<bullet> Q)"
  by (pred_auto)

lemma all_strengthens: "wb_lens x \<Longrightarrow> P \<sqsubseteq> (\<forall> x \<bullet> P)"
  by (pred_simp, metis wb_lens.get_put)

lemma ex_unrest: "x \<sharp> P \<Longrightarrow> (\<exists> x \<bullet> P) = P"
  by (pred_auto)

lemma all_unrest: "x \<sharp> P \<Longrightarrow> (\<forall> x \<bullet> P) = P"
  by (pred_auto)

lemma not_ex_not: "\<not> (\<exists> x \<bullet> \<not> P) = (\<forall> x \<bullet> P)"
  by (pred_auto)

subsection {* Variable Restriction *}

lemma var_res_all:
  "P \<restriction>\<^sub>v &\<Sigma> = P"
  by (rel_auto)

lemma var_res_twice:
  "mwb_lens x \<Longrightarrow> P \<restriction>\<^sub>v x \<restriction>\<^sub>v x = P \<restriction>\<^sub>v x"
  by (pred_auto)

subsection {* Conditional laws *}

lemma cond_def:
  "(P \<triangleleft> b \<triangleright> Q) = ((b \<and> P) \<or> ((\<not> b) \<and> Q))"
  by (pred_auto)

lemma cond_idem:"(P \<triangleleft> b \<triangleright> P) = P" by (pred_auto)

lemma cond_symm:"(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft> \<not> b \<triangleright> P)" by (pred_auto)

lemma cond_assoc: "((P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> R) = (P \<triangleleft> b \<and> c \<triangleright> (Q \<triangleleft> c \<triangleright> R))" by (pred_auto)

lemma cond_unit_T [simp]:"(P \<triangleleft> true \<triangleright> Q) = P" by (pred_auto)

lemma cond_unit_F [simp]:"(P \<triangleleft> false \<triangleright> Q) = Q" by (pred_auto)

lemma cond_conj_not: "((P \<triangleleft> b \<triangleright> Q) \<and> (\<not> b)) = (Q \<and> (\<not> b))"
  by (rel_auto)

lemma cond_and_T_integrate:
  "((P \<and> b) \<or> (Q \<triangleleft> b \<triangleright> R)) = ((P \<or> Q) \<triangleleft> b \<triangleright> R)"
  by (pred_auto)

lemma cond_L6: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)" by (pred_auto)

lemma cond_L7: "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)" by (pred_auto)

lemma cond_and_distr: "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_imp_distr:
"((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (R \<Rightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Rightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_eq_distr:
"((P \<Leftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<Leftrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Leftrightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_conj_distr:"(P \<and> (Q \<triangleleft> b \<triangleright> S)) = ((P \<and> Q) \<triangleleft> b \<triangleright> (P \<and> S))" by (pred_auto)

lemma cond_disj_distr:"(P \<or> (Q \<triangleleft> b \<triangleright> S)) = ((P \<or> Q) \<triangleleft> b \<triangleright> (P \<or> S))" by (pred_auto)

lemma cond_neg: "\<not> (P \<triangleleft> b \<triangleright> Q) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))" by (pred_auto)

lemma cond_conj: "P \<triangleleft> b \<and> c \<triangleright> Q = (P \<triangleleft> c \<triangleright> Q) \<triangleleft> b \<triangleright> Q"
  by (pred_auto)

lemma spec_cond_dist: "(P \<Rightarrow> (Q \<triangleleft> b \<triangleright> R)) = ((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (P \<Rightarrow> R))"
  by (pred_auto)

lemma cond_USUP_dist: "(\<Squnion> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Squnion> P\<in>S \<bullet> G(P)) = (\<Squnion> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
  by (pred_auto)

lemma cond_UINF_dist: "(\<Sqinter> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Sqinter> P\<in>S \<bullet> G(P)) = (\<Sqinter> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
  by (pred_auto)

lemma cond_var_subst_left:
  assumes "vwb_lens x"
  shows "(P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> Q) = (P \<triangleleft> var x \<triangleright> Q)"
  using assms by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma cond_var_subst_right:
  assumes "vwb_lens x"
  shows "(P \<triangleleft> var x \<triangleright> Q\<lbrakk>false/x\<rbrakk>) = (P \<triangleleft> var x \<triangleright> Q)"
  using assms by (pred_auto, metis (full_types) vwb_lens.put_eq)

lemma cond_var_split:
  "vwb_lens x \<Longrightarrow> (P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> P\<lbrakk>false/x\<rbrakk>) = P"
  by (rel_simp, (metis (full_types) vwb_lens.put_eq)+)

lemma cond_assign_subst:
  "vwb_lens x \<Longrightarrow> (P \<triangleleft> utp_expr.var x =\<^sub>u v \<triangleright> Q) = (P\<lbrakk>v/x\<rbrakk> \<triangleleft> utp_expr.var x =\<^sub>u v \<triangleright> Q)"
  apply (rel_simp) using vwb_lens.put_eq by force

lemma conj_conds:
  "(P1 \<triangleleft> b \<triangleright> Q1 \<and> P2 \<triangleleft> b \<triangleright> Q2) = (P1 \<and> P2) \<triangleleft> b \<triangleright> (Q1 \<and> Q2)"
  by pred_auto

lemma disj_conds:
  "(P1 \<triangleleft> b \<triangleright> Q1 \<or> P2 \<triangleleft> b \<triangleright> Q2) = (P1 \<or> P2) \<triangleleft> b \<triangleright> (Q1 \<or> Q2)"
  by pred_auto

subsection {* Additional Expression Laws *}

lemma le_pred_refl [simp]:
  fixes x :: "('a::preorder, '\<alpha>) uexpr"
  shows "(x \<le>\<^sub>u x) = true"
  by (pred_auto)

lemma uzero_le_laws [simp]:
  "(0 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u numeral x = true"
  "(1 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u numeral x = true"
  "(0 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u 1 = true"
  by (pred_simp)+

lemma unumeral_le_1 [simp]:
  assumes "(numeral i :: 'a::{numeral,ord}) \<le> numeral j"
  shows "(numeral i :: ('a, '\<alpha>) uexpr) \<le>\<^sub>u numeral j = true"
  using assms by (pred_auto)

lemma unumeral_le_2 [simp]:
  assumes "(numeral i :: 'a::{numeral,linorder}) > numeral j"
  shows "(numeral i :: ('a, '\<alpha>) uexpr) \<le>\<^sub>u numeral j = false"
  using assms by (pred_auto)

lemma uset_laws [simp]:
  "x \<in>\<^sub>u {}\<^sub>u = false"
  "x \<in>\<^sub>u {m..n}\<^sub>u = (m \<le>\<^sub>u x \<and> x \<le>\<^sub>u n)"
  by (pred_auto)+

lemma pfun_entries_apply [simp]:
  "(entr\<^sub>u(d,f) :: (('k, 'v) pfun, '\<alpha>) uexpr)(i)\<^sub>a = ((\<guillemotleft>f\<guillemotright>(i)\<^sub>a) \<triangleleft> i \<in>\<^sub>u d \<triangleright> \<bottom>\<^sub>u)"
  by (pred_auto)

lemma udom_uupdate_pfun [simp]:
  fixes m :: "(('k, 'v) pfun, '\<alpha>) uexpr"
  shows "dom\<^sub>u(m(k \<mapsto> v)\<^sub>u) = {k}\<^sub>u \<union>\<^sub>u dom\<^sub>u(m)"
  by (rel_auto)

lemma uapply_uupdate_pfun [simp]:
  fixes m :: "(('k, 'v) pfun, '\<alpha>) uexpr"
  shows "(m(k \<mapsto> v)\<^sub>u)(i)\<^sub>a = v \<triangleleft> i =\<^sub>u k \<triangleright> m(i)\<^sub>a"
  by (rel_auto)

lemma ulit_eq [simp]: "x = y \<Longrightarrow> (\<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>y\<guillemotright>) = true"
  by (rel_auto)

lemma ulit_neq [simp]: "x \<noteq> y \<Longrightarrow> (\<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>y\<guillemotright>) = false"
  by (rel_auto)

lemma uset_mems [simp]:
  "x \<in>\<^sub>u {y}\<^sub>u = (x =\<^sub>u y)"
  "x \<in>\<^sub>u A \<union>\<^sub>u B = (x \<in>\<^sub>u A \<or> x \<in>\<^sub>u B)"
  "x \<in>\<^sub>u A \<inter>\<^sub>u B = (x \<in>\<^sub>u A \<and> x \<in>\<^sub>u B)"
  by (rel_auto)+

subsection {* Refinement By Observation *}

text {* Function to obtain the set of observations of a predicate *}

definition obs_upred :: "'\<alpha> upred \<Rightarrow> '\<alpha> set" ("\<lbrakk>_\<rbrakk>\<^sub>o")
where [upred_defs]: "\<lbrakk>P\<rbrakk>\<^sub>o = {b. \<lbrakk>P\<rbrakk>\<^sub>eb}"

lemma obs_upred_refine_iff:
  "P \<sqsubseteq> Q \<longleftrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>o \<subseteq> \<lbrakk>P\<rbrakk>\<^sub>o"
  by (pred_auto)

text {* A refinement can be demonstrated by considering only the observations of the predicates
  which are relevant, i.e. not unrestricted, for them. In other words, if the alphabet can
  be split into two disjoint segments, $x$ and $y$, and neither predicate refers to $y$ then
  only $x$ need be considered when checking for observations. *}

lemma refine_by_obs:
  assumes "x \<bowtie> y" "bij_lens (x +\<^sub>L y)" "y \<sharp> P" "y \<sharp> Q" "{v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`} \<subseteq> {v. `Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`}"
  shows "Q \<sqsubseteq> P"
  using assms(3-5)
  apply (simp add: obs_upred_refine_iff subset_eq)
  apply (pred_simp)
  apply (rename_tac b)
  apply (drule_tac x="get\<^bsub>x\<^esub>b" in spec)
  apply (auto simp add: assms)
  apply (metis assms(1) assms(2) bij_lens.axioms(2) bij_lens_axioms_def lens_override_def lens_override_plus)+
done

subsection {* Cylindric Algebra *}

lemma C1: "(\<exists> x \<bullet> false) = false"
  by (pred_auto)

lemma C2: "wb_lens x \<Longrightarrow> `P \<Rightarrow> (\<exists> x \<bullet> P)`"
  by (pred_simp, metis wb_lens.get_put)

lemma C3: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> (P \<and> (\<exists> x \<bullet> Q))) = ((\<exists> x \<bullet> P) \<and> (\<exists> x \<bullet> Q))"
  by (pred_auto)

lemma C4a: "x \<approx>\<^sub>L y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))+

lemma C4b: "x \<bowtie> y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  using ex_commute by blast

lemma C5:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(&x =\<^sub>u &x) = true"
  by (pred_auto)

lemma C6:
  assumes "wb_lens x" "x \<bowtie> y" "x \<bowtie> z"
  shows "(&y =\<^sub>u &z) = (\<exists> x \<bullet> &y =\<^sub>u &x \<and> &x =\<^sub>u &z)"
  using assms
  by (pred_simp, (metis lens_indep_def)+)

lemma C7:
  assumes "weak_lens x" "x \<bowtie> y"
  shows "((\<exists> x \<bullet> &x =\<^sub>u &y \<and> P) \<and> (\<exists> x \<bullet> &x =\<^sub>u &y \<and> \<not> P)) = false"
  using assms
  by (pred_simp, simp add: lens_indep_sym)
subsection {*AUX lemmas*}

lemma uimp_refl:"`p \<Rightarrow> p`"
  by pred_simp

end