(*  Title:      HOL/MacLaurin.thy
    Author:     Jacques D. Fleuriot, 2001 University of Edinburgh
    Author:     Lawrence C Paulson, 2004
    Author:     Lukas Bulwahn and Bernhard Häupler, 2005
*)

section \<open>MacLaurin and Taylor Series\<close>

theory MacLaurin
imports Transcendental
begin

subsection \<open>Maclaurin's Theorem with Lagrange Form of Remainder\<close>

text \<open>This is a very long, messy proof even now that it's been broken down
  into lemmas.\<close>

lemma Maclaurin_lemma:
  "0 < h \<Longrightarrow>
    \<exists>B::real. f h = (\<Sum>m<n. (j m / (fact m)) * (h^m)) + (B * ((h^n) /(fact n)))"
  by (rule exI[where x = "(f h - (\<Sum>m<n. (j m / (fact m)) * h^m)) * (fact n) / (h^n)"]) simp

lemma eq_diff_eq': "x = y - z \<longleftrightarrow> y = x + z"
  for x y z :: real
  by arith

lemma fact_diff_Suc: "n < Suc m \<Longrightarrow> fact (Suc m - n) = (Suc m - n) * fact (m - n)"
  by (subst fact_reduce) auto

lemma Maclaurin_lemma2:
  fixes B
  assumes DERIV: "\<forall>m t. m < n \<and> 0\<le>t \<and> t\<le>h \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
    and INIT: "n = Suc k"
  defines "difg \<equiv>
    (\<lambda>m t::real. diff m t -
      ((\<Sum>p<n - m. diff (m + p) 0 / fact p * t ^ p) + B * (t ^ (n - m) / fact (n - m))))"
    (is "difg \<equiv> (\<lambda>m t. diff m t - ?difg m t)")
  shows "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> h \<longrightarrow> DERIV (difg m) t :> difg (Suc m) t"
proof (rule allI impI)+
  fix m t
  assume INIT2: "m < n \<and> 0 \<le> t \<and> t \<le> h"
  have "DERIV (difg m) t :> diff (Suc m) t -
    ((\<Sum>x<n - m. real x * t ^ (x - Suc 0) * diff (m + x) 0 / fact x) +
     real (n - m) * t ^ (n - Suc m) * B / fact (n - m))"
    by (auto simp: difg_def intro!: derivative_eq_intros DERIV[rule_format, OF INIT2])
  moreover
  from INIT2 have intvl: "{..<n - m} = insert 0 (Suc ` {..<n - Suc m})" and "0 < n - m"
    unfolding atLeast0LessThan[symmetric] by auto
  have "(\<Sum>x<n - m. real x * t ^ (x - Suc 0) * diff (m + x) 0 / fact x) =
      (\<Sum>x<n - Suc m. real (Suc x) * t ^ x * diff (Suc m + x) 0 / fact (Suc x))"
    unfolding intvl by (subst sum.insert) (auto simp: sum.reindex)
  moreover
  have fact_neq_0: "\<And>x. (fact x) + real x * (fact x) \<noteq> 0"
    by (metis add_pos_pos fact_gt_zero less_add_same_cancel1 less_add_same_cancel2
        less_numeral_extra(3) mult_less_0_iff of_nat_less_0_iff)
  have "\<And>x. (Suc x) * t ^ x * diff (Suc m + x) 0 / fact (Suc x) = diff (Suc m + x) 0 * t^x / fact x"
    by (rule nonzero_divide_eq_eq[THEN iffD2]) auto
  moreover
  have "(n - m) * t ^ (n - Suc m) * B / fact (n - m) = B * (t ^ (n - Suc m) / fact (n - Suc m))"
    using \<open>0 < n - m\<close> by (simp add: field_split_simps fact_reduce)
  ultimately show "DERIV (difg m) t :> difg (Suc m) t"
    unfolding difg_def  by (simp add: mult.commute)
qed

lemma Maclaurin:
  assumes h: "0 < h"
    and n: "0 < n"
    and diff_0: "diff 0 = f"
    and diff_Suc: "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> h \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
  shows
    "\<exists>t::real. 0 < t \<and> t < h \<and>
      f h = sum (\<lambda>m. (diff m 0 / fact m) * h ^ m) {..<n} + (diff n t / fact n) * h ^ n"
proof -
  from n obtain m where m: "n = Suc m"
    by (cases n) (simp add: n)
  from m have "m < n" by simp

  obtain B where f_h: "f h = (\<Sum>m<n. diff m 0 / fact m * h ^ m) + B * (h ^ n / fact n)"
    using Maclaurin_lemma [OF h] ..

  define g where [abs_def]: "g t =
    f t - (sum (\<lambda>m. (diff m 0 / fact m) * t^m) {..<n} + B * (t^n / fact n))" for t
  have g2: "g 0 = 0" "g h = 0"
    by (simp_all add: m f_h g_def lessThan_Suc_eq_insert_0 image_iff diff_0 sum.reindex)

  define difg where [abs_def]: "difg m t =
    diff m t - (sum (\<lambda>p. (diff (m + p) 0 / fact p) * (t ^ p)) {..<n-m} +
      B * ((t ^ (n - m)) / fact (n - m)))" for m t
  have difg_0: "difg 0 = g"
    by (simp add: difg_def g_def diff_0)
  have difg_Suc: "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> h \<longrightarrow> DERIV (difg m) t :> difg (Suc m) t"
    using diff_Suc m unfolding difg_def [abs_def] by (rule Maclaurin_lemma2)
  have difg_eq_0: "\<forall>m<n. difg m 0 = 0"
    by (auto simp: difg_def m Suc_diff_le lessThan_Suc_eq_insert_0 image_iff sum.reindex)
  have isCont_difg: "\<And>m x. m < n \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<le> h \<Longrightarrow> isCont (difg m) x"
    by (rule DERIV_isCont [OF difg_Suc [rule_format]]) simp
  have differentiable_difg: "\<And>m x. m < n \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<le> h \<Longrightarrow> difg m differentiable (at x)"
    using difg_Suc real_differentiable_def by auto
  have difg_Suc_eq_0:
    "\<And>m t. m < n \<Longrightarrow> 0 \<le> t \<Longrightarrow> t \<le> h \<Longrightarrow> DERIV (difg m) t :> 0 \<Longrightarrow> difg (Suc m) t = 0"
    by (rule DERIV_unique [OF difg_Suc [rule_format]]) simp

  have "\<exists>t. 0 < t \<and> t < h \<and> DERIV (difg m) t :> 0"
  using \<open>m < n\<close>
  proof (induct m)
    case 0
    show ?case
    proof (rule Rolle)
      show "0 < h" by fact
      show "difg 0 0 = difg 0 h"
        by (simp add: difg_0 g2)
      show "continuous_on {0..h} (difg 0)"
        by (simp add: continuous_at_imp_continuous_on isCont_difg n)
    qed (simp add: differentiable_difg n)
  next
    case (Suc m')
    then obtain t where t: "0 < t" "t < h" "DERIV (difg m') t :> 0"
      by force
    have "\<exists>t'. 0 < t' \<and> t' < t \<and> DERIV (difg (Suc m')) t' :> 0"
    proof (rule Rolle)
      show "0 < t" by fact
      show "difg (Suc m') 0 = difg (Suc m') t"
        using t \<open>Suc m' < n\<close> by (simp add: difg_Suc_eq_0 difg_eq_0)
      have "\<And>x. 0 \<le> x \<and> x \<le> t \<Longrightarrow> isCont (difg (Suc m')) x"
        using \<open>t < h\<close> \<open>Suc m' < n\<close> by (simp add: isCont_difg)
      then show "continuous_on {0..t} (difg (Suc m'))"
        by (simp add: continuous_at_imp_continuous_on)
    qed (use \<open>t < h\<close> \<open>Suc m' < n\<close> in \<open>simp add: differentiable_difg\<close>)
    with \<open>t < h\<close> show ?case
      by auto
  qed
  then obtain t where "0 < t" "t < h" "difg (Suc m) t = 0"
    using \<open>m < n\<close> difg_Suc_eq_0 by force
  show ?thesis
  proof (intro exI conjI)
    show "0 < t" "t < h" by fact+
    show "f h = (\<Sum>m<n. diff m 0 / (fact m) * h ^ m) + diff n t / (fact n) * h ^ n"
      using \<open>difg (Suc m) t = 0\<close> by (simp add: m f_h difg_def)
  qed
qed

lemma Maclaurin2:
  fixes n :: nat
    and h :: real
  assumes INIT1: "0 < h"
    and INIT2: "diff 0 = f"
    and DERIV: "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> h \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
  shows "\<exists>t. 0 < t \<and> t \<le> h \<and> f h = (\<Sum>m<n. diff m 0 / (fact m) * h ^ m) + diff n t / fact n * h ^ n"
proof (cases n)
  case 0
  with INIT1 INIT2 show ?thesis by fastforce
next
  case Suc
  then have "n > 0" by simp
  from Maclaurin [OF INIT1 this INIT2 DERIV]
  show ?thesis by fastforce
qed

lemma Maclaurin_minus:
  fixes n :: nat and h :: real
  assumes "h < 0" "0 < n" "diff 0 = f"
    and DERIV: "\<forall>m t. m < n \<and> h \<le> t \<and> t \<le> 0 \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
  shows "\<exists>t. h < t \<and> t < 0 \<and> f h = (\<Sum>m<n. diff m 0 / fact m * h ^ m) + diff n t / fact n * h ^ n"
proof -
  txt \<open>Transform \<open>ABL'\<close> into \<open>derivative_intros\<close> format.\<close>
  note DERIV' = DERIV_chain'[OF _ DERIV[rule_format], THEN DERIV_cong]
  let ?sum = "\<lambda>t.
    (\<Sum>m<n. (- 1) ^ m * diff m (- 0) / (fact m) * (- h) ^ m) +
    (- 1) ^ n * diff n (- t) / (fact n) * (- h) ^ n"
  from assms have "\<exists>t>0. t < - h \<and> f (- (- h)) = ?sum t"
    by (intro Maclaurin) (auto intro!: derivative_eq_intros DERIV')
  then obtain t where "0 < t" "t < - h" "f (- (- h)) = ?sum t"
    by blast
  moreover have "(- 1) ^ n * diff n (- t) * (- h) ^ n / fact n = diff n (- t) * h ^ n / fact n"
    by (auto simp: power_mult_distrib[symmetric])
  moreover
    have "(\<Sum>m<n. (- 1) ^ m * diff m 0 * (- h) ^ m / fact m) = (\<Sum>m<n. diff m 0 * h ^ m / fact m)"
    by (auto intro: sum.cong simp add: power_mult_distrib[symmetric])
  ultimately have "h < - t \<and> - t < 0 \<and>
    f h = (\<Sum>m<n. diff m 0 / (fact m) * h ^ m) + diff n (- t) / (fact n) * h ^ n"
    by auto
  then show ?thesis ..
qed

subsection \<open>More Convenient "Bidirectional" Version.\<close>

lemma Maclaurin_bi_le:
  fixes n :: nat and x :: real
  assumes "diff 0 = f"
    and DERIV : "\<forall>m t. m < n \<and> \<bar>t\<bar> \<le> \<bar>x\<bar> \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
  shows "\<exists>t. \<bar>t\<bar> \<le> \<bar>x\<bar> \<and> f x = (\<Sum>m<n. diff m 0 / (fact m) * x ^ m) + diff n t / (fact n) * x ^ n"
    (is "\<exists>t. _ \<and> f x = ?f x t")
proof (cases "n = 0")
  case True
  with \<open>diff 0 = f\<close> show ?thesis by force
next
  case False
  show ?thesis
  proof (cases rule: linorder_cases)
    assume "x = 0"
    with \<open>n \<noteq> 0\<close> \<open>diff 0 = f\<close> DERIV have "\<bar>0\<bar> \<le> \<bar>x\<bar> \<and> f x = ?f x 0"
      by auto
    then show ?thesis ..
  next
    assume "x < 0"
    with \<open>n \<noteq> 0\<close> DERIV have "\<exists>t>x. t < 0 \<and> diff 0 x = ?f x t"
      by (intro Maclaurin_minus) auto
    then obtain t where "x < t" "t < 0"
      "diff 0 x = (\<Sum>m<n. diff m 0 / fact m * x ^ m) + diff n t / fact n * x ^ n"
      by blast
    with \<open>x < 0\<close> \<open>diff 0 = f\<close> show ?thesis by force
  next
    assume "x > 0"
    with \<open>n \<noteq> 0\<close> \<open>diff 0 = f\<close> DERIV have "\<exists>t>0. t < x \<and> diff 0 x = ?f x t"
      by (intro Maclaurin) auto
    then obtain t where "0 < t" "t < x"
      "diff 0 x = (\<Sum>m<n. diff m 0 / fact m * x ^ m) + diff n t / fact n * x ^ n"
      by blast
    with \<open>x > 0\<close> \<open>diff 0 = f\<close> have "\<bar>t\<bar> \<le> \<bar>x\<bar> \<and> f x = ?f x t" by simp
    then show ?thesis ..
  qed
qed

lemma Maclaurin_all_lt:
  fixes x :: real
  assumes INIT1: "diff 0 = f"
    and INIT2: "0 < n"
    and INIT3: "x \<noteq> 0"
    and DERIV: "\<forall>m x. DERIV (diff m) x :> diff(Suc m) x"
  shows "\<exists>t. 0 < \<bar>t\<bar> \<and> \<bar>t\<bar> < \<bar>x\<bar> \<and> f x =
      (\<Sum>m<n. (diff m 0 / fact m) * x ^ m) + (diff n t / fact n) * x ^ n"
    (is "\<exists>t. _ \<and> _ \<and> f x = ?f x t")
proof (cases rule: linorder_cases)
  assume "x = 0"
  with INIT3 show ?thesis ..
next
  assume "x < 0"
  with assms have "\<exists>t>x. t < 0 \<and> f x = ?f x t"
    by (intro Maclaurin_minus) auto
  then show ?thesis by force
next
  assume "x > 0"
  with assms have "\<exists>t>0. t < x \<and> f x = ?f x t"
    by (intro Maclaurin) auto
  then show ?thesis by force
qed

lemma Maclaurin_zero: "x = 0 \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> (\<Sum>m<n. (diff m 0 / fact m) * x ^ m) = diff 0 0"
  for x :: real and n :: nat
  by simp

lemma Maclaurin_all_le:
  fixes x :: real and n :: nat
  assumes INIT: "diff 0 = f"
    and DERIV: "\<forall>m x. DERIV (diff m) x :> diff (Suc m) x"
  shows "\<exists>t. \<bar>t\<bar> \<le> \<bar>x\<bar> \<and> f x = (\<Sum>m<n. (diff m 0 / fact m) * x ^ m) + (diff n t / fact n) * x ^ n"
    (is "\<exists>t. _ \<and> f x = ?f x t")
proof (cases "n = 0")
  case True
  with INIT show ?thesis by force
next
  case False
  show ?thesis
    using DERIV INIT Maclaurin_bi_le by auto
qed

lemma Maclaurin_all_le_objl:
  "diff 0 = f \<and> (\<forall>m x. DERIV (diff m) x :> diff (Suc m) x) \<longrightarrow>
    (\<exists>t::real. \<bar>t\<bar> \<le> \<bar>x\<bar> \<and> f x = (\<Sum>m<n. (diff m 0 / fact m) * x ^ m) + (diff n t / fact n) * x ^ n)"
  for x :: real and n :: nat
  by (blast intro: Maclaurin_all_le)

subsection \<open>Version for Exponential Function\<close>

lemma Maclaurin_exp_lt:
  fixes x :: real and n :: nat
  shows
    "x \<noteq> 0 \<Longrightarrow> n > 0 \<Longrightarrow>
      (\<exists>t. 0 < \<bar>t\<bar> \<and> \<bar>t\<bar> < \<bar>x\<bar> \<and> exp x = (\<Sum>m<n. (x ^ m) / fact m) + (exp t / fact n) * x ^ n)"
 using Maclaurin_all_lt [where diff = "\<lambda>n. exp" and f = exp and x = x and n = n] by auto

lemma Maclaurin_exp_le:
  fixes x :: real and n :: nat
  shows "\<exists>t. \<bar>t\<bar> \<le> \<bar>x\<bar> \<and> exp x = (\<Sum>m<n. (x ^ m) / fact m) + (exp t / fact n) * x ^ n"
  using Maclaurin_all_le_objl [where diff = "\<lambda>n. exp" and f = exp and x = x and n = n] by auto

corollary exp_lower_Taylor_quadratic: "0 \<le> x \<Longrightarrow> 1 + x + x\<^sup>2 / 2 \<le> exp x"
  for x :: real
  using Maclaurin_exp_le [of x 3] by (auto simp: numeral_3_eq_3 power2_eq_square)

corollary ln_2_less_1: "ln 2 < (1::real)"
  by (smt (verit) ln_eq_minus_one ln_le_minus_one)

subsection \<open>Version for Sine Function\<close>

lemma mod_exhaust_less_4: "m mod 4 = 0 \<or> m mod 4 = 1 \<or> m mod 4 = 2 \<or> m mod 4 = 3"
  for m :: nat
  by auto

text \<open>It is unclear why so many variant results are needed.\<close>

lemma sin_expansion_lemma: "sin (x + real (Suc m) * pi / 2) = cos (x + real m * pi / 2)"
  by (auto simp: cos_add sin_add add_divide_distrib distrib_right)

lemma Maclaurin_sin_expansion2:
  "\<exists>t. \<bar>t\<bar> \<le> \<bar>x\<bar> \<and>
    sin x = (\<Sum>m<n. sin_coeff m * x ^ m) + (sin (t + 1/2 * real n * pi) / fact n) * x ^ n"
proof (cases "n = 0 \<or> x = 0")
  case False
  let ?diff = "\<lambda>n x. sin (x + 1/2 * real n * pi)"
  have "\<exists>t. 0 < \<bar>t\<bar> \<and> \<bar>t\<bar> < \<bar>x\<bar> \<and> sin x =
      (\<Sum>m<n. (?diff m 0 / fact m) * x ^ m) + (?diff n t / fact n) * x ^ n"
  proof (rule Maclaurin_all_lt)
    show "\<forall>m x. ((\<lambda>t. sin (t + 1/2 * real m * pi)) has_real_derivative
           sin (x + 1/2 * real (Suc m) * pi)) (at x)"
      by (rule allI derivative_eq_intros | use sin_expansion_lemma in force)+
  qed (use False in auto)
  then show ?thesis
    apply (rule ex_forward, simp)
    apply (rule sum.cong[OF refl])
    apply (auto simp: sin_coeff_def sin_zero_iff elim: oddE simp del: of_nat_Suc)
    done
qed auto

lemma Maclaurin_sin_expansion:
  "\<exists>t. sin x = (\<Sum>m<n. sin_coeff m * x ^ m) + (sin (t + 1/2 * real n * pi) / fact n) * x ^ n"
  using Maclaurin_sin_expansion2 [of x n] by blast

lemma Maclaurin_sin_expansion3:
  assumes "n > 0" "x > 0"
    shows "\<exists>t. 0 < t \<and> t < x \<and>
          sin x = (\<Sum>m<n. sin_coeff m * x ^ m) + (sin (t + 1/2 * real n * pi) / fact n) * x ^ n"
proof -
  let ?diff = "\<lambda>n x. sin (x + 1/2 * real n * pi)"
  have "\<exists>t. 0 < t \<and> t < x \<and> sin x = (\<Sum>m<n. ?diff m 0 / (fact m) * x ^ m) + ?diff n t / fact n * x ^ n"
  proof (rule Maclaurin)
    show "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> x \<longrightarrow>
                ((\<lambda>u. sin (u + 1/2 * real m * pi)) has_real_derivative
                 sin (t + 1/2 * real (Suc m) * pi)) (at t)"
      apply (simp add: sin_expansion_lemma del: of_nat_Suc)
      apply (force intro!: derivative_eq_intros)
      done
  qed (use assms in auto)
  then show ?thesis
    apply (rule ex_forward, simp)
    apply (rule sum.cong[OF refl])
    apply (auto simp: sin_coeff_def sin_zero_iff elim: oddE simp del: of_nat_Suc)
    done
qed

lemma Maclaurin_sin_expansion4:
  assumes "0 < x"
  shows "\<exists>t. 0 < t \<and> t \<le> x \<and> sin x = (\<Sum>m<n. sin_coeff m * x ^ m) + (sin (t + 1/2 * real n * pi) / fact n) * x ^ n"
proof -
  let ?diff = "\<lambda>n x. sin (x + 1/2 * real n * pi)"
  have "\<exists>t. 0 < t \<and> t \<le> x \<and> sin x = (\<Sum>m<n. ?diff m 0 / (fact m) * x ^ m) + ?diff n t / fact n * x ^ n"
  proof (rule Maclaurin2)
    show "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> x \<longrightarrow>
                ((\<lambda>u. sin (u + 1/2 * real m * pi)) has_real_derivative
                 sin (t + 1/2 * real (Suc m) * pi)) (at t)"
      apply (simp add: sin_expansion_lemma del: of_nat_Suc)
      apply (force intro!: derivative_eq_intros)
      done
  qed (use assms in auto)
  then show ?thesis
    apply (rule ex_forward, simp)
    apply (rule sum.cong[OF refl])
    apply (auto simp: sin_coeff_def sin_zero_iff elim: oddE simp del: of_nat_Suc)
    done
qed

subsection \<open>Maclaurin Expansion for Cosine Function\<close>

lemma sumr_cos_zero_one [simp]: "(\<Sum>m<Suc n. cos_coeff m * 0 ^ m) = 1"
  by (induct n) auto

lemma cos_expansion_lemma: "cos (x + real (Suc m) * pi / 2) = - sin (x + real m * pi / 2)"
  by (auto simp: cos_add sin_add distrib_right add_divide_distrib)

lemma Maclaurin_cos_expansion:
  "\<exists>t::real. \<bar>t\<bar> \<le> \<bar>x\<bar> \<and>
    cos x = (\<Sum>m<n. cos_coeff m * x ^ m) + (cos(t + 1/2 * real n * pi) / fact n) * x ^ n"
proof (cases "n = 0 \<or> x = 0")
  case False
  let ?diff = "\<lambda>n x. cos (x + 1/2 * real n * pi)"
  have "\<exists>t. 0 < \<bar>t\<bar> \<and> \<bar>t\<bar> < \<bar>x\<bar> \<and> cos x =
      (\<Sum>m<n. (?diff m 0 / fact m) * x ^ m) + (?diff n t / fact n) * x ^ n"
  proof (rule Maclaurin_all_lt)
    show "\<forall>m x. ((\<lambda>t. cos (t + 1/2 * real m * pi)) has_real_derivative
           cos (x + 1/2 * real (Suc m) * pi)) (at x)"
      using cos_expansion_lemma
      by (intro allI derivative_eq_intros | simp)+
  qed (use False in auto)
  then show ?thesis
    apply (rule ex_forward, simp)
    apply (rule sum.cong[OF refl])
    apply (auto simp: cos_coeff_def cos_zero_iff elim: evenE simp del: of_nat_Suc)
    done
qed auto

lemma Maclaurin_cos_expansion2:
  assumes "x > 0" "n > 0"
  shows "\<exists>t. 0 < t \<and> t < x \<and>
      cos x = (\<Sum>m<n. cos_coeff m * x ^ m) + (cos (t + 1/2 * real n * pi) / fact n) * x ^ n"
proof -
  let ?diff = "\<lambda>n x. cos (x + 1/2 * real n * pi)"
  have "\<exists>t. 0 < t \<and> t < x \<and> cos x = (\<Sum>m<n. ?diff m 0 / (fact m) * x ^ m) + ?diff n t / fact n * x ^ n"
  proof (rule Maclaurin)
    show "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> x \<longrightarrow>
              ((\<lambda>u. cos (u + 1 / 2 * real m * pi)) has_real_derivative
               cos (t + 1 / 2 * real (Suc m) * pi)) (at t)"
      by (simp add: cos_expansion_lemma del: of_nat_Suc)
  qed (use assms in auto)
  then show ?thesis
    apply (rule ex_forward, simp)
    apply (rule sum.cong[OF refl])
    apply (auto simp: cos_coeff_def cos_zero_iff elim: evenE)
    done
qed

lemma Maclaurin_minus_cos_expansion:
  assumes "n > 0" "x < 0"
  shows "\<exists>t. x < t \<and> t < 0 \<and>
         cos x = (\<Sum>m<n. cos_coeff m * x ^ m) + ((cos (t + 1/2 * real n * pi) / fact n) * x ^ n)"
proof -
  let ?diff = "\<lambda>n x. cos (x + 1/2 * real n * pi)"
  have "\<exists>t. x < t \<and> t < 0 \<and> cos x = (\<Sum>m<n. ?diff m 0 / (fact m) * x ^ m) + ?diff n t / fact n * x ^ n"
  proof (rule Maclaurin_minus)
    show "\<forall>m t. m < n \<and> x \<le> t \<and> t \<le> 0 \<longrightarrow>
              ((\<lambda>u. cos (u + 1 / 2 * real m * pi)) has_real_derivative
               cos (t + 1 / 2 * real (Suc m) * pi)) (at t)"
      by (simp add: cos_expansion_lemma del: of_nat_Suc)
  qed (use assms in auto)
  then show ?thesis
    apply (rule ex_forward, simp)
    apply (rule sum.cong[OF refl])
    apply (auto simp: cos_coeff_def cos_zero_iff elim: evenE)
    done
qed

(* Version for ln(1 +/- x). Where is it?? *)

lemma sin_bound_lemma: "x = y \<Longrightarrow> \<bar>u\<bar> \<le> v \<Longrightarrow> \<bar>(x + u) - y\<bar> \<le> v"
  for x y u v :: real
  by auto

lemma Maclaurin_sin_bound: "\<bar>sin x - (\<Sum>m<n. sin_coeff m * x ^ m)\<bar> \<le> inverse (fact n) * \<bar>x\<bar> ^ n"
proof -
  have est: "x \<le> 1 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x * y \<le> 1 * y" for x y :: real
    by (rule mult_right_mono) simp_all
  let ?diff = "\<lambda>(n::nat) (x::real).
    if n mod 4 = 0 then sin x
    else if n mod 4 = 1 then cos x
    else if n mod 4 = 2 then - sin x
    else - cos x"
  have diff_0: "?diff 0 = sin" by simp
  have "DERIV (?diff m) x :> ?diff (Suc m) x" for m and x
    using mod_exhaust_less_4 [of m]
    by (auto simp: mod_Suc intro!: derivative_eq_intros)
  then have DERIV_diff: "\<forall>m x. DERIV (?diff m) x :> ?diff (Suc m) x"
    by blast
  from Maclaurin_all_le [OF diff_0 DERIV_diff]
  obtain t where t1: "\<bar>t\<bar> \<le> \<bar>x\<bar>"
    and t2: "sin x = (\<Sum>m<n. ?diff m 0 / (fact m) * x ^ m) + ?diff n t / (fact n) * x ^ n"
    by fast
  have diff_m_0: "?diff m 0 = (if even m then 0 else (- 1) ^ ((m - Suc 0) div 2))" for m
    using mod_exhaust_less_4 [of m]
    by (auto simp: minus_one_power_iff even_even_mod_4_iff [of m] dest: even_mod_4_div_2 odd_mod_4_div_2)
  show ?thesis
    apply (subst t2)
    apply (rule sin_bound_lemma)
     apply (rule sum.cong[OF refl])
    unfolding sin_coeff_def
     apply (subst diff_m_0, simp)
    using est
    apply (auto intro: mult_right_mono [where b=1, simplified] mult_right_mono
        simp: ac_simps divide_inverse power_abs [symmetric] abs_mult)
    done
qed

section \<open>Taylor series\<close>

text \<open>
  We use MacLaurin and the translation of the expansion point \<open>c\<close> to \<open>0\<close>
  to prove Taylor's theorem.
\<close>

lemma Taylor_up:
  assumes INIT: "n > 0" "diff 0 = f"
    and DERIV: "\<forall>m t. m < n \<and> a \<le> t \<and> t \<le> b \<longrightarrow> DERIV (diff m) t :> (diff (Suc m) t)"
    and INTERV: "a \<le> c" "c < b"
  shows "\<exists>t::real. c < t \<and> t < b \<and>
    f b = (\<Sum>m<n. (diff m c / fact m) * (b - c)^m) + (diff n t / fact n) * (b - c)^n"
proof -
  from INTERV have "0 < b - c" by arith
  moreover from INIT have "n > 0" "(\<lambda>m x. diff m (x + c)) 0 = (\<lambda>x. f (x + c))"
    by auto
  moreover
  have "\<forall>m t. m < n \<and> 0 \<le> t \<and> t \<le> b - c \<longrightarrow> DERIV (\<lambda>x. diff m (x + c)) t :> diff (Suc m) (t + c)"
  proof (intro strip)
    fix m t
    assume "m < n \<and> 0 \<le> t \<and> t \<le> b - c"
    with DERIV and INTERV have "DERIV (diff m) (t + c) :> diff (Suc m) (t + c)"
      by auto
    moreover from DERIV_ident and DERIV_const have "DERIV (\<lambda>x. x + c) t :> 1 + 0"
      by (rule DERIV_add)
    ultimately have "DERIV (\<lambda>x. diff m (x + c)) t :> diff (Suc m) (t + c) * (1 + 0)"
      by (rule DERIV_chain2)
    then show "DERIV (\<lambda>x. diff m (x + c)) t :> diff (Suc m) (t + c)"
      by simp
  qed
  ultimately obtain x where
    "0 < x \<and> x < b - c \<and>
      f (b - c + c) =
        (\<Sum>m<n. diff m (0 + c) / fact m * (b - c) ^ m) + diff n (x + c) / fact n * (b - c) ^ n"
     by (rule Maclaurin [THEN exE])
  then show ?thesis
    by (smt (verit) sum.cong)
qed

lemma Taylor_down:
  fixes a :: real and n :: nat
  assumes INIT: "n > 0" "diff 0 = f"
    and DERIV: "(\<forall>m t. m < n \<and> a \<le> t \<and> t \<le> b \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t)"
    and INTERV: "a < c" "c \<le> b"
  shows "\<exists>t. a < t \<and> t < c \<and>
    f a = (\<Sum>m<n. (diff m c / fact m) * (a - c)^m) + (diff n t / fact n) * (a - c)^n"
proof -
  from INTERV have "a-c < 0" by arith
  moreover from INIT have "n > 0" "(\<lambda>m x. diff m (x + c)) 0 = (\<lambda>x. f (x + c))"
    by auto
  moreover
  have "\<forall>m t. m < n \<and> a - c \<le> t \<and> t \<le> 0 \<longrightarrow> DERIV (\<lambda>x. diff m (x + c)) t :> diff (Suc m) (t + c)"
  proof (rule allI impI)+
    fix m t
    assume "m < n \<and> a - c \<le> t \<and> t \<le> 0"
    with DERIV and INTERV have "DERIV (diff m) (t + c) :> diff (Suc m) (t + c)"
      by auto
    moreover from DERIV_ident and DERIV_const have "DERIV (\<lambda>x. x + c) t :> 1 + 0"
      by (rule DERIV_add)
    ultimately show "DERIV (\<lambda>x. diff m (x + c)) t :> diff (Suc m) (t + c)"
      using DERIV_chain2 DERIV_shift by blast
  qed
  ultimately obtain x where
    "a - c < x \<and> x < 0 \<and>
      f (a - c + c) =
        (\<Sum>m<n. diff m (0 + c) / fact m * (a - c) ^ m) + diff n (x + c) / fact n * (a - c) ^ n"
    by (rule Maclaurin_minus [THEN exE])
  then have "a < x + c \<and> x + c < c \<and>
    f a = (\<Sum>m<n. diff m c / fact m * (a - c) ^ m) + diff n (x + c) / fact n * (a - c) ^ n"
    by fastforce
  then show ?thesis by fastforce
qed

theorem Taylor:
  fixes a :: real and n :: nat
  assumes INIT: "n > 0" "diff 0 = f"
    and DERIV: "\<forall>m t. m < n \<and> a \<le> t \<and> t \<le> b \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
    and INTERV: "a \<le> c " "c \<le> b" "a \<le> x" "x \<le> b" "x \<noteq> c"
  shows "\<exists>t.
    (if x < c then x < t \<and> t < c else c < t \<and> t < x) \<and>
    f x = (\<Sum>m<n. (diff m c / fact m) * (x - c)^m) + (diff n t / fact n) * (x - c)^n"
proof (cases "x < c")
  case True
  note INIT
  moreover have "\<forall>m t. m < n \<and> x \<le> t \<and> t \<le> b \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
    using DERIV and INTERV by fastforce
  ultimately show ?thesis
    using True INTERV Taylor_down by simp
next
  case False
  note INIT
  moreover have "\<forall>m t. m < n \<and> a \<le> t \<and> t \<le> x \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
    using DERIV and INTERV by fastforce
  ultimately show ?thesis
    using Taylor_up INTERV False by simp
qed

end


section \<open>Connecting Nondeterministic Büchi Automata to CAVA Automata Structures\<close>

theory NBA_Graphs
imports
  NBA
  CAVA_Automata.Automata_Impl
begin

  no_notation build (infixr "##" 65)

  subsection \<open>Regular Graphs\<close>

  definition nba_g :: "('label, 'state) nba \<Rightarrow> 'state graph_rec" where
    "nba_g A \<equiv> \<lparr> g_V = UNIV, g_E = E_of_succ (successors A), g_V0 = initial A \<rparr>"

  lemma nba_g_graph[simp]: "graph (nba_g A)" unfolding nba_g_def graph_def by simp

  lemma nba_g_V0: "g_V0 (nba_g A) = initial A" unfolding nba_g_def by simp
  lemma nba_g_E_rtrancl: "(g_E (nba_g A))\<^sup>* = {(p, q). q \<in> reachable A p}"
  unfolding nba_g_def graph_rec.simps E_of_succ_def
  proof safe
    show "(p, q) \<in> {(p, q). q \<in> successors A p}\<^sup>*" if "q \<in> reachable A p" for p q
      using that by (induct) (auto intro: rtrancl_into_rtrancl)
    show "q \<in> reachable A p" if "(p, q) \<in> {(p, q). q \<in> successors A p}\<^sup>*" for p q
      using that by induct auto
  qed

  lemma nba_g_rtrancl_path: "(g_E (nba_g A))\<^sup>* = {(p, target r p) |r p. NBA.path A r p}"
    unfolding nba_g_E_rtrancl by blast
  lemma nba_g_trancl_path: "(g_E (nba_g A))\<^sup>+ = {(p, target r p) |r p. NBA.path A r p \<and> r \<noteq> []}"
  unfolding nba_g_def graph_rec.simps E_of_succ_def
  proof safe
    show "\<exists> r p. (x, y) = (p, target r p) \<and> NBA.path A r p \<and> r \<noteq> []"
      if "(x, y) \<in> {(p, q). q \<in> successors A p}\<^sup>+" for x y
    using that
    proof induct
      case (base y)
      obtain a where 1: "a \<in> alphabet A" "y \<in> transition A a x" using base by auto
      show ?case
      proof (intro exI conjI)
        show "(x, y) = (x, target [(a, y)] x)" by simp
        show "NBA.path A [(a, y)] x" using 1 by auto
        show "[(a, y)] \<noteq> []" by simp
      qed
    next
      case (step y z)
      obtain r where 1: "y = target r x" "NBA.path A r x" "r \<noteq> []" using step(3) by auto
      obtain a where 2: "a \<in> alphabet A" "z \<in> transition A a y" using step(2) by auto
      show ?case
      proof (intro exI conjI)
        show "(x, z) = (x, target (r @ [(a, z)]) x)" by simp
        show "NBA.path A (r @ [(a, z)]) x" using 1 2 by auto
        show "r @ [(a, z)] \<noteq> []" by simp
      qed
    qed
    show "(p, target r p) \<in> {(u, v). v \<in> successors A u}\<^sup>+" if "NBA.path A r p" "r \<noteq> []" for r p
      using that by (induct) (fastforce intro: trancl_into_trancl2)+
  qed

  lemma nba_g_ipath_run:
    assumes "ipath (g_E (nba_g A)) r"
    obtains w
    where "run A (w ||| smap (r \<circ> Suc) nats) (r 0)"
  proof -
    have 1: "\<exists> a \<in> alphabet A. r (Suc i) \<in> transition A a (r i)" for i
      using assms unfolding ipath_def nba_g_def E_of_succ_def by auto
    obtain wr where 2: "run A wr (r 0)" "\<And> i. target (stake i wr) (r 0) = r i"
    proof (rule nba.invariant_run_index)
      show "\<exists> aq. (fst aq \<in> alphabet A \<and> snd aq \<in> transition A (fst aq) p) \<and> snd aq = r (Suc i) \<and> True"
        if "p = r i" for i p using that 1 by auto
      show "r 0 = r 0" by rule
    qed auto
    have 3: "smap (r \<circ> Suc) nats = smap snd wr"
    proof (rule eqI_snth)
      fix i
      have "smap (r \<circ> Suc) nats !! i = r (Suc i)" by simp
      also have "\<dots> = target (stake (Suc i) wr) (r 0)" unfolding 2(2) by rule
      also have "\<dots> = (r 0 ## trace wr (r 0)) !! Suc i" by simp
      also have "\<dots> = smap snd wr !! i" unfolding nba.trace_alt_def by simp
      finally show "smap (r \<circ> Suc) nats !! i = smap snd wr !! i" by this
    qed
    show ?thesis
    proof
      show "run A (smap fst wr ||| smap (r \<circ> Suc) nats) (r 0)" using 2(1) unfolding 3 by auto
    qed
  qed
  lemma nba_g_run_ipath:
    assumes "run A (w ||| r) p"
    shows "ipath (g_E (nba_g A)) (snth (p ## r))"
  proof
    fix i
    have 1: "w !! i \<in> alphabet A" "r !! i \<in> transition A (w !! i) (target (stake i (w ||| r)) p)"
      using assms by (auto dest: nba.run_snth)
    have 2: "r !! i \<in> successors A ((p ## r) !! i)"
      using 1 unfolding sscan_scons_snth[symmetric] nba.trace_alt_def by auto
    show "((p ## r) !! i, (p ## r) !! Suc i) \<in> g_E (nba_g A)"
      using 2 unfolding nba_g_def graph_rec.simps E_of_succ_def by simp
  qed

  subsection \<open>Indexed Generalized Büchi Graphs\<close>

  definition nba_igbg :: "('label, 'state) nba \<Rightarrow> 'state igb_graph_rec" where
    "nba_igbg A \<equiv> graph_rec.extend (nba_g A)
      \<lparr> igbg_num_acc = 1, igbg_acc = \<lambda> p. if accepting A p then {0} else {} \<rparr>"

  lemma acc_run_language:
    assumes "igb_graph (nba_igbg A)"
    shows "Ex (igb_graph.is_acc_run (nba_igbg A)) \<longleftrightarrow> language A \<noteq> {}"
  proof
    interpret igb_graph "nba_igbg A" using assms by this
    have [simp]: "V0 = g_V0 (nba_g A)" "E = g_E (nba_g A)"
      "num_acc = 1" "0 \<in> acc p \<longleftrightarrow> accepting A p" for p
      unfolding nba_igbg_def graph_rec.defs by simp+
    show "language A \<noteq> {}" if run: "Ex is_acc_run"
    proof -
      obtain r where 1: "is_acc_run r" using run by rule
      have 2: "r 0 \<in> V0" "ipath E r" "is_acc r"
        using 1 unfolding is_acc_run_def graph_defs.is_run_def by auto
      obtain w where 3: "run A (w ||| smap (r \<circ> Suc) nats) (r 0)" using nba_g_ipath_run 2(2) by auto
      have 4: "r 0 ## smap (r \<circ> Suc) nats = smap r nats" by (simp) (metis stream.map_comp smap_siterate)
      have 5: "infs (accepting A) (r 0 ## smap (r \<circ> Suc) nats)"
        using 2(3) unfolding infs_infm is_acc_def 4 by simp
      have "w \<in> language A"
      proof
        show "r 0 \<in> initial A" using nba_g_V0 2(1) by force
        show "run A (w ||| smap (r \<circ> Suc) nats) (r 0)" using 3 by this
        show "infs (accepting A) (r 0 ## smap (r \<circ> Suc) nats)" using 5 by simp
      qed
      then show ?thesis by auto
    qed
    show "Ex is_acc_run" if language: "language A \<noteq> {}"
    proof -
      obtain w where 1: "w \<in> language A" using language by auto
      obtain r p where 2: "p \<in> initial A" "run A (w ||| r) p" "infs (accepting A) (p ## r)" using 1 by rule
      have 3: "infs (accepting A) (p ## r)" using 2(3) by simp
      have "is_acc_run (snth (p ## r))"
      unfolding is_acc_run_def graph_defs.is_run_def
      proof safe
        show "(p ## r) !! 0 \<in> V0" using nba_g_V0 2(1) by force
        show "ipath E (snth (p ## r))" using nba_g_run_ipath 2(2) by force
        show "is_acc (snth (p ## r))" using 3 unfolding infs_infm is_acc_def by simp
      qed
      then show ?thesis by auto
    qed
  qed

end


theory Chapter12_5
imports "HOL-IMP.Hoare_Total"
begin

text\<open>
\exercise
Prove total correctness of the commands in exercises~\ref{exe:Hoare:sumeq} to
\ref{exe:Hoare:sqrt}.
\<close>

text\<open>
\endexercise

\exercise
Modify the VCG to take termination into account. First modify type \<open>acom\<close>
by annotating  \<open>WHILE\<close> with a measure function in addition to an
invariant:
\<close>
datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn "state \<Rightarrow> nat" bexp acom
    ("({_, _}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_,_} WHILE b DO C) = (WHILE b DO strip C)"

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I,f} WHILE b DO C) Q = I"

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
(* your definition/proof here *)

text\<open>
Functions @{const strip} and @{const pre} remain almost unchanged.
The only significant change is in the \<open>WHILE\<close> case for @{const vc}.
Modify the old soundness proof to obtain
\<close>

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
(* your definition/proof here *)

text\<open>
You may need the combined soundness and completeness of \<open>\<turnstile>\<^sub>t\<close>:
@{thm hoaret_sc}
\endexercise
\<close>

end


(* Author: Dmitriy Traytel, ported by Tobias Nipkow *)

header {* Finiteness of Derivatives Modulo ACI *}

(*<*)
(* split into Norm and Fin theories *)
theory Derivatives_Finite
imports "../Regular-Sets/Derivatives"
begin
(*>*)

text {* Lifting constructors to lists *}

fun rexp_of_list where
  "rexp_of_list OP N [] = N"
| "rexp_of_list OP N [r] = r"
| "rexp_of_list OP N (r # rs) = OP r (rexp_of_list OP N rs)"

abbreviation "PLUS \<equiv> rexp_of_list Plus Zero"
abbreviation "TIMES \<equiv> rexp_of_list Times One"

lemma list_singleton_induct [case_names nil single cons]:
assumes "P []" and "\<And>x. P [x]" and "\<And>x y xs. P (y # xs) \<Longrightarrow> P (x # (y # xs))"
shows "P xs"
using assms by induction_schema (pat_completeness, lexicographic_order)

subsection {* ACI normalization *}

fun toplevel_summands :: "'a rexp \<Rightarrow> 'a rexp set" where
  "toplevel_summands (Plus r s) = toplevel_summands r \<union> toplevel_summands s"
| "toplevel_summands r = {r}"

abbreviation "flatten LISTOP X \<equiv> LISTOP (sorted_list_of_set X)"

lemma toplevel_summands_nonempty[simp]:
  "toplevel_summands r \<noteq> {}"
  by (induct r) auto

lemma toplevel_summands_finite[simp]:
  "finite (toplevel_summands r)"
  by (induct r) auto

primrec ACI_norm :: "('a::linorder) rexp \<Rightarrow> 'a rexp"  ("\<guillemotleft>_\<guillemotright>") where
  "\<guillemotleft>Zero\<guillemotright> = Zero"
| "\<guillemotleft>One\<guillemotright> = One"
| "\<guillemotleft>Atom a\<guillemotright> = Atom a"
| "\<guillemotleft>Plus r s\<guillemotright> = flatten PLUS (toplevel_summands (Plus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>))"
| "\<guillemotleft>Times r s\<guillemotright> = Times \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
| "\<guillemotleft>Star r\<guillemotright> = Star \<guillemotleft>r\<guillemotright>"

lemma Plus_toplevel_summands: "Plus r s \<in> toplevel_summands t \<Longrightarrow> False"
by (induction t) auto

lemma toplevel_summands_not_Plus[simp]:
  "(\<forall>r s. x \<noteq> Plus r s) \<Longrightarrow> toplevel_summands x = {x}"
by (induction x) auto

lemma toplevel_summands_PLUS_strong:
  "\<lbrakk>xs \<noteq> []; list_all (\<lambda>x. \<not>(\<exists>r s. x = Plus r s)) xs\<rbrakk> \<Longrightarrow> toplevel_summands (PLUS xs) = set xs"
  by (induct xs rule: list_singleton_induct) auto

lemma toplevel_summands_flatten:
  "\<lbrakk>X \<noteq> {}; finite X; \<forall>x \<in> X. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow> toplevel_summands (flatten PLUS X) = X"
  using toplevel_summands_PLUS_strong[of "sorted_list_of_set X"] sorted_list_of_set[of X]
  unfolding list_all_iff by fastforce

lemma ACI_norm_Plus: "\<guillemotleft>r\<guillemotright> = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
by (induction r) auto

lemma toplevel_summands_flatten_ACI_norm_image:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r)) = ACI_norm ` toplevel_summands r"
by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus intro: Plus_toplevel_summands)

lemma toplevel_summands_flatten_ACI_norm_image_Union:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s)) =
    ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s"
by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus[OF sym] intro: Plus_toplevel_summands)

lemma toplevel_summands_ACI_norm:
  "toplevel_summands \<guillemotleft>r\<guillemotright> = ACI_norm ` toplevel_summands r"
by (induction r) (auto simp: toplevel_summands_flatten_ACI_norm_image_Union)

lemma ACI_norm_flatten:
  "\<guillemotleft>r\<guillemotright> = flatten PLUS (ACI_norm ` toplevel_summands r)"
by (induction r) (auto simp: image_Un toplevel_summands_flatten_ACI_norm_image)

theorem ACI_norm_idem[simp]: "\<guillemotleft>\<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induct r)
  case (Plus r s)
  have "\<guillemotleft>\<guillemotleft>Plus r s\<guillemotright>\<guillemotright> = \<guillemotleft>flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)\<guillemotright>"
    (is "_ = \<guillemotleft>flatten PLUS ?U\<guillemotright>") by simp
  also have "\<dots> = flatten PLUS (ACI_norm ` toplevel_summands (flatten PLUS ?U))"
    unfolding ACI_norm_flatten ..
  also have "toplevel_summands (flatten PLUS ?U) = ?U"
    by (intro toplevel_summands_flatten) (auto intro: Plus_toplevel_summands)
  also have "flatten PLUS (ACI_norm ` ?U) = flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)"
    unfolding image_Un toplevel_summands_ACI_norm[symmetric] Plus ..
  finally show ?case by simp
qed auto

subsection "Atoms"

lemma atoms_toplevel_summands:
  "atoms s = (\<Union>r\<in>toplevel_summands s. atoms r)"
by (induct s) auto

lemma wf_PLUS: "atoms (PLUS xs) \<subseteq> \<Sigma> \<longleftrightarrow> (\<forall>r \<in> set xs. atoms r \<subseteq> \<Sigma>)"
by (induct xs rule: list_singleton_induct) auto

lemma atoms_PLUS: "atoms (PLUS xs) = (\<Union>r \<in> set xs. atoms r)"
by (induct xs rule: list_singleton_induct) auto

lemma atoms_flatten_PLUS:
  "finite X \<Longrightarrow> atoms (flatten PLUS X) = (\<Union>r \<in> X. atoms r)"
using wf_PLUS[of "sorted_list_of_set X"] sorted_list_of_set[of X] by auto

theorem atoms_ACI_norm: "atoms \<guillemotleft>r\<guillemotright> = atoms r"
proof (induct r)
  case (Plus r1 r2) thus ?case
   using atoms_toplevel_summands[of "\<guillemotleft>r1\<guillemotright>"] atoms_toplevel_summands[of "\<guillemotleft>r2\<guillemotright>"]
   by(simp add: atoms_flatten_PLUS ball_Un Un_commute)
qed auto

subsection "Language"

lemma toplevel_summands_lang: "r \<in> toplevel_summands s \<Longrightarrow> lang r \<subseteq> lang s"
by (induct s) auto

lemma toplevel_summands_lang_UN:
  "lang s = (\<Union>r\<in>toplevel_summands s. lang r)"
by (induct s) auto

lemma toplevel_summands_in_lang:
  "w \<in> lang s = (\<exists>r\<in>toplevel_summands s. w \<in> lang r)"
by (induct s) auto

lemma lang_PLUS: "lang (PLUS xs) = (\<Union>r \<in> set xs. lang r)"
by (induct xs rule: list_singleton_induct) auto

lemma lang_PLUS_map[simp]:
  "lang (PLUS (map f xs)) = (\<Union>a\<in>set xs. lang (f a))"
by (induct xs rule: list_singleton_induct) auto

lemma lang_flatten_PLUS[simp]:
  "finite X \<Longrightarrow> lang (flatten PLUS X) = (\<Union>r \<in> X. lang r)"
using lang_PLUS[of "sorted_list_of_set X"] sorted_list_of_set[of X] by fastforce

theorem lang_ACI_norm[simp]: "lang \<guillemotleft>r\<guillemotright> = lang r"
proof (induct r)
  case (Plus r1 r2)
  moreover
  from Plus[symmetric] have "lang (Plus r1 r2) \<subseteq> lang \<guillemotleft>Plus r1 r2\<guillemotright>"
    using toplevel_summands_in_lang[of _ "\<guillemotleft>r1\<guillemotright>"] toplevel_summands_in_lang[of _ "\<guillemotleft>r2\<guillemotright>"]
    by auto
  ultimately show ?case by (fastforce dest!: toplevel_summands_lang)
qed auto

subsection {* Finiteness of ACI-Equivalent Derivatives *}

lemma toplevel_summands_deriv:
  "toplevel_summands (deriv as r) = (\<Union>s\<in>toplevel_summands r. toplevel_summands (deriv as s))"
by (induction r) (auto simp: Let_def)

lemma derivs_Zero[simp]: "derivs xs Zero = Zero"
by (induction xs) auto

lemma derivs_One: "derivs xs One \<in> {Zero, One}"
by (induction xs) auto

lemma derivs_Atom: "derivs xs (Atom as) \<in> {Zero, One, Atom as}"
proof (induction xs)
  case Cons thus ?case by (auto intro: insertE[OF derivs_One])
qed simp

lemma derivs_Plus: "derivs xs (Plus r s) = Plus (derivs xs r) (derivs xs s)"
by (induction xs arbitrary: r s) auto

lemma derivs_PLUS: "derivs xs (PLUS ys) = PLUS (map (derivs xs) ys)"
by (induction ys rule: list_singleton_induct) (auto simp: derivs_Plus)

lemma toplevel_summands_derivs_Times: "toplevel_summands (derivs xs (Times r s)) \<subseteq>
  {Times (derivs xs r) s} \<union>
  {r'. \<exists>ys zs. r' \<in> toplevel_summands (derivs ys s) \<and> ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induction xs arbitrary: r s)
  case (Cons x xs)
  thus ?case by (auto simp: Let_def derivs_Plus) (fastforce intro: exI[of _ "x#xs"])+
qed simp

lemma toplevel_summands_derivs_Star_nonempty:
  "xs \<noteq> [] \<Longrightarrow> toplevel_summands (derivs xs (Star r)) \<subseteq>
    {Times (derivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induction xs rule: length_induct)
  case (1 xs)
  then obtain y ys where "xs = y # ys" by (cases xs) auto
  thus ?case using spec[OF 1(1)]
    by (auto dest!: subsetD[OF toplevel_summands_derivs_Times] intro: exI[of _ "y#ys"])
       (auto elim!: impE dest!: meta_spec subsetD)
qed

lemma toplevel_summands_derivs_Star:
  "toplevel_summands (derivs xs (Star r)) \<subseteq>
    {Star r} \<union> {Times (derivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
by (cases "xs = []") (auto dest!: toplevel_summands_derivs_Star_nonempty)

lemma toplevel_summands_PLUS:
 "xs \<noteq> [] \<Longrightarrow> toplevel_summands (PLUS (map f xs)) = (\<Union>r \<in> set xs. toplevel_summands (f r))"
by (induction xs rule: list_singleton_induct) simp_all

lemma ACI_norm_toplevel_summands_Zero: "toplevel_summands r \<subseteq> {Zero} \<Longrightarrow> \<guillemotleft>r\<guillemotright> = Zero"
by (subst ACI_norm_flatten) (auto dest: subset_singletonD)

lemma finite_ACI_norm_toplevel_summands:
  "finite B \<Longrightarrow> finite {f \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> B}"
by (elim finite_surj[OF iffD2[OF finite_Pow_iff], of _ _ "f o flatten PLUS o image ACI_norm"])
   (auto simp: Pow_def image_Collect ACI_norm_flatten)

theorem finite_derivs: "finite {\<guillemotleft>derivs xs r\<guillemotright> | xs . True}"
proof (induct r)
  case Zero show ?case by simp
next
  case One show ?case
   by (rule finite_surj[of "{Zero, One}"]) (blast intro: insertE[OF derivs_One])+
next
  case (Atom as) show ?case
    by (rule finite_surj[of "{Zero, One, Atom as}"]) (blast intro: insertE[OF derivs_Atom])+
next
  case (Plus r s)
  show ?case by (auto simp: derivs_Plus intro!: finite_surj[OF finite_cartesian_product[OF Plus]])
next
  case (Times r s)
  hence "finite (\<Union> (toplevel_summands ` {\<guillemotleft>derivs xs s\<guillemotright> | xs . True}))" by auto
  moreover have "{\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (derivs ys s)} =
    {r'. \<exists>ys. r' \<in> toplevel_summands \<guillemotleft>derivs ys s\<guillemotright>}"
    unfolding toplevel_summands_ACI_norm by auto
  ultimately have fin: "finite {\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (derivs ys s)}"
    by (fastforce intro: finite_subset[of _ "\<Union> (toplevel_summands ` {\<guillemotleft>derivs xs s\<guillemotright> | xs . True})"])
  let ?X = "\<lambda>xs. {Times (derivs ys r) s | ys. True} \<union> {r'. r' \<in> (\<Union>ys. toplevel_summands (derivs ys s))}"
  show ?case unfolding ACI_norm_flatten
  proof (rule finite_surj[of "{X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}" _ "flatten PLUS"])
    show "finite {X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}"
      using fin by (fastforce simp: image_Un elim: finite_subset[rotated] intro: finite_surj[OF Times(1), of _ "\<lambda>r. Times r \<guillemotleft>s\<guillemotright>"])
  qed (fastforce dest!: subsetD[OF toplevel_summands_derivs_Times] intro!: imageI)
next
  case (Star r)
  let ?f = "\<lambda>f r'. Times r' (Star (f r))"
  let ?X = "{Star r} \<union> ?f id ` {r'. r' \<in> {derivs ys r|ys. True}}"
  show ?case unfolding ACI_norm_flatten
  proof (rule finite_surj[of "{X. X \<subseteq> ACI_norm ` ?X}" _ "flatten PLUS"])
    have *: "\<And>X. ACI_norm ` ?f (\<lambda>x. x) ` X = ?f ACI_norm ` ACI_norm ` X" by (auto simp: image_def)
    show "finite {X. X \<subseteq> ACI_norm ` ?X}"
      by (rule finite_Collect_subsets)
         (auto simp: * intro!: finite_imageI[of _ "?f ACI_norm"] intro: finite_subset[OF _ Star])
  qed (fastforce dest!: subsetD[OF toplevel_summands_derivs_Star] intro!: imageI)
qed

subsection {* Deriving preserves ACI-equivalence *}

lemma ACI_norm_PLUS:
  "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>) xs ys \<Longrightarrow> \<guillemotleft>PLUS xs\<guillemotright> = \<guillemotleft>PLUS ys\<guillemotright>"
proof (induct rule: list_all2_induct)
  case (Cons x xs y ys)
  hence "length xs = length ys" by (elim list_all2_lengthD)
  thus ?case using Cons by (induct xs ys rule: list_induct2) auto
qed simp

lemma toplevel_summands_ACI_norm_deriv:
  "(\<Union>a\<in>toplevel_summands r. toplevel_summands \<guillemotleft>deriv as \<guillemotleft>a\<guillemotright>\<guillemotright>) = toplevel_summands \<guillemotleft>deriv as \<guillemotleft>r\<guillemotright>\<guillemotright>"
proof (induct r)
  case (Plus r1 r2) thus ?case
   unfolding toplevel_summands.simps toplevel_summands_ACI_norm
     toplevel_summands_deriv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] SUP_def image_Un Union_Un_distrib
   by (simp add: image_UN)
qed (auto simp: Let_def)

lemma toplevel_summands_nullable:
  "nullable s = (\<exists>r\<in>toplevel_summands s. nullable r)"
by (induction s) auto

lemma nullable_PLUS:
  "nullable (PLUS xs) = (\<exists>r \<in> set xs. nullable r)"
by (induction xs rule: list_singleton_induct) auto

theorem ACI_norm_deriv: "\<guillemotleft>deriv as \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>deriv as r\<guillemotright>"
proof (induction r arbitrary: as)
  case (Plus r1 r2) thus ?case
   unfolding deriv.simps ACI_norm_flatten[of "deriv as \<guillemotleft>Plus r1 r2\<guillemotright>"]
     toplevel_summands_deriv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un image_UN
   by (auto simp: toplevel_summands_ACI_norm toplevel_summands_flatten_ACI_norm_image_Union)
     (auto simp: toplevel_summands_ACI_norm[symmetric] toplevel_summands_ACI_norm_deriv)
qed (simp_all add: ACI_norm_nullable)

corollary deriv_preserves: "\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright> \<Longrightarrow> \<guillemotleft>deriv as r\<guillemotright> = \<guillemotleft>deriv as s\<guillemotright>"
  by (rule box_equals[OF _ ACI_norm_deriv ACI_norm_deriv]) (erule arg_cong)

lemma derivs_snoc[simp]: "derivs (xs @ [x]) r = (deriv x (derivs xs r))"
by (induction xs arbitrary: r) auto

theorem ACI_norm_derivs: "\<guillemotleft>derivs xs \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>derivs xs r\<guillemotright>"
proof (induction xs arbitrary: r rule: rev_induct)
  case (snoc x xs) thus ?case
    using ACI_norm_deriv[of x "derivs xs r"] ACI_norm_deriv[of x "derivs xs \<guillemotleft>r\<guillemotright>"] by auto
qed simp

subsection {* Alternative ACI defintions *}

text {* Not necessary but conceptually nicer (and seems also to be faster?!) *}

fun ACI_nPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "ACI_nPlus (Plus r1 r2) s = ACI_nPlus r1 (ACI_nPlus r2 s)"
| "ACI_nPlus r (Plus s1 s2) =
  (if r = s1 then Plus s1 s2
  else if r < s1 then Plus r (Plus s1 s2)
  else Plus s1 (ACI_nPlus r s2))"
| "ACI_nPlus r s =
  (if r = s then r
  else if r < s then Plus r s
  else Plus s r)"

primrec ACI_norm_alt where
  "ACI_norm_alt Zero = Zero"
| "ACI_norm_alt One = One"
| "ACI_norm_alt (Atom a) = Atom a"
| "ACI_norm_alt (Plus r s) = ACI_nPlus (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Times r s) = Times (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Star r) = Star (ACI_norm_alt r)"

lemma toplevel_summands_ACI_nPlus:
  "toplevel_summands (ACI_nPlus r s) = toplevel_summands (Plus r s)"
  by (induct r s rule: ACI_nPlus.induct) auto

lemma toplevel_summands_ACI_norm_alt:
  "toplevel_summands (ACI_norm_alt r) = ACI_norm_alt ` toplevel_summands r"
  by (induct r) (auto simp: toplevel_summands_ACI_nPlus)

lemma ACI_norm_alt_Plus:
  "ACI_norm_alt r = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
  by (induct r) auto

lemma toplevel_summands_flatten_ACI_norm_alt_image:
  "toplevel_summands (flatten PLUS (ACI_norm_alt ` toplevel_summands r)) = ACI_norm_alt ` toplevel_summands r"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_alt_Plus intro: Plus_toplevel_summands)

lemma ACI_norm_ACI_norm_alt: "\<guillemotleft>ACI_norm_alt r\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induction r)
  case (Plus r s) show ?case
    by (auto simp: ACI_norm_flatten image_Un toplevel_summands_ACI_nPlus)
       (metis Plus.IH toplevel_summands_ACI_norm)
qed auto

lemma ACI_nPlus_singleton_PLUS:
  "\<lbrakk>xs \<noteq> []; sorted xs; distinct xs; \<forall>x \<in> {x} \<union> set xs. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow>
  ACI_nPlus x (PLUS xs) = (if x \<in> set xs then PLUS xs else PLUS (insort x xs))"
proof (induct xs rule: list_singleton_induct)
  case (single y)
  thus ?case
    by (cases x y rule: linorder_cases) (induct x y rule: ACI_nPlus.induct, auto)+
next
  case (cons y1 y2 ys) thus ?case by (cases x) (auto simp: sorted_Cons)
qed simp

lemma ACI_nPlus_PLUS:
  "\<lbrakk>xs1 \<noteq> []; xs2 \<noteq> []; \<forall>x \<in> set (xs1 @ xs2). \<not>(\<exists>r s. x = Plus r s); sorted xs2; distinct xs2\<rbrakk>\<Longrightarrow>
  ACI_nPlus (PLUS xs1) (PLUS xs2) = flatten PLUS (set (xs1 @ xs2))"
proof (induct xs1 arbitrary: xs2 rule: list_singleton_induct)
  case (single x1)
  thus ?case
    apply (auto intro!: trans[OF ACI_nPlus_singleton_PLUS] simp del: sorted_list_of_set_insert)
    apply fastforce
    apply (simp only: insert_absorb)
    apply (metis List.finite_set finite_sorted_distinct_unique sorted_list_of_set)
    apply (rule arg_cong[of _ _ PLUS])
    apply (metis remdups_id_iff_distinct sorted_list_of_set_sort_remdups sorted_sort_id)
    done
next
  case (cons x11 x12 xs1) thus ?case
  apply (simp del: sorted_list_of_set_insert)
  apply (rule trans[OF ACI_nPlus_singleton_PLUS])
  apply (auto simp del: sorted_list_of_set_insert simp add: insert_commute[of x11])
  apply (auto simp only: Un_insert_left[of x11, symmetric] insert_absorb) []
  apply (auto simp only: Un_insert_right[of _ x11, symmetric] insert_absorb) []
  apply (auto simp add: insert_commute[of x12])
  done
qed simp

lemma ACI_nPlus_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; X2 \<noteq> {}; finite X1; finite X2; \<forall>x \<in> X1 \<union> X2. \<not>(\<exists>r s. x = Plus r s)\<rbrakk>\<Longrightarrow>
  ACI_nPlus (flatten PLUS X1) (flatten PLUS X2) = flatten PLUS (X1 \<union> X2)"
  by (rule trans[OF ACI_nPlus_PLUS]) auto

lemma ACI_nPlus_ACI_norm[simp]: "ACI_nPlus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright> = \<guillemotleft>Plus r s\<guillemotright>"
  by (auto simp: image_Un Un_assoc ACI_norm_flatten intro!: trans[OF ACI_nPlus_flatten_PLUS])
   (metis ACI_norm_Plus Plus_toplevel_summands ACI_norm_flatten)+

lemma ACI_norm_alt:
  "ACI_norm_alt r = \<guillemotleft>r\<guillemotright>"
  by (induct r) auto

declare ACI_norm_alt[symmetric, code]

inductive ACI where
  ACI_refl:       "ACI r r" |
  ACI_sym:        "ACI r s \<Longrightarrow> ACI s r" |
  ACI_trans:      "ACI r s \<Longrightarrow> ACI s t \<Longrightarrow> ACI r t" |
  ACI_Plus_cong:  "\<lbrakk>ACI r1 s1; ACI r2 s2\<rbrakk> \<Longrightarrow> ACI (Plus r1 r2) (Plus s1 s2)" |
  ACI_Times_cong: "\<lbrakk>ACI r1 s1; ACI r2 s2\<rbrakk> \<Longrightarrow> ACI (Times r1 r2) (Times s1 s2)" |
  ACI_Star_cong:  "ACI r s \<Longrightarrow> ACI (Star r) (Star s)" |
  ACI_assoc:      "ACI (Plus (Plus r s) t) (Plus r (Plus s t))" |
  ACI_comm:       "ACI (Plus r s) (Plus s r)" |
  ACI_idem:       "ACI (Plus r r) r"

lemma ACI_nullable: "ACI r s \<Longrightarrow> nullable r = nullable s"
  by (induct rule: ACI.induct) auto

lemma ACI_lang: "ACI r s \<Longrightarrow> lang r = lang s"
  by (induct rule: ACI.induct) auto

lemma ACI_deriv: "ACI r s \<Longrightarrow> ACI (deriv a r) (deriv a s)"
proof (induct arbitrary: a rule: ACI.induct)
  case (ACI_Times_cong r1 s1 r2 s2) thus ?case
    by (auto simp: Let_def intro: ACI.intros dest: ACI_nullable)
      (metis ACI.ACI_Times_cong ACI_Plus_cong)
qed (auto intro: ACI.intros)

lemma ACI_Plus_assocI[intro]:
  "ACI (Plus r1 r2) s2 \<Longrightarrow> ACI (Plus r1 (Plus s1 r2)) (Plus s1 s2)"
  "ACI (Plus r1 r2) s2 \<Longrightarrow> ACI (Plus r1 (Plus r2 s1)) (Plus s1 s2)"
  by (metis ACI_assoc ACI_comm ACI_Plus_cong ACI_refl ACI_trans)+

lemma ACI_Plus_idemI[intro]: "\<lbrakk>ACI r s1; ACI r s2\<rbrakk> \<Longrightarrow> ACI r (Plus s1 s2)"
  by (metis ACI_Plus_cong ACI_idem ACI_sym ACI_trans)

lemma ACI_Plus_idemI'[intro]:
  "\<lbrakk>ACI r1 s1; ACI (Plus r1 r2) s2\<rbrakk> \<Longrightarrow> ACI (Plus r1 r2) (Plus s1 s2)"
  by (rule ACI_trans[OF ACI_Plus_cong[OF ACI_sym[OF ACI_idem] ACI_refl]
             ACI_trans[OF ACI_assoc ACI_trans[OF ACI_Plus_cong ACI_refl]]])

lemma ACI_ACI_nPlus: "\<lbrakk>ACI r1 s1; ACI r2 s2\<rbrakk> \<Longrightarrow> ACI (ACI_nPlus r1 r2) (Plus s1 s2)"
proof (induct r1 r2 arbitrary: s1 s2 rule: ACI_nPlus.induct)
  case 1
  from 1(2)[OF ACI_refl 1(1)[OF ACI_refl 1(4)]] 1(3) show ?case by (auto intro: ACI_comm ACI_trans)
next
  case ("2_1" r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_1"(1)[OF _ _ "2_1"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_2" r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_2"(1)[OF _ _ "2_2"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_3" _ r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_3"(1)[OF _ _ "2_3"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_4" _ _ r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_4"(1)[OF _ _ "2_4"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
next
  case ("2_5" _ r1 r2)
  with ACI_Plus_cong[OF ACI_refl "2_5"(1)[OF _ _ "2_5"(2) ACI_refl], of r1]
    show ?case by (auto intro: ACI.intros)
qed (auto intro: ACI.intros)

lemma ACI_ACI_norm: "ACI \<guillemotleft>r\<guillemotright> r"
  unfolding ACI_norm_alt[symmetric]
  by (induct r) (auto intro: ACI.intros simp: ACI_ACI_nPlus)

lemma ACI_norm_eqI: "ACI r s \<Longrightarrow> \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>"
  by (induct rule: ACI.induct) (auto simp: toplevel_summands_ACI_norm ACI_norm_flatten[symmetric]
    toplevel_summands_flatten_ACI_norm_image_Union ac_simps)

lemma ACI_I: "\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright> \<Longrightarrow> ACI r s"
  by (metis ACI_ACI_norm ACI_sym ACI_trans)

lemma ACI_decidable: "ACI r s = (\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>)"
  by (metis ACI_I ACI_norm_eqI)

(*<*)
end
(*>*)


theory HochsteinLamport
  imports "./TLA-Utils"
begin

(* see https://lorinhochstein.wordpress.com/2018/12/27/inductive-invariants/ *)

datatype Pc = Start | SetX | Finish

locale Algorithm =
  fixes N :: nat
  assumes Npos: "0 < N"
  fixes pc :: "(nat \<Rightarrow> Pc) stfun"
  fixes x :: "(nat \<Rightarrow> nat) stfun"
  fixes y :: "(nat \<Rightarrow> nat) stfun"
  assumes bvs: "basevars (pc,x,y)"
  fixes Initial :: stpred
  defines "Initial \<equiv> PRED (\<forall>n. id<pc,#n> = #Start)"
  fixes Step1 :: "nat \<Rightarrow> action"
  defines "Step1 n \<equiv> ACT (#n < #N
    \<and> id<$pc,#n> = #Start \<and> id<pc$,#n> = #SetX
    \<and> id<x$,#n> = #1
    \<and> (\<forall>n'. #n' \<noteq> #n \<longrightarrow> id<pc$,#n'> = id<$pc,#n'>)
    \<and> (\<forall>n'. #n' \<noteq> #n \<longrightarrow> id< x$,#n'> = id<$x ,#n'>)
    \<and> unchanged y)"
  fixes Step2 :: "nat \<Rightarrow> nat \<Rightarrow> action"
  defines "Step2 n j \<equiv> ACT (#n < #N \<and> #j < #N
    \<and> id<$pc,#n> = #SetX \<and> id<pc$,#n> = #Finish
    \<and> id<y$,#n> = id<$x,#j>
    \<and> (\<forall>n'. #n' \<noteq> #n \<longrightarrow> id<pc$,#n'> = id<$pc,#n'>)
    \<and> unchanged x
    \<and> (\<forall>n'. #n' \<noteq> #n \<longrightarrow> id<y$,#n'> = id<$y,#n'>))"
  fixes Step :: action
  defines "Step \<equiv> ACT (\<exists> n. Step1 n \<or> (\<exists> j. Step2 n j))"
  fixes Spec :: temporal
  defines "Spec \<equiv> TEMP (Init Initial \<and> \<box>[Step]_(pc,x,y) \<and> WF(Step)_(pc,x,y))"

context Algorithm
begin

definition xSet :: "nat set stfun" where "xSet s \<equiv> { n. pc s n \<noteq> Start }"
definition ySet :: "nat set stfun" where "ySet s \<equiv> { n. pc s n = Finish }"

lemma Step_cases[consumes 1, case_names unchanged Step1 Step2]:
  assumes sq_Step: "(s,t) \<Turnstile> [Step]_(pc,x,y)"
  assumes unchanged: "\<lbrakk> x t = x s; y t = y s; pc t = pc s; xSet t = xSet s; ySet t = ySet s \<rbrakk> \<Longrightarrow> P"
  assumes Step1: "\<And>n.   \<lbrakk> n < N;        pc s n = Start; pc t n = SetX;   x t n = 1;     \<forall> n'. n' \<noteq> n \<longrightarrow> pc t n' = pc s n'; \<forall> n'. n' \<noteq> n \<longrightarrow> x t n' = x s n'; y t = y s; xSet t = insert n (xSet s); ySet t = ySet s \<rbrakk> \<Longrightarrow> P"
  assumes Step2: "\<And>n j. \<lbrakk> n < N; j < N; pc s n = SetX;  pc t n = Finish; y t n = x s j; \<forall> n'. n' \<noteq> n \<longrightarrow> pc t n' = pc s n'; \<forall> n'. n' \<noteq> n \<longrightarrow> y t n' = y s n'; x t = x s; ySet t = insert n (ySet s); xSet t = xSet s \<rbrakk> \<Longrightarrow> P"
  shows P
proof -
  from sq_Step consider
    (unchanged_case) "(s,t) \<Turnstile> unchanged (pc,x,y)"
    | (Step1_case) "\<exists>n.   (s,t) \<Turnstile> Step1 n"
    | (Step2_case) "\<exists>n j. (s,t) \<Turnstile> Step2 n j"
    unfolding square_def Step_def by auto
  thus P
  proof cases
    case unchanged_case with unchanged show P unfolding xSet_def ySet_def by simp
  next
    case Step1_case
    then obtain n where st: "(s,t) \<Turnstile> Step1 n" ..
    thus P
      apply (intro Step1 [of n], auto simp add: Step1_def xSet_def ySet_def)
      using Pc.distinct by metis+
  next
    case Step2_case
    then obtain n j where st: "(s,t) \<Turnstile> Step2 n j" by blast
    thus P apply (intro Step2 [of n j], auto simp add: Step2_def xSet_def ySet_def)
      using Pc.distinct by metis+
  qed
qed

definition Safety :: stpred
  where "Safety s \<equiv> xSet s \<subseteq> {n. n < N}
                  \<and> ySet s \<subseteq> xSet s
                  \<and> (\<forall> n \<in> xSet s. x s n = 1)
                  \<and> (ySet s = {n. n < N} \<longrightarrow> (\<exists> n < N. y s n = 1))"

lemma Safety: "\<turnstile> Spec \<longrightarrow> \<box>Safety"
proof (intro invariantI)
  show "\<turnstile> Spec \<longrightarrow> Init Safety" using Npos by (auto simp add: Spec_def Safety_def Init_def Initial_def xSet_def ySet_def)
  show "\<turnstile> Spec \<longrightarrow> \<box>[Step]_(pc,x,y)" by (auto simp add: Spec_def)

  fix s t
  assume s_Safety: "s \<Turnstile> Safety"
  assume "(s,t) \<Turnstile> [Step]_(pc,x,y)"
  thus "t \<Turnstile> Safety"
  proof (cases rule: Step_cases)
    case unchanged with s_Safety show ?thesis unfolding Safety_def by simp
  next
    case (Step1 n)
    show ?thesis
      unfolding Safety_def
    proof (intro conjI impI exI)
      show "\<forall>n\<in>xSet t. x t n = 1" "xSet t \<subseteq> {n. n < N}" "ySet t \<subseteq> xSet t" "n < N"
        using s_Safety Step1 unfolding Safety_def by fastforce+

      from Step1 have "ySet s = ySet t" by simp
      also assume "ySet t = {n. n < N}"
      moreover from s_Safety have "ySet s \<subseteq> xSet s" unfolding Safety_def by simp
      moreover from s_Safety have "xSet s \<subseteq> {n. n < N}" unfolding Safety_def by simp
      ultimately have "xSet s = {n. n < N}" by auto
      with Step1 have "n \<in> xSet s" by (auto simp add: xSet_def)
      with Step1 have False by (simp add: xSet_def)
      thus "y t n = 1" by simp_all
    qed
  next
    case (Step2 n j)
    show ?thesis
      unfolding Safety_def
    proof (intro conjI impI exI)
      show "\<forall>n\<in>xSet t. x t n = 1" "xSet t \<subseteq> {n. n < N}" "ySet t \<subseteq> xSet t" "n < N"
        using s_Safety Step2 unfolding Safety_def xSet_def ySet_def by fastforce+

      assume "ySet t = {n. n < N}"
      with `ySet t \<subseteq> xSet t` `xSet t \<subseteq> {n. n < N}` have "xSet s = {n. n < N}" using Step2 by simp
      with Step2 s_Safety have "x s j = 1" unfolding Safety_def by auto
      with Step2 show "y t n = 1" by simp
    qed
  qed
qed

lemma angle_Step_eq: "(ACT <Step>_(pc, x, y)) = Step"
proof (intro ext iffI)
  fix st
  show "st \<Turnstile> <Step>_(pc,x,y) \<Longrightarrow> st \<Turnstile> Step" unfolding angle_def by auto

  assume Step: "st \<Turnstile> Step"
  obtain s t where st: "st = (s,t)" by fastforce

  have "(s,t) \<Turnstile> <Step>_(pc,x,y)"
    unfolding angle_def
  proof (intro temp_conjI)
    from Step st show "(s,t) \<Turnstile> Step" by simp
    thus "(s,t) \<Turnstile> \<not> unchanged (pc, x, y)"
      by (auto simp add: Step_def Step1_def Step2_def)
  qed
  thus "st \<Turnstile> <Step>_(pc,x,y)" by (simp add: st)
qed

lemma enabled_StepI:
  assumes "s \<Turnstile> Safety"
  assumes "ySet s \<noteq> {n. n < N}"
  shows "s \<Turnstile> Enabled Step"
proof -
  from assms obtain n where n: "n < N" "pc s n \<noteq> Finish" unfolding ySet_def Safety_def by auto
  thus ?thesis
  proof (cases "pc s n")
    case Start
    show ?thesis unfolding Step_def enabled_ex [temp_use] enabled_disj [temp_use]
    proof (intro exI [where x = n] disjI1, enabled bvs, intro exI allI impI, elim conjE)
      fix u
      assume
        "pc u = (\<lambda>m. if m = n then SetX else pc s m)"
        "x  u = (\<lambda>m. if m = n then 1    else x s m)"
        "y  u = y s"
      with n Start show "(s,u) \<Turnstile> Step1 n" by (auto simp add: Step1_def)
    qed
  next
    case SetX
    show ?thesis unfolding Step_def enabled_ex [temp_use] enabled_disj [temp_use]
    proof (intro exI [where x = n] disjI2, enabled bvs, intro exI allI impI, elim conjE)
      fix u
      assume
        "pc u = (\<lambda>m. if m = n then Finish else pc s m)"
        "y  u = (\<lambda>m. if m = n then x s n else y s m)"
        "x  u = x s"
      with n SetX show "(s,u) \<Turnstile> Step2 n n" by (auto simp add: Step2_def)
    qed
  qed simp
qed

lemma StepFair:
  assumes "\<turnstile> $P \<and> $Safety \<and> [Step]_(pc,x,y) \<longrightarrow> P$ \<or> Q$"
  assumes "\<turnstile> $P \<and> $Safety \<and>  Step        \<longrightarrow>      Q$"
  assumes "\<turnstile> $P \<and> $Safety \<and> [Step]_(pc,x,y) \<longrightarrow> $Enabled Step"
  shows "\<turnstile> Spec \<longrightarrow> (P \<leadsto> Q)"
proof -
  from Safety have "\<turnstile> Spec \<longrightarrow> \<box>([Step]_(pc,x,y) \<and> $Safety) \<and> WF(Step)_(pc,x,y)" by (auto simp add: Spec_def more_temp_simps)
  also have "\<turnstile> \<box>([Step]_(pc,x,y) \<and> $Safety) \<and> WF(Step)_(pc,x,y) \<longrightarrow> (P \<leadsto> Q)"
    using assms angle_Step_eq by (intro WF1, auto)
  finally show ?thesis .
qed

lemma StepFair_action:
  assumes "\<And>s t. \<lbrakk> s \<Turnstile> P; s \<Turnstile> Safety; (s,t) \<Turnstile> [Step]_(pc,x,y) \<rbrakk> \<Longrightarrow> t \<Turnstile> P \<or> Q"
  assumes "\<And>s t. \<lbrakk> s \<Turnstile> P; s \<Turnstile> Safety; (s,t) \<Turnstile>  Step           \<rbrakk> \<Longrightarrow> t \<Turnstile>     Q"
  assumes "\<And>s t. \<lbrakk> s \<Turnstile> P; s \<Turnstile> Safety; (s,t) \<Turnstile> [Step]_(pc,x,y) \<rbrakk> \<Longrightarrow> s \<Turnstile> Enabled Step"
  shows "\<turnstile> Spec \<longrightarrow> (P \<leadsto> Q)"
  using assms by (intro StepFair actionI, auto)

lemma Termination: "\<turnstile> Spec \<longrightarrow> \<diamond>(ySet = #{n. n < N})"
proof -
  define F :: "(nat set \<times> nat set) \<Rightarrow> stpred" where "F \<equiv> \<lambda>(xs, ys). \<lambda>s. {n. n < N} - xSet s = xs \<and> {n. n < N} - ySet s = ys"
  define r :: "((nat set \<times> nat set) \<times> (nat set \<times> nat set)) set" where "r \<equiv> {(X, Y). X \<subset> Y \<and> Y \<subseteq> {n. n < N}} <*lex*> {(X, Y). X \<subset> Y \<and> Y \<subseteq> {n. n < N}}"

  have "\<turnstile> Spec \<longrightarrow> \<diamond>(\<exists> xsys. F xsys)"
    by (intro imp_eventually_tautology, auto simp add: F_def)
  also have "\<turnstile> Spec \<longrightarrow> ((\<exists> xsys. F xsys) \<leadsto> ySet = #{n. n < N})"
  proof (rule imp_leadsto_triangle_excl)
    show "\<turnstile> Spec \<longrightarrow> ((\<exists>xsys. F xsys) \<leadsto> (\<exists>xsys. F xsys))" by (intro imp_imp_leadsto, simp)

    have "\<turnstile> Spec \<longrightarrow> ((\<exists>xsys. F xsys) \<and> ySet \<noteq> #{n. n < N} \<leadsto> (\<exists>xsys. F xsys \<and> ySet \<noteq> #{n. n < N}))" by (intro imp_imp_leadsto, auto)
    also have "\<turnstile> Spec \<longrightarrow> ((\<exists>xsys. F xsys \<and> ySet \<noteq> #{n. n < N}) \<leadsto> ySet = #{n. n < N})"
    proof (intro wf_imp_ex_leadsto)
      show "wf r" unfolding r_def by (intro wf_lex_prod finite_subset_wf, auto)

      fix xsys
      show "\<turnstile> Spec \<longrightarrow> (F xsys \<and> ySet \<noteq> #{n. n < N} \<leadsto> ySet = #{n. n < N} \<or> (\<exists>y. #((y, xsys) \<in> r) \<and> F y \<and> ySet \<noteq> #{n. n < N}))"
      proof (intro StepFair_action)
        fix s t
        assume "s \<Turnstile> F xsys \<and> ySet \<noteq> #{n. n < N}"
        then obtain xs ys where xsys: "xsys = (xs, ys)" and running: "ySet s \<noteq> {n. n < N}"
          and xs: "xs = {n. n < N} - xSet s" and ys: "ys = {n. n < N} - ySet s"
          and s_F: "s \<Turnstile> F xsys" unfolding F_def by auto

        assume Safety: "s \<Turnstile> Safety"
        hence xSet_range: "xSet s \<subseteq> {n. n < N}" and ySet_range: "ySet s \<subseteq> {n. n < N}"
          and ySet_xSet: "ySet s \<subseteq> xSet s" and xSet_set: "\<And>n. n \<in> xSet s \<Longrightarrow> x s n = 1"
          unfolding Safety_def by auto

        show "s \<Turnstile> Enabled Step" by (intro enabled_StepI Safety running)

        show progress: "t \<Turnstile> ySet = #{n. n < N} \<or> (\<exists>y. #((y, xsys) \<in> r) \<and> F y \<and> ySet \<noteq> #{n. n < N})" if Step: "(s,t) \<Turnstile> Step"
        proof -
          from Step have "(s,t) \<Turnstile> [Step]_(pc,x,y)" unfolding square_def by simp
          thus ?thesis
          proof (cases rule: Step_cases)
            case (Step1 n)
            hence "t \<Turnstile> #(((xs - {n}, ys), xsys) \<in> r) \<and> F (xs - {n}, ys) \<and> ySet \<noteq> #{n. n < N}"
              apply (auto simp add: xsys F_def xs ys running, unfold r_def, simp)
              using Algorithm.xSet_def Algorithm_axioms by auto
            then show ?thesis by auto
          next
            case (Step2 n j)
            show ?thesis
            proof (cases "ySet t = {n. n < N}")
              case True thus ?thesis by simp
            next
              case False
              have "t \<Turnstile> #(((xs, ys - {n}), xsys) \<in> r) \<and> F (xs, ys - {n}) \<and> ySet \<noteq> #{n. n < N}"
              proof (intro temp_conjI)
                from False show "t \<Turnstile> ySet \<noteq> #{n. n < N}" by simp
                from Step2 xs ys show "t \<Turnstile> F (xs, ys - {n})" unfolding F_def by auto
                from Step2 xs ys show "t \<Turnstile> (#(((xs, ys - {n}), xsys) \<in> r))"
                  unfolding r_def xsys
                proof simp
                  assume a1: "pc s n = SetX"
                  assume "n < N"
                  then have "n \<in> {n. n < N} - ySet s"
                    using a1 by (simp add: ySet_def)
                  then show "{n. n < N} - ySet s - {n} \<subset> {n. n < N} - ySet s"
                    by blast
                qed

              qed
              then show ?thesis by auto
            qed
          next
            case unchanged
            from Step have "(s,t) \<Turnstile> <Step>_(pc,x,y)" unfolding angle_Step_eq.
            with unchanged show ?thesis by (simp add: angle_def)
          qed
        qed

        assume "(s,t) \<Turnstile> [Step]_(pc,x,y)"
        then consider (Step) "(s,t) \<Turnstile> Step" | (unchanged) "x t = x s" "y t = y s" "xSet t = xSet s" "ySet t = ySet s" unfolding square_def xSet_def ySet_def by auto
        thus "t \<Turnstile> F xsys \<and> ySet \<noteq> #{n. n < N} \<or> ySet = #{n. n < N} \<or> (\<exists>y. #((y, xsys) \<in> r) \<and> F y \<and> ySet \<noteq> #{n. n < N})"
        proof cases
          case Step with progress show ?thesis by simp
        next
          case unchanged with s_F have "t \<Turnstile> F xsys" by (auto simp add: F_def)
          thus ?thesis by simp
        qed
      qed
    qed
    finally show "\<turnstile> Spec \<longrightarrow> ((\<exists>xsys. F xsys) \<and> ySet \<noteq> #{n. n < N} \<leadsto> ySet = #{n. n < N})".
  qed
  finally show "\<turnstile> Spec \<longrightarrow> \<diamond>ySet = #{n. n < N}".
qed

lemma Termination_stops: "\<turnstile> Spec \<longrightarrow> \<diamond>\<box>(ySet = #{n. n < N})"
proof (intro stable_dmd_stuck Termination)
  from Safety have "\<turnstile> Spec \<longrightarrow> \<box>([Step]_(pc,x,y) \<and> $Safety)" unfolding Spec_def
    apply auto using Init_stp_act_rev boxInit_act boxInit_stp by auto
  also have "\<turnstile> \<box>([Step]_(pc,x,y) \<and> $Safety) \<longrightarrow> stable (ySet = #{n. n < N})"
  proof (intro StableT actionI temp_impI, elim temp_conjE, simp_all)
    fix s t
    assume "(s,t) \<Turnstile> [Step]_(pc,x,y)" "ySet s = {n. n < N}" "Safety s"
    thus "ySet t = {n. n < N}" by (cases rule: Step_cases, auto)
  qed
  finally show "\<turnstile> Spec \<longrightarrow> stable (ySet = #{n. n < N})".
qed

lemma eventually_1: "\<turnstile> Spec \<longrightarrow> \<diamond>(\<exists>n. id<y,#n> = #1)"
proof -
  note Termination
  also have "\<turnstile> Spec \<longrightarrow> ((ySet = #{n. n < N}) \<leadsto> (\<exists>n. id<y,#n> = #1))"
    by (intro imp_INV_leadsto [OF Safety imp_imp_leadsto] intI temp_impI, elim temp_conjE, auto simp add: Safety_def)
  finally show ?thesis .
qed

end


(*
  Author: Mohammad Abdulaziz, Fred Kurz
*)
theory STRIPS_Representation
  imports State_Variable_Representation
begin

section "STRIPS Representation"

(*<*)
type_synonym  ('variable) strips_state = "('variable, bool) state"
(*>*)
text \<open> We start by declaring a \isakeyword{record} for STRIPS operators.
This which allows us to define a data type and automatically generated selector operations.
\footnote{For the full reference on records see \cite[11.6, pp.260-265]{wenzel--2018}}

The record specification given below closely resembles the canonical representation of
STRIPS operators with fields corresponding to precondition, add effects as well as delete effects.\<close>

record  ('variable) strips_operator =
  precondition_of :: "'variable list"
  add_effects_of :: "'variable list"
  delete_effects_of :: "'variable list"

\<comment> \<open> This constructor function is sometimes a more descriptive and replacement for the record
syntax and can moreover be helpful if the record syntax leads to type ambiguity.\<close>
abbreviation  operator_for
  :: "'variable list \<Rightarrow> 'variable list \<Rightarrow> 'variable list \<Rightarrow> 'variable strips_operator"
  where "operator_for pre add delete \<equiv> \<lparr>
    precondition_of = pre
    , add_effects_of = add
    , delete_effects_of = delete \<rparr>"

definition  to_precondition
  :: "'variable strips_operator \<Rightarrow> ('variable, bool) assignment list"
  where "to_precondition op \<equiv> map (\<lambda>v. (v, True)) (precondition_of op)"

definition  to_effect
  :: "'variable strips_operator \<Rightarrow> ('variable, bool) Effect"
  where "to_effect op =  [(v\<^sub>a, True). v\<^sub>a \<leftarrow> add_effects_of op] @ [(v\<^sub>d, False). v\<^sub>d \<leftarrow> delete_effects_of op]"

text \<open> Similar to the operator definition, we use a record to represent STRIPS problems and specify
fields for the variables, operators, as well as the initial and goal state. \<close>

record  ('variable) strips_problem =
  variables_of :: "'variable list" ("(_\<^sub>\<V>)" [1000] 999)
  operators_of :: "'variable strips_operator list" ("(_\<^sub>\<O>)" [1000] 999)
  initial_of :: "'variable strips_state" ("(_\<^sub>I)" [1000] 999)
  goal_of :: "'variable strips_state" ("(_\<^sub>G)" [1000] 999)

value  "stop" (* Tell document preparation to stop collecting for the last tag *)
(*<*)
\<comment> \<open> This constructor function is sometimes a more descriptive and replacement for the record
syntax and can moreover be helpful if the record syntax leads to type ambiguity.\<close>
(* TODO change identifier gs ~> G *)
abbreviation problem_for
  :: "'variable list
  \<Rightarrow> 'variable strips_operator list
  \<Rightarrow> 'variable strips_state
  \<Rightarrow> 'variable strips_state
  \<Rightarrow> ('variable) strips_problem"
  where "problem_for vs ops I gs \<equiv> \<lparr>
    variables_of = vs
    , operators_of = ops
    , initial_of = I
    , goal_of = gs \<rparr>"

type_synonym ('variable) strips_plan = "'variable strips_operator list"

type_synonym ('variable) strips_parallel_plan = "'variable strips_operator list list"

definition is_valid_operator_strips
  :: "'variable strips_problem \<Rightarrow> 'variable strips_operator \<Rightarrow> bool"
  where "is_valid_operator_strips \<Pi> op \<equiv> let
      vs = variables_of \<Pi>
      ; pre = precondition_of op
      ; add = add_effects_of op
      ; del = delete_effects_of op
    in list_all (\<lambda>v. ListMem v vs) pre
    \<and> list_all (\<lambda>v. ListMem v vs) add
    \<and> list_all (\<lambda>v. ListMem v vs) del
    \<and> list_all (\<lambda>v. \<not>ListMem v del) add
    \<and> list_all (\<lambda>v. \<not>ListMem v add) del"

definition "is_valid_problem_strips \<Pi>
  \<equiv> let ops = operators_of \<Pi>
      ; vs = variables_of \<Pi>
      ; I = initial_of \<Pi>
      ; G = goal_of \<Pi>
    in  list_all (is_valid_operator_strips \<Pi>) ops
    \<and> (\<forall>v. I v \<noteq> None \<longleftrightarrow> ListMem v vs)
    \<and> (\<forall>v. G v \<noteq> None \<longrightarrow> ListMem v vs)"

definition is_operator_applicable_in
  :: "'variable strips_state \<Rightarrow> 'variable strips_operator \<Rightarrow> bool"
  where "is_operator_applicable_in s op \<equiv> let p = precondition_of op in
    list_all (\<lambda>v. s v = Some True) p"

(* TODO effect_to_strips and effect_to_assignments could just be removed if we prove a lemma
  showing the equivalence to effcond semantics.*)
definition effect__strips
  :: "'variable strips_operator \<Rightarrow> ('variable, bool) Effect"
  where "effect__strips op
    =
      map (\<lambda>v. (v, True)) (add_effects_of op)
      @ map (\<lambda>v. (v, False)) (delete_effects_of op)"

definition effect_to_assignments
  where "effect_to_assignments op \<equiv> effect__strips op"
(*>*)

text \<open> As discussed in \autoref{sub:serial-sas-plus-and-parallel-strips}, the effect of
a STRIPS operator can be normalized to a conjunction of atomic effects. We can therefore construct
the successor state by simply converting the list of add effects to assignments to \<^term>\<open>True\<close> resp.
converting the list of delete effect to a list of assignments to \<^term>\<open>False\<close> and then adding the
map corresponding to the assignments to the given state \<^term>\<open>s\<close> as shown below in definition
\ref{isadef:operator-execution-strips}.
\footnote{Function \path{effect_to_assignments} converts the operator effect to a list of
assignments. }\<close>

definition  execute_operator
  :: "'variable strips_state
    \<Rightarrow> 'variable strips_operator
    \<Rightarrow> 'variable strips_state" (infixl "\<then>" 52)
  where "execute_operator s op
    \<equiv> s ++ map_of (effect_to_assignments op)"

end


theory prop_13
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

hipster eqN
lemma lemma_a [thy_expl]: "eqN x2 y2 = eqN y2 x2"
by (hipster_induct_schemes eqN.simps)

lemma lemma_aa [thy_expl]: "eqN x2 x2 = True"
by (hipster_induct_schemes eqN.simps)

lemma lemma_ab [thy_expl]: "eqN x2 (S x2) = False"
by (hipster_induct_schemes eqN.simps)

theorem count02: "count t ts = n \<Longrightarrow> count t (Cons t ts) = S n"
by (hipster_induct_schemes)

end


(*  Title:      JinjaThreads/J/DefAss.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

header {* \isaheader{Definite assignment} *}

theory DefAss
imports
  Expr
begin

subsection "Hypersets"

type_synonym 'a hyperset = "'a set option"

definition hyperUn :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<squnion>" 65)
where
  "A \<squnion> B  \<equiv>  case A of None \<Rightarrow> None
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> None | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<union> B\<rfloor>)"

definition hyperInt :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<sqinter>" 70)
where
  "A \<sqinter> B  \<equiv>  case A of None \<Rightarrow> B
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> \<lfloor>A\<rfloor> | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<inter> B\<rfloor>)"

definition hyperDiff1 :: "'a hyperset \<Rightarrow> 'a \<Rightarrow> 'a hyperset"   (infixl "\<ominus>" 65)
where
  "A \<ominus> a  \<equiv>  case A of None \<Rightarrow> None | \<lfloor>A\<rfloor> \<Rightarrow> \<lfloor>A - {a}\<rfloor>"

definition hyper_isin :: "'a \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<in>\<in>" 50)
where
 "a \<in>\<in> A  \<equiv>  case A of None \<Rightarrow> True | \<lfloor>A\<rfloor> \<Rightarrow> a \<in> A"

definition hyper_subset :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<sqsubseteq>" 50)
where
  "A \<sqsubseteq> B  \<equiv>  case B of None \<Rightarrow> True
                 | \<lfloor>B\<rfloor> \<Rightarrow> (case A of None \<Rightarrow> False | \<lfloor>A\<rfloor> \<Rightarrow> A \<subseteq> B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "\<lfloor>A\<rfloor> \<squnion> \<lfloor>B\<rfloor> = \<lfloor>A \<union> B\<rfloor> \<and> \<lfloor>A\<rfloor> \<ominus> a = \<lfloor>A - {a}\<rfloor>"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "None \<squnion> A = None \<and> A \<squnion> None = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "a \<in>\<in> None \<and> None \<ominus> a = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma hyperUn_assoc: "(A \<squnion> B) \<squnion> C = A \<squnion> (B \<squnion> C)"
(*<*)by(simp add:hyperset_defs Un_assoc)(*>*)

lemma hyper_insert_comm: "A \<squnion> \<lfloor>{a}\<rfloor> = \<lfloor>{a}\<rfloor> \<squnion> A \<and> A \<squnion> (\<lfloor>{a}\<rfloor> \<squnion> B) = \<lfloor>{a}\<rfloor> \<squnion> (A \<squnion> B)"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "A \<sqsubseteq> A"
by(auto simp add: hyperset_defs)

lemma [iff]: "\<lfloor>A\<rfloor> \<sqsubseteq> \<lfloor>B\<rfloor> \<longleftrightarrow> A \<subseteq> B"
by(auto simp add: hyperset_defs)

lemma sqUn_lem2: "A \<sqsubseteq> A' \<Longrightarrow> B \<squnion> A \<sqsubseteq> B \<squnion> A'"
by(simp add:hyperset_defs) blast

lemma sqSub_trans [trans, intro]: "\<lbrakk> A \<sqsubseteq> B; B \<sqsubseteq> C \<rbrakk> \<Longrightarrow> A \<sqsubseteq> C"
by(auto simp add: hyperset_defs)

lemma hyperUn_comm: "A \<squnion> B = B \<squnion> A"
by(auto simp add: hyperset_defs)

lemma hyperUn_leftComm: "A \<squnion> (B \<squnion> C) = B \<squnion> (A \<squnion> C)"
by(auto simp add: hyperset_defs)

lemmas hyperUn_ac = hyperUn_comm hyperUn_leftComm hyperUn_assoc

lemma [simp]: "\<lfloor>{}\<rfloor> \<squnion> B = B"
by(auto)

lemma [simp]: "\<lfloor>{}\<rfloor> \<sqsubseteq> A"
by(auto simp add: hyperset_defs)

lemma sqInt_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<sqinter> B \<sqsubseteq> A' \<sqinter> B"
by(auto simp add: hyperset_defs)

subsection "Definite assignment"

primrec \  :: "('a,'b,'addr) exp \<Rightarrow> 'a hyperset"
  and \s :: "('a,'b,'addr) exp list \<Rightarrow> 'a hyperset"
where
  "\ (new C) = \<lfloor>{}\<rfloor>"
| "\ (newA T\<lfloor>e\<rceil>) = \ e"
| "\ (Cast C e) = \ e"
| "\ (e instanceof T) = \ e"
| "\ (Val v) = \<lfloor>{}\<rfloor>"
| "\ (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (Var V) = \<lfloor>{}\<rfloor>"
| "\ (LAss V e) = \<lfloor>{V}\<rfloor> \<squnion> \ e"
| "\ (a\<lfloor>i\<rceil>) = \ a \<squnion> \ i"
| "\ (a\<lfloor>i\<rceil> := e) = \ a \<squnion> \ i \<squnion> \ e"
| "\ (a\<bullet>length) = \ a"
| "\ (e\<bullet>F{D}) = \ e"
| "\ (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (e\<bullet>M(es)) = \ e \<squnion> \s es"
| "\ ({V:T=vo; e}) = \ e \<ominus> V"
| "\ (sync\<^bsub>V\<^esub> (o') e) = \ o' \<squnion> \ e"
| "\ (insync\<^bsub>V\<^esub> (a) e) = \ e"
| "\ (e\<^sub>1;;e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (if (e) e\<^sub>1 else e\<^sub>2) =  \ e \<squnion> (\ e\<^sub>1 \<sqinter> \ e\<^sub>2)"
| "\ (while (b) e) = \ b"
| "\ (throw e) = None"
| "\ (try e\<^sub>1 catch(C V) e\<^sub>2) = \ e\<^sub>1 \<sqinter> (\ e\<^sub>2 \<ominus> V)"

| "\s ([]) = \<lfloor>{}\<rfloor>"
| "\s (e#es) = \ e \<squnion> \s es"

primrec \<D>  :: "('a,'b,'addr) exp \<Rightarrow> 'a hyperset \<Rightarrow> bool"
  and \<D>s :: "('a,'b,'addr) exp list \<Rightarrow> 'a hyperset \<Rightarrow> bool"
where
  "\<D> (new C) A = True"
| "\<D> (newA T\<lfloor>e\<rceil>) A = \<D> e A"
| "\<D> (Cast C e) A = \<D> e A"
| "\<D> (e instanceof T) = \<D> e"
| "\<D> (Val v) A = True"
| "\<D> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (Var V) A = (V \<in>\<in> A)"
| "\<D> (LAss V e) A = \<D> e A"
| "\<D> (a\<lfloor>i\<rceil>) A = (\<D> a A \<and> \<D> i (A \<squnion> \ a))"
| "\<D> (a\<lfloor>i\<rceil> := e) A = (\<D> a A \<and> \<D> i (A \<squnion> \ a) \<and> \<D> e (A \<squnion> \ a \<squnion> \ i))"
| "\<D> (a\<bullet>length) A = \<D> a A"
| "\<D> (e\<bullet>F{D}) A = \<D> e A"
| "\<D> (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (e\<bullet>M(es)) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"
| "\<D> ({V:T=vo; e}) A = (if vo = None then \<D> e (A \<ominus> V) else \<D> e (A \<squnion> \<lfloor>{V}\<rfloor>))"
| "\<D> (sync\<^bsub>V\<^esub> (o') e) A = (\<D> o' A \<and> \<D> e (A \<squnion> \ o'))"
| "\<D> (insync\<^bsub>V\<^esub> (a) e) A = \<D> e A"
| "\<D> (e\<^sub>1;;e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (if (e) e\<^sub>1 else e\<^sub>2) A = (\<D> e A \<and> \<D> e\<^sub>1 (A \<squnion> \ e) \<and> \<D> e\<^sub>2 (A \<squnion> \ e))"
| "\<D> (while (e) c) A = (\<D> e A \<and> \<D> c (A \<squnion> \ e))"
| "\<D> (throw e) A = \<D> e A"
| "\<D> (try e\<^sub>1 catch(C V) e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \<lfloor>{V}\<rfloor>))"

| "\<D>s ([]) A = True"
| "\<D>s (e#es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"

lemma As_map_Val[simp]: "\s (map Val vs) = \<lfloor>{}\<rfloor>"
(*<*)by (induct vs) simp_all(*>*)

lemma As_append [simp]: "\s (xs @ ys) = (\s xs) \<squnion> (\s ys)"
by(induct xs, auto simp add: hyperset_defs)

lemma Ds_map_Val[simp]: "\<D>s (map Val vs) A"
(*<*)by (induct vs) simp_all(*>*)

lemma D_append[iff]: "\<And>A. \<D>s (es @ es') A = (\<D>s es A \<and> \<D>s es' (A \<squnion> \s es))"
(*<*)by (induct es type:list) (auto simp:hyperUn_assoc)(*>*)

lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
  shows A_fv: "\<And>A. \ e = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fv e"
  and  "\<And>A. \s es = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fvs es"
apply(induct e and es rule: \.induct \s.induct)
apply (simp_all add:hyperset_defs)
apply fast+
done

lemma sqUn_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<squnion> B \<sqsubseteq> A' \<squnion> B"
(*<*)by(simp add:hyperset_defs) blast(*>*)

lemma diff_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<ominus> b \<sqsubseteq> A' \<ominus> b"
(*<*)by(simp add:hyperset_defs) blast(*>*)

(* This order of the premises avoids looping of the simplifier *)
lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows D_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D> e A \<Longrightarrow> \<D> e A'"
  and Ds_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A \<Longrightarrow> \<D>s es A'"
(*<*)
apply(induct e and es rule: \<D>.induct \<D>s.induct)
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply (fastforce simp add:hyperset_defs)
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply(clarsimp split: split_if_asm) apply (iprover dest:diff_lem) apply(iprover dest: sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
done
(*>*)

(* And this is the order of premises preferred during application: *)
lemma D_mono': "\<D> e A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D> e A'"
and Ds_mono': "\<D>s es A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A'"
(*<*)by(blast intro:D_mono, blast intro:Ds_mono)(*>*)

declare hyperUn_comm [simp]
declare hyperUn_leftComm [simp]

end


header {* Abstract syntax for bHCSP *}

theory bHCSP_Com
  imports  Main
"DCSequents/DCSequent"

begin

type_synonym bexp = fform
type_synonym Inv = fform

(*Only ch?RVar x{u} is allowed for simplicity, but not an essential restriction.*)
type_synonym qualityp = "fform \<Rightarrow> fform \<Rightarrow> fform"
datatype bindp
=  Send "string" "exp" "string"        ("_!!_{_}" [110,108,108] 100)
  | Receive "string" "string"  "string"  ("_??_{_}" [110,108,108] 100)
  | Binder "qualityp" "bindp" "bindp" ("& _ [_, _]" [110,108,108] 10)

(*May-modified variables of binders*)
primrec mvar :: "bindp \<Rightarrow> string list" ("mvar _")
where
"mvar (ch??x{u}) = [x, u]" |
"mvar (ch!!e{u}) = [u]" |
"mvar (&q [a, b]) = mvar (a) @ mvar (b)"

(*Existential quantifiers extension to a list of variables*)
primrec Lex :: "fform => string list => fform"  ("Lex _ _")
where
"Lex p [] = p" |
"Lex p (x # xs) = (WEX x (Lex p xs))"

datatype typeid = Ri | Si | Bi

consts der :: "string => string"
type_synonym diffeq = "string list => exp"
type_synonym eqlist = "diffeq list"

definition test :: "diffeq" where
"test  ==  % a. (if (a = [''s'']) then ((RVar ''s'') [+] RVar (der (''s''))) else (Real 0))"

datatype bproc
= "Skip"
| Ass "exp" "exp"          ("_ := _" [99, 95] 94)
(*binder from quality calculus*)
| Qb "bindp"                ("Qb _" 94)
| Con "string list" "eqlist" "bexp"                 ("_:<_&&_> " [94,95,96]94)
| Inr "string list" "eqlist" "bexp" "bindp" "bproc" ("_:<_&&_>[[_ _"[95,94,95,94]94)
| Par  "bproc" "bproc"                  ("_||_" [90,90]89)
| Seq "bproc" "bproc"                   ("_; _"        [91,90] 90)
| Cond "bexp" "bproc"                 ("IF _ _"   [95,94]93)
| Rep    "bproc"                               ("_*"[91] 90)
| Nondeter "typeid" "string" "bexp" "bproc"                 ("NON _ _ : _ _"   [95,95,94,94]93)

type_synonym pair = "exp * exp"

primrec map :: "pair list => exp => exp" where
"map ([]) (a) = a" |
"map (x#xs) (a) = (if (fst (x) = a) then (snd (x)) else (map (xs) (a)))"

lemma "map ([(RVar ''x'', Real 2), (RVar ''y'', RVar z)],  RVar ''x'') = (Real 2)"
apply (induct, auto)
done

lemma fact1 : "map ([(RVar ''x'', Real 2), (RVar ''y'', RVar z)]) (RVar ''z'') = RVar ''z''"
apply (induct, auto)
done

(*Expression substitution: "map" records the substitution mapping.*)
primrec substE :: "pair list => exp => exp" where
"substE (mp, (RVar x)) = map (mp, (RVar x))"  |
"substE (mp, (SVar x)) = map (mp, (SVar x))"  |
"substE (mp, (BVar x)) = map (mp, (BVar x))"  |
"substE (mp, (Real m)) = map (mp, (Real m))"  |
"substE (mp, (Bool b)) = map (mp, (Bool b))"  |
"substE (mp, (String s)) = map (mp, (String s))"  |
"substE (mp, (e1 [+] e2)) = substE (mp, e1) [+] substE (mp, e2)"  |
"substE (mp, (e1 [-] e2)) = substE (mp, e1) [-] substE (mp, e2)"|
"substE (mp, (e1 [*] e2)) = substE (mp, e1) [*] substE (mp, e2)"

lemma "(% x. x [+] x = RVar ''z'' [+] RVar ''z'') (RVar ''z'')"
apply auto
done

lemma "substE ([(RVar ''x'', Real 1), (RVar ''y'', RVar ''z'')], (RVar ''y'' [+] RVar ''z''))
        = RVar ''z'' [+] RVar ''z''"
apply (induct, auto)
done

(*Tip: for theory built on Pure, application is written by f(x) rather than f x as usual. *)

primrec lVarE :: "pair list => string => pair list" where
"lVarE ([],s) = []" |
"lVarE (x#xs,s) = (if (fst (x) = (RVar s)) then xs else x#lVarE(xs, s))"

primrec inExp :: "string => exp => bool" where
"inExp (s, (RVar x)) = (s=x)"  |
"inExp (s, (SVar x)) = (s=x)"  |
"inExp (s, (BVar x)) = (s=x)"  |
"inExp (s, (Real m)) = (False)"  |
"inExp (s, (Bool b)) = (False)"  |
"inExp (s, (String r)) = (False)"  |
"inExp (s, (e1 [+] e2)) = (inExp (s, e1) | inExp (s, e2))"  |
"inExp (s, (e1 [-] e2)) = (inExp (s, e1) | inExp (s, e2))"|
"inExp (s, (e1 [*] e2)) = (inExp (s, e1) | inExp (s, e2))"

primrec inPairL :: "pair list => string => bool" where
"inPairL ([],s) = False" |
"inPairL (x#xs,s) = (if (inExp (s, fst (x))) then True else inPairL(xs, s))"

primrec inPairR :: "pair list => string => bool" where
"inPairR ([],s) = False" |
"inPairR (x#xs,s) = (if (inExp (s, snd (x))) then True else inPairR(xs, s))"

(*Check if the quantifiers of a formula occur in mp*)
primrec inPairForm :: "pair list => fform => bool" where
 "inPairForm (mp) (WTrue) = False" |
 "inPairForm (mp) (WFalse) = False" |
 "inPairForm (mp) (e1 [=] e2) =False" |
 "inPairForm (mp) (e1 [<] e2) = False" |
 "inPairForm (mp) (e1 [>] e2) =False" |
 "inPairForm (mp) ([~]p) = (inPairForm (mp) (p))" |
 "inPairForm (mp) (p [&] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (p [|] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (p [-->] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (p [<->] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (WALL i p) = (inPairL (mp, i) | inPairR (mp, i) | inPairForm (mp)(p))" |
 "inPairForm (mp) (WEX i p) = (inPairL (mp, i) | inPairR (mp, i) | inPairForm (mp)(p))"

(*Formula sustitution.*)
primrec substF :: "pair list => fform => fform" where
 "substF (mp) (WTrue) = WTrue" |
 "substF (mp) (WFalse) = WFalse" |
 "substF (mp) (e1 [=] e2) = ((substE (mp, e1)) [=] (substE (mp, e2)))" |
 "substF (mp) (e1 [<] e2) = ((substE (mp, e1)) [<] (substE (mp, e2)))" |
 "substF (mp) (e1 [>] e2) = (substE (mp, e1) [>] substE (mp, e2))" |
 "substF (mp) ([~]p) = ([~](substF (mp) (p)))" |
 "substF (mp) (p [&] q) = ((substF (mp) (p)) [&] (substF (mp) (q)))" |
 "substF (mp) (p [|] q) = ((substF (mp) (p)) [|] (substF (mp) (q)))" |
 "substF (mp) (p [-->] q) = ((substF (mp) (p)) [-->] (substF (mp) (q)))" |
 "substF (mp) (p [<->] q) = ((substF (mp) (p)) [<->] (substF (mp) (q)))" |
 "substF (mp) (WALL i p) = (if ((~inPairL (mp, i)) & (~inPairR (mp, i))) then (WALL i (substF (mp)(p)))
                           else WFalse)" |
 "substF (mp) (WEX i p) = (if ((~inPairL (mp, i)) & (~inPairR (mp, i))) then (WEX i (substF (mp)(p)))
                           else WFalse)"

lemma allEX : "substF([(RVar ''x'', RVar ''m''), (RVar ''y'', RVar ''z'')],
                 ((RVar ''x'')[=]Real 2) [&] (WALL ''w'' ((RVar ''w'') [>] (RVar ''z''))))
             = (((RVar ''m'')[=]Real 2) [&] (WALL ''w'' ((RVar ''w'') [>] (RVar ''z''))))"
apply auto
done

lemma test : "substF ([(RVar ''x'', Real 2), (RVar ''y'', RVar ''z'')]) (RVar ''x'' [>] Real 1) = (Real 2 [>] Real 1)"
apply (induct, auto)
done

end


theory sort_StoogeSort2Sorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

fun zsplitAt :: "int => 'a list =>
                 (('a list), ('a list)) Pair2" where
"zsplitAt x y = Pair (ztake x y) (zdrop x y)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

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

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 x =
   case zsplitAt (div ((2 * (zlength x)) + 1) 3) x of
     | Pair ys zs =>
         case zsplitAt (div ((2 * (zlength x)) + 1) 3) x of
           | Pair xs zs2 => append (stoogesort2 ys) zs2
         end
   end"
| "stoogesort2 (Nil2) = Nil2"
| "stoogesort2 (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "stoogesort2 (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "stoogesort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "stooge2sort1 x =
     case zsplitAt (div (zlength x) 3) x of
       | Pair ys zs =>
           case zsplitAt (div (zlength x) 3) x of
             | Pair xs zs2 => append ys (stoogesort2 zs2)
           end
     end"
by pat_completeness auto

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster ztake
          zlength
          zdrop
          zsplitAt
          sort2
          append
          stooge2sort2
          stoogesort2
          stooge2sort1
          and2
          ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (stoogesort2 x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end