(*  Title:      HOL/Library/Stirling.thy
    Author:     Amine Chaieb
    Author:     Florian Haftmann
    Author:     Lukas Bulwahn
    Author:     Manuel Eberl
*)

section \<open>Stirling numbers of first and second kind\<close>

theory Stirling
imports Binomial
begin

subsection \<open>Stirling numbers of the second kind\<close>

fun Stirling :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "Stirling 0 0 = 1"
  | "Stirling 0 (Suc k) = 0"
  | "Stirling (Suc n) 0 = 0"
  | "Stirling (Suc n) (Suc k) = Suc k * Stirling n (Suc k) + Stirling n k"

lemma Stirling_1 [simp]: "Stirling (Suc n) (Suc 0) = 1"
  by (induct n) simp_all

lemma Stirling_less [simp]: "n < k \<Longrightarrow> Stirling n k = 0"
  by (induct n k rule: Stirling.induct) simp_all

lemma Stirling_same [simp]: "Stirling n n = 1"
  by (induct n) simp_all

lemma Stirling_2_2: "Stirling (Suc (Suc n)) (Suc (Suc 0)) = 2 ^ Suc n - 1"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "Stirling (Suc (Suc (Suc n))) (Suc (Suc 0)) =
      2 * Stirling (Suc (Suc n)) (Suc (Suc 0)) + Stirling (Suc (Suc n)) (Suc 0)"
    by simp
  also have "\<dots> = 2 * (2 ^ Suc n - 1) + 1"
    by (simp only: Suc Stirling_1)
  also have "\<dots> = 2 ^ Suc (Suc n) - 1"
  proof -
    have "(2::nat) ^ Suc n - 1 > 0"
      by (induct n) simp_all
    then have "2 * ((2::nat) ^ Suc n - 1) > 0"
      by simp
    then have "2 \<le> 2 * ((2::nat) ^ Suc n)"
      by simp
    with add_diff_assoc2 [of 2 "2 * 2 ^ Suc n" 1]
    have "2 * 2 ^ Suc n - 2 + (1::nat) = 2 * 2 ^ Suc n + 1 - 2" .
    then show ?thesis
      by (simp add: nat_distrib)
  qed
  finally show ?case by simp
qed

lemma Stirling_2: "Stirling (Suc n) (Suc (Suc 0)) = 2 ^ n - 1"
  using Stirling_2_2 by (cases n) simp_all

subsection \<open>Stirling numbers of the first kind\<close>

fun stirling :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "stirling 0 0 = 1"
  | "stirling 0 (Suc k) = 0"
  | "stirling (Suc n) 0 = 0"
  | "stirling (Suc n) (Suc k) = n * stirling n (Suc k) + stirling n k"

lemma stirling_0 [simp]: "n > 0 \<Longrightarrow> stirling n 0 = 0"
  by (cases n) simp_all

lemma stirling_less [simp]: "n < k \<Longrightarrow> stirling n k = 0"
  by (induct n k rule: stirling.induct) simp_all

lemma stirling_same [simp]: "stirling n n = 1"
  by (induct n) simp_all

lemma stirling_Suc_n_1: "stirling (Suc n) (Suc 0) = fact n"
  by (induct n) auto

lemma stirling_Suc_n_n: "stirling (Suc n) n = Suc n choose 2"
  by (induct n) (auto simp add: numerals(2))

lemma stirling_Suc_n_2:
  assumes "n \<ge> Suc 0"
  shows "stirling (Suc n) 2 = (\<Sum>k=1..n. fact n div k)"
  using assms
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by (simp add: numerals(2))
  next
    case Suc
    then have geq1: "Suc 0 \<le> n"
      by simp
    have "stirling (Suc (Suc n)) 2 = Suc n * stirling (Suc n) 2 + stirling (Suc n) (Suc 0)"
      by (simp only: stirling.simps(4)[of "Suc n"] numerals(2))
    also have "\<dots> = Suc n * (\<Sum>k=1..n. fact n div k) + fact n"
      using Suc.hyps[OF geq1]
      by (simp only: stirling_Suc_n_1 of_nat_fact of_nat_add of_nat_mult)
    also have "\<dots> = Suc n * (\<Sum>k=1..n. fact n div k) + Suc n * fact n div Suc n"
      by (metis nat.distinct(1) nonzero_mult_div_cancel_left)
    also have "\<dots> = (\<Sum>k=1..n. fact (Suc n) div k) + fact (Suc n) div Suc n"
      by (simp add: sum_distrib_left div_mult_swap dvd_fact)
    also have "\<dots> = (\<Sum>k=1..Suc n. fact (Suc n) div k)"
      by simp
    finally show ?thesis .
  qed
qed

lemma of_nat_stirling_Suc_n_2:
  assumes "n \<ge> Suc 0"
  shows "(of_nat (stirling (Suc n) 2)::'a::field_char_0) = fact n * (\<Sum>k=1..n. (1 / of_nat k))"
  using assms
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by (auto simp add: numerals(2))
  next
    case Suc
    then have geq1: "Suc 0 \<le> n"
      by simp
    have "(of_nat (stirling (Suc (Suc n)) 2)::'a) =
        of_nat (Suc n * stirling (Suc n) 2 + stirling (Suc n) (Suc 0))"
      by (simp only: stirling.simps(4)[of "Suc n"] numerals(2))
    also have "\<dots> = of_nat (Suc n) * (fact n * (\<Sum>k = 1..n. 1 / of_nat k)) + fact n"
      using Suc.hyps[OF geq1]
      by (simp only: stirling_Suc_n_1 of_nat_fact of_nat_add of_nat_mult)
    also have "\<dots> = fact (Suc n) * (\<Sum>k = 1..n. 1 / of_nat k) + fact (Suc n) * (1 / of_nat (Suc n))"
      using of_nat_neq_0 by auto
    also have "\<dots> = fact (Suc n) * (\<Sum>k = 1..Suc n. 1 / of_nat k)"
      by (simp add: distrib_left)
    finally show ?thesis .
  qed
qed

lemma sum_stirling: "(\<Sum>k\<le>n. stirling n k) = fact n"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "(\<Sum>k\<le>Suc n. stirling (Suc n) k) = stirling (Suc n) 0 + (\<Sum>k\<le>n. stirling (Suc n) (Suc k))"
    by (simp only: sum_atMost_Suc_shift)
  also have "\<dots> = (\<Sum>k\<le>n. stirling (Suc n) (Suc k))"
    by simp
  also have "\<dots> = (\<Sum>k\<le>n. n * stirling n (Suc k) + stirling n k)"
    by simp
  also have "\<dots> = n * (\<Sum>k\<le>n. stirling n (Suc k)) + (\<Sum>k\<le>n. stirling n k)"
    by (simp add: sum.distrib sum_distrib_left)
  also have "\<dots> = n * fact n + fact n"
  proof -
    have "n * (\<Sum>k\<le>n. stirling n (Suc k)) = n * ((\<Sum>k\<le>Suc n. stirling n k) - stirling n 0)"
      by (metis add_diff_cancel_left' sum_atMost_Suc_shift)
    also have "\<dots> = n * (\<Sum>k\<le>n. stirling n k)"
      by (cases n) simp_all
    also have "\<dots> = n * fact n"
      using Suc.hyps by simp
    finally have "n * (\<Sum>k\<le>n. stirling n (Suc k)) = n * fact n" .
    moreover have "(\<Sum>k\<le>n. stirling n k) = fact n"
      using Suc.hyps .
    ultimately show ?thesis by simp
  qed
  also have "\<dots> = fact (Suc n)" by simp
  finally show ?case .
qed

lemma stirling_pochhammer:
  "(\<Sum>k\<le>n. of_nat (stirling n k) * x ^ k) = (pochhammer x n :: 'a::comm_semiring_1)"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "of_nat (n * stirling n 0) = (0 :: 'a)" by (cases n) simp_all
  then have "(\<Sum>k\<le>Suc n. of_nat (stirling (Suc n) k) * x ^ k) =
      (of_nat (n * stirling n 0) * x ^ 0 +
      (\<Sum>i\<le>n. of_nat (n * stirling n (Suc i)) * (x ^ Suc i))) +
      (\<Sum>i\<le>n. of_nat (stirling n i) * (x ^ Suc i))"
    by (subst sum_atMost_Suc_shift) (simp add: sum.distrib ring_distribs)
  also have "\<dots> = pochhammer x (Suc n)"
    by (subst sum_atMost_Suc_shift [symmetric])
      (simp add: algebra_simps sum.distrib sum_distrib_left pochhammer_Suc Suc [symmetric])
  finally show ?case .
qed

text \<open>A row of the Stirling number triangle\<close>

definition stirling_row :: "nat \<Rightarrow> nat list"
  where "stirling_row n = [stirling n k. k \<leftarrow> [0..<Suc n]]"

lemma nth_stirling_row: "k \<le> n \<Longrightarrow> stirling_row n ! k = stirling n k"
  by (simp add: stirling_row_def del: upt_Suc)

lemma length_stirling_row [simp]: "length (stirling_row n) = Suc n"
  by (simp add: stirling_row_def)

lemma stirling_row_nonempty [simp]: "stirling_row n \<noteq> []"
  using length_stirling_row[of n] by (auto simp del: length_stirling_row)

(* TODO Move *)
lemma list_ext:
  assumes "length xs = length ys"
  assumes "\<And>i. i < length xs \<Longrightarrow> xs ! i = ys ! i"
  shows "xs = ys"
  using assms
proof (induction rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons x xs y ys)
  from Cons.prems[of 0] have "x = y"
    by simp
  moreover from Cons.prems[of "Suc i" for i] have "xs = ys"
    by (intro Cons.IH) simp
  ultimately show ?case by simp
qed

subsubsection \<open>Efficient code\<close>

text \<open>
  Naively using the defining equations of the Stirling numbers of the first
  kind to compute them leads to exponential run time due to repeated
  computations. We can use memoisation to compute them row by row without
  repeating computations, at the cost of computing a few unneeded values.

  As a bonus, this is very efficient for applications where an entire row of
  Stirling numbers is needed.
\<close>

definition zip_with_prev :: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'b list"
  where "zip_with_prev f x xs = map (\<lambda>(x,y). f x y) (zip (x # xs) xs)"

lemma zip_with_prev_altdef:
  "zip_with_prev f x xs =
    (if xs = [] then [] else f x (hd xs) # [f (xs!i) (xs!(i+1)). i \<leftarrow> [0..<length xs - 1]])"
proof (cases xs)
  case Nil
  then show ?thesis
    by (simp add: zip_with_prev_def)
next
  case (Cons y ys)
  then have "zip_with_prev f x xs = f x (hd xs) # zip_with_prev f y ys"
    by (simp add: zip_with_prev_def)
  also have "zip_with_prev f y ys = map (\<lambda>i. f (xs ! i) (xs ! (i + 1))) [0..<length xs - 1]"
    unfolding Cons
    by (induct ys arbitrary: y)
      (simp_all add: zip_with_prev_def upt_conv_Cons map_Suc_upt [symmetric] del: upt_Suc)
  finally show ?thesis
    using Cons by simp
qed

primrec stirling_row_aux
  where
    "stirling_row_aux n y [] = [1]"
  | "stirling_row_aux n y (x#xs) = (y + n * x) # stirling_row_aux n x xs"

lemma stirling_row_aux_correct:
  "stirling_row_aux n y xs = zip_with_prev (\<lambda>a b. a + n * b) y xs @ [1]"
  by (induct xs arbitrary: y) (simp_all add: zip_with_prev_def)

lemma stirling_row_code [code]:
  "stirling_row 0 = [1]"
  "stirling_row (Suc n) = stirling_row_aux n 0 (stirling_row n)"
proof goal_cases
  case 1
  show ?case by (simp add: stirling_row_def)
next
  case 2
  have "stirling_row (Suc n) =
    0 # [stirling_row n ! i + stirling_row n ! (i+1) * n. i \<leftarrow> [0..<n]] @ [1]"
  proof (rule list_ext, goal_cases length nth)
    case (nth i)
    from nth have "i \<le> Suc n"
      by simp
    then consider "i = 0 \<or> i = Suc n" | "i > 0" "i \<le> n"
      by linarith
    then show ?case
    proof cases
      case 1
      then show ?thesis
        by (auto simp: nth_stirling_row nth_append)
    next
      case 2
      then show ?thesis
        by (cases i) (simp_all add: nth_append nth_stirling_row)
    qed
  next
    case length
    then show ?case by simp
  qed
  also have "0 # [stirling_row n ! i + stirling_row n ! (i+1) * n. i \<leftarrow> [0..<n]] @ [1] =
      zip_with_prev (\<lambda>a b. a + n * b) 0 (stirling_row n) @ [1]"
    by (cases n) (auto simp add: zip_with_prev_altdef stirling_row_def hd_map simp del: upt_Suc)
  also have "\<dots> = stirling_row_aux n 0 (stirling_row n)"
    by (simp add: stirling_row_aux_correct)
  finally show ?case .
qed

lemma stirling_code [code]:
  "stirling n k =
    (if k = 0 then (if n = 0 then 1 else 0)
     else if k > n then 0
     else if k = n then 1
     else stirling_row n ! k)"
  by (simp add: nth_stirling_row)

end


theory SetUtils
  imports Main
begin

\<comment> \<open>TODO use Inf instead of Min where necessary.\<close>

\<comment> \<open>TODO can be replaced by @{term "card_Un_disjoint (\<lbrakk>finite A; finite B; A \<inter> B = {}\<rbrakk>
  \<Longrightarrow> card (A \<union> B) = card A + card B)"} ?\<close>
lemma card_union': "(finite s) \<and> (finite t) \<and> (disjnt s t) \<Longrightarrow> (card (s \<union> t) = card s + card t)"
  by (simp add: card_Un_disjoint disjnt_def)

lemma CARD_INJ_IMAGE_2:
  fixes f s
  assumes "finite s" "(\<forall>x y. ((x \<in> s) \<and> (y \<in> s)) \<longrightarrow> ((f x = f y) \<longleftrightarrow> (x = y)))"
  shows "(card (f ` s) = card s)"
proof -
  {
    fix x y
    assume "x \<in> s" "y \<in> s"
    then have "f x = f y \<longrightarrow> x = y"
      using assms(2)
      by blast
  }
  then have "inj_on f s"
    by (simp add: inj_onI)
  then show ?thesis
    using assms(1) inj_on_iff_eq_card
    by blast
qed

lemma scc_main_lemma_x: "\<And>s t x. (x \<in> s) \<and> \<not>(x \<in> t) \<Longrightarrow> \<not>(s = t)"
  by blast

lemma neq_funs_neq_images:
  fixes s
  assumes "\<forall>x. x \<in> s \<longrightarrow> (\<forall>y. y \<in> s \<longrightarrow> f1 x \<noteq> f2 y)" "\<exists>x. x \<in> s"
  shows "f1 ` s \<noteq> f2 ` s"
  using assms
  by blast

subsection "Sets of Numbers"

\<comment> \<open>TODO
  Is '<=' natural number lte or overloaded?
  If it's overloaded for reals, this might be wrong (e.g. the real set s = [0; 1] is not finite even
though @{term "\<forall> x \<in> s. x \<le> 1"} holds).\<close>
lemma mems_le_finite_i:
  fixes s :: "nat set" and k :: nat
  shows "(\<forall> x. x \<in> s \<longrightarrow> x \<le> k) \<Longrightarrow> finite s"
proof -
  assume P: "(\<forall> x. x \<in> s \<longrightarrow> x \<le> k)"
  let ?f = "id :: nat \<Rightarrow> nat"
  let ?S = "{i. i \<le> k}"
  have "s \<subseteq> ?S" using P by blast
  moreover have "?f ` ?S = ?S" by auto
  moreover have "finite ?S" using nat_seg_image_imp_finite by auto
  moreover have "finite s" using calculation finite_subset by auto
  ultimately show ?thesis by auto
qed
lemma mems_le_finite:
  fixes s :: "nat set" and k :: nat
  shows "\<And>(s :: nat set) k. (\<forall> x. x \<in> s \<longrightarrow> x \<le> k) \<Longrightarrow> finite s"
  using mems_le_finite_i by auto

\<comment> \<open>NOTE translated `s` to `nat set` (more generality wasn't required.).\<close>
lemma mem_le_imp_MIN_le:
  fixes s :: "nat set" and k :: nat
  assumes "\<exists>x. (x \<in> s) \<and> (x \<le> k)"
  shows "(Inf s \<le> k)"
proof -
  from assms obtain x where 1: "x \<in> s" "x \<le> k"
    by blast
  {
    assume C: "Inf s > k"
    then have "Inf s > x" using 1(2)
      by fastforce
    then have False
      using 1(1) cInf_lower leD
      by fast
  }
  then show ?thesis
    by fastforce
qed

\<comment> \<open>NOTE
  nat --> bool is the type of a HOL4 set and was translated to 'nat set'.\<close>
\<comment> \<open>NOTE
  We cannot use 'Min' instead of 'Inf' because there is no indication that '{n. s n}' will be
finite. Without that @{term "Min {n. s n} \<in> {n. s n}"} is not necessarily true.\<close>
lemma mem_lt_imp_MIN_lt:
  fixes s :: "nat set" and k :: nat
  assumes "(\<exists>x. x \<in> s \<and> x < k)"
  shows "(Inf s) < k"
proof -
  obtain x where 1: "x \<in> s" "x < k"
    using assms
    by blast
  then have 2: "s \<noteq> {}"
    by blast
  then have "Inf s \<in> s"
    using Inf_nat_def LeastI
    by force
  moreover have "\<forall>x\<in>s. Inf s \<le> x"
    by (simp add: cInf_lower)
  ultimately show "(Inf s) < k"
    using assms leD
    by force
qed

\<comment> \<open>NOTE type for 'k' had to be fixed (type unordered error; also not true for e.g. real sets).\<close>
lemma bound_child_parent_neq_mems_state_set_neq_len:
  fixes s and k :: nat
  assumes "(\<forall>x. x \<in> s \<longrightarrow> x < k)"
  shows "finite s"
  using assms bounded_nat_set_is_finite
  by blast

lemma bound_main_lemma_2: "\<And>(s :: nat set) k. (s \<noteq> {}) \<and> (\<forall>x. x \<in> s \<longrightarrow> x \<le> k) \<Longrightarrow> Sup s \<le> k"
proof -
  fix s :: "nat set" and k
  {
    assume P1: "s \<noteq> {}"
    assume P2: "(\<forall>x. x \<in> s \<longrightarrow> x \<le> k)"
    have "finite s" using P2 mems_le_finite by auto
    moreover have "Max s \<in> s" using P1 calculation Max_in by auto
    moreover have "Max s \<le> k" using P2 calculation by auto
  }
  then show "(s \<noteq> {}) \<and> (\<forall>x. x \<in> s \<longrightarrow> x \<le> k) \<Longrightarrow> Sup s \<le> k"
    by (simp add: Sup_nat_def)
qed

\<comment> \<open>NOTE type of 'k' fixed to nat to be able to use 'bound\_child\_parent\_neq\_mems\_state\_set\_neq\_len'.\<close>
lemma bound_child_parent_not_eq_last_diff_paths: "\<And>s (k :: nat).
  (s \<noteq> {})
  \<Longrightarrow> (\<forall>x. x \<in> s \<longrightarrow> x < k)
  \<Longrightarrow> Sup s < k
"
  by (simp add: Sup_nat_def bound_child_parent_neq_mems_state_set_neq_len)

lemma FINITE_ALL_DISTINCT_LISTS_i:
  fixes P
  assumes "finite P"
  shows "
    {p. distinct p \<and> set p \<subseteq> P}
    = {[]} \<union> (\<Union> ((\<lambda>e. {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}) ` P))"
proof -
  let ?A="{p. distinct p \<and> set p \<subseteq> P }"
  let ?B="{[]} \<union> (\<Union> ((\<lambda>e. {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}) ` P))"
  {
    {
      fix a
      assume P: "a \<in> ?A"
      then have "a \<in> ?B"
      proof (cases a)
        text \<open> The empty list is distinct and its corresponding set is the empty set which is a
            trivial subset of `?B`. The `Nil` case can therefore be derived by automation. \<close>
        case (Cons h list)
        {
          let ?b'="h"
          {
            from P have "set a \<subseteq> P"
              by simp
            then have "set list \<subseteq> (P - {h})"
              using P dual_order.trans local.Cons
              by auto
          }
          moreover from P Cons
          have "distinct list"
            by force
          ultimately have "a \<in> ((\<lambda>e. {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}) ?b')"
            using Cons
            by blast
          moreover {
            from P Cons have "?b' \<in> set a"
              by simp
            moreover from P have "set a \<subseteq> P"
              by simp
            ultimately have "?b' \<in> P"
              by auto
          }
          ultimately have
            "\<exists>b' \<in> P. a \<in> ((\<lambda>e. {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}) b')"
            by meson
        }
        then obtain b' where
          "b' \<in> P" "a \<in> ((\<lambda>e. {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}) b')"
          by blast
        then show ?thesis
          by blast
      qed blast
    }
    then have "?A \<subseteq> ?B"
      by auto
  }
  moreover {
    {
      fix b
      assume P: "b \<in> ?B"
      have "b \<in> ?A"
        text \<open> The empty list is in `?B` by construction. The `Nil` case can therefore be derived
          straightforwardly.\<close>
      proof (cases b)
        case (Cons a list)
        from P Cons obtain b' where a:
          "b' \<in> P" "b \<in> {b' # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {b'})}"
          by fast
        then obtain p0 where b: "b = b' # p0" "distinct p0" "set p0 \<subseteq> (P - {b'})"
          by blast
        then have "distinct (b' # p0)"
          by (simp add: subset_Diff_insert)
        moreover have "set (b' # p0) \<subseteq> P"
          using a(1) b(3)
          by auto
        ultimately show ?thesis
          using b(1)
          by fast
      qed simp
    }
    then have "?B \<subseteq> ?A"
      by blast
  }
  ultimately show ?thesis
    using set_eq_subset
    by blast
qed

lemma FINITE_ALL_DISTINCT_LISTS:
  fixes P
  assumes "finite P"
  shows "finite {p. distinct p \<and> set p \<subseteq> P}"
  using assms
proof (induction "card P" arbitrary: P)
  case 0
  then have "P = {}"
    by force
  then show ?case
    using 0
    by simp
next
  case (Suc x)
  {
    text \<open> Proof the finiteness of the union by proving both sets of the union are finite. The
      singleton set `{[]}` is trivially finite. \<close>
    {
      {
        fix e
        assume P: "e \<in> P"
        have "
          {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> P - {e}}
          = (\<lambda>p. e # p) ` { p. distinct p \<and> set p \<subseteq> P - {e}}"
          by blast
        moreover {
          let ?P'="P - {e}"
          from Suc.prems
          have "finite ?P'"
            by blast
          text \<open> The finiteness can now be shown using the induction hypothesis. However `e` might
            already be contained in `?P`, so we have to split cases first. \<close>
          have "finite ((\<lambda>p. e # p) ` {p. distinct p \<and> set p \<subseteq> ?P'})"
          proof (cases "e \<in> P")
            case True
            then have "x = card ?P'" using Suc.prems Suc(2)
              by fastforce
            moreover from Suc.prems
            have "finite ?P'"
              by blast
            ultimately show ?thesis
              using Suc(1)
              by blast
          next
            case False
            then have "?P' = P"
              by simp
            then have "finite {p. distinct p \<and> set p \<subseteq> ?P'}"
              using False P by linarith
            then show ?thesis
              using finite_imageI
              by blast
          qed
        }
        ultimately have "finite {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}"
          by argo
      }
      then have "finite (\<Union> ((\<lambda>e. {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}) ` P))"
        using Suc.prems
        by blast
    }
    then have
      "finite ({[]} \<union> (\<Union> ((\<lambda>e. {e # p0 | p0. distinct p0 \<and> set p0 \<subseteq> (P - {e})}) ` P)))"
      using finite_Un
      by blast
  }
  then show ?case
    using FINITE_ALL_DISTINCT_LISTS_i[OF Suc.prems]
    by force
qed

lemma subset_inter_diff_empty:
  assumes "s \<subseteq> t"
  shows "(s \<inter> (u - t) = {})"
  using assms
  by auto

end


theory Chapter05_06
imports Chapter04
begin

primrec is_val :: "expr => bool"
where "is_val (Var v) = False"
    | "is_val (Num x) = True"
    | "is_val (Str s) = True"
    | "is_val (Plus e1 e2) = False"
    | "is_val (Times e1 e2) = False"
    | "is_val (Cat e1 e2) = False"
    | "is_val (Len e) = False"
    | "is_val (Let e1 e2) = False"

inductive eval :: "expr => expr => bool"
where eval_plus_1 [simp]: "eval (Plus (Num n1) (Num n2)) (Num (n1 + n2))"
    | eval_plus_2 [simp]: "eval e1 e1' ==> eval (Plus e1 e2) (Plus e1' e2)"
    | eval_plus_3 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Plus e1 e2) (Plus e1 e2')"
    | eval_times_1 [simp]: "eval (Times (Num n1) (Num n2)) (Num (n1 * n2))"
    | eval_times_2 [simp]: "eval e1 e1' ==> eval (Times e1 e2) (Times e1' e2)"
    | eval_times_3 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Times e1 e2) (Times e1 e2')"
    | eval_cat_1 [simp]: "eval (Cat (Str n1) (Str n2)) (Str (n1 @ n2))"
    | eval_cat_2 [simp]: "eval e1 e1' ==> eval (Cat e1 e2) (Cat e1' e2)"
    | eval_cat_3 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Cat e1 e2) (Cat e1 e2')"
    | eval_len_1 [simp]: "eval (Len (Str n1)) (Num (int (length n1)))"
    | eval_len_2 [simp]: "eval e1 e1' ==> eval (Len e1) (Len e1')"
    | eval_let_1 [simp]: "is_val e1 ==> eval (Let e1 e2) (subst e1 first e2)"
    | eval_let_2 [simp]: "eval e1 e1' ==> eval (Let e1 e2) (Let e1' e2)"

lemma canonical_num: "is_val e ==> typecheck gam e NumType ==> EX n. e = Num n"
by (induction e, auto)

lemma canonical_str: "is_val e ==> typecheck gam e StrType ==> EX n. e = Str n"
by (induction e, auto)

theorem preservation: "eval e e' ==> typecheck gam e t ==> typecheck gam e' t"
by (induction e e' arbitrary: t rule: eval.induct, fastforce+)

theorem progress: "typecheck gam e t ==> gam = empty_env ==> is_val e | (EX e'. eval e e')"
proof (induction gam e t rule: typecheck.induct)
case tc_var
  thus ?case by simp
next case tc_str
  thus ?case by simp
next case tc_num
  thus ?case by simp
next case (tc_plus gam e1 e2)
  thus ?case by (metis eval_plus_1 eval_plus_2 eval_plus_3 canonical_num)
next case (tc_times gam e1 e2)
  thus ?case by (metis eval_times_1 eval_times_2 eval_times_3 canonical_num)
next case (tc_cat gam e1 e2)
  thus ?case by (metis eval_cat_1 eval_cat_2 eval_cat_3 canonical_str)
next case (tc_len gam e)
  thus ?case by (metis eval_len_1 eval_len_2 canonical_str)
next case (tc_let gam e1 t1 e2 t2)
  thus ?case by (metis eval_let_1 eval_let_2)
qed

end


(*  Title:      FOL/ex/Miniscope.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

Classical First-Order Logic.
Conversion to nnf/miniscope format: pushing quantifiers in.
Demonstration of formula rewriting by proof.
*)

theory Miniscope
imports FOL
begin

lemmas ccontr = FalseE [THEN classical]

subsection {* Negation Normal Form *}

subsubsection {* de Morgan laws *}

lemma demorgans:
  "~(P&Q) <-> ~P | ~Q"
  "~(P|Q) <-> ~P & ~Q"
  "~~P <-> P"
  "!!P. ~(ALL x. P(x)) <-> (EX x. ~P(x))"
  "!!P. ~(EX x. P(x)) <-> (ALL x. ~P(x))"
  by blast+

(*** Removal of --> and <-> (positive and negative occurrences) ***)
(*Last one is important for computing a compact CNF*)
lemma nnf_simps:
  "(P-->Q) <-> (~P | Q)"
  "~(P-->Q) <-> (P & ~Q)"
  "(P<->Q) <-> (~P | Q) & (~Q | P)"
  "~(P<->Q) <-> (P | Q) & (~P | ~Q)"
  by blast+

(* BEWARE: rewrite rules for <-> can confuse the simplifier!! *)

subsubsection {* Pushing in the existential quantifiers *}

lemma ex_simps:
  "(EX x. P) <-> P"
  "!!P Q. (EX x. P(x) & Q) <-> (EX x. P(x)) & Q"
  "!!P Q. (EX x. P & Q(x)) <-> P & (EX x. Q(x))"
  "!!P Q. (EX x. P(x) | Q(x)) <-> (EX x. P(x)) | (EX x. Q(x))"
  "!!P Q. (EX x. P(x) | Q) <-> (EX x. P(x)) | Q"
  "!!P Q. (EX x. P | Q(x)) <-> P | (EX x. Q(x))"
  by blast+

subsubsection {* Pushing in the universal quantifiers *}

lemma all_simps:
  "(ALL x. P) <-> P"
  "!!P Q. (ALL x. P(x) & Q(x)) <-> (ALL x. P(x)) & (ALL x. Q(x))"
  "!!P Q. (ALL x. P(x) & Q) <-> (ALL x. P(x)) & Q"
  "!!P Q. (ALL x. P & Q(x)) <-> P & (ALL x. Q(x))"
  "!!P Q. (ALL x. P(x) | Q) <-> (ALL x. P(x)) | Q"
  "!!P Q. (ALL x. P | Q(x)) <-> P | (ALL x. Q(x))"
  by blast+

lemmas mini_simps = demorgans nnf_simps ex_simps all_simps

ML {*
val mini_ss = simpset_of (@{context} addsimps @{thms mini_simps});
fun mini_tac ctxt = resolve_tac @{thms ccontr} THEN' asm_full_simp_tac (put_simpset mini_ss ctxt);
*}

end


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
verification components.\<close>

theory HS_VC_Examples
  imports HS_VC_Spartan

begin

subsubsection \<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma pendulum_dyn: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |EVOL \<phi> G T] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by force

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |x\<acute>= f & G] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by (auto intro!: diff_invariant_rules poly_derivatives)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |x\<acute>=f & G] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by (force simp: local_flow.fbox_g_ode[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection \<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assigntment that
flips the velocity, thus it is a completely elastic collision with the ground. We use @{text "s$1"}
to ball's height and @{text "s$2"} for its velocity. We prove that the ball remains above ground
and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma bouncing_ball_inv: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (x\<acute>=(f g) & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  apply(rule fbox_loopI, simp_all, force, force simp: bb_real_arith)
  by (rule fbox_g_odei) (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> + v) * (g * \<tau> + v) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0" by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    by (metis (mono_tags, hide_lams) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    apply(subst power2_sum) by (metis (no_types, hide_lams) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 * g * h + (g * \<tau> + v) * (g * \<tau> + v) = 0"
    by (simp add: add.commute distrib_right power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> + v) * (g * \<tau> + v)" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 = 2 * g * h + s$2 * s$2)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  by (rule fbox_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (x\<acute>=(f g) & (\<lambda> s. s$1 \<ge> 0)) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 = 2 * g * h + s$2 * s$2)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  by (rule fbox_loopI) (auto simp: bb_real_arith local_flow.fbox_g_ode[OF local_flow_ball])

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection \<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas fbox_temp_dyn = local_flow.fbox_g_ode_ivl[OF local_flow_temp _ UNIV_I]

lemma thermostat:
  assumes "a > 0" and "0 \<le> t" and "0 < Tmin" and "Tmax < L"
  shows "(\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0) \<le>
  |LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>=(f a 0) & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a) on {0..t} UNIV @ 0)
    ELSE (x\<acute>=(f a L) & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a) on {0..t} UNIV @ 0)) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1))]
  (\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax)"
  apply(rule fbox_loopI, simp_all add: fbox_temp_dyn[OF assms(1,2)] le_fun_def)
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

end