theory Submission
imports Defs
begin

subsection \<open>Some auxiliary lemmas on lists\<close>

lemma takeWhile_replicate_append:
  "takeWhile P (replicate n x @ ys) = (if P x \<or> n = 0 then replicate n x @ takeWhile P ys else [])"
  by (induction n) auto

lemma dropWhile_replicate_append:
  "dropWhile P (replicate n x @ ys) = (if P x \<or> n = 0 then dropWhile P ys else replicate n x @ ys)"
  by (induction n) auto

lemma takeWhile_NilI:
  assumes "xs = [] \<or> \<not>P (hd xs)"
  shows   "takeWhile P xs = []"
  using assms by (cases xs) auto

lemma dropWhile_selfI:
  assumes "xs = [] \<or> \<not>P (hd xs)"
  shows   "dropWhile P xs = xs"
  using assms by (cases xs) auto

subsection \<open>Lists with distinct adjoint elements\<close>

fun distinct_adj
  where "distinct_adj [] = True" |
        "distinct_adj [_] = True" |
        "distinct_adj (x # y # xs) \<longleftrightarrow> x \<noteq> y \<and> distinct_adj (y # xs)"

lemma distinct_adj_ConsI:
  assumes "xs = [] \<or> x \<noteq> hd xs" "distinct_adj xs"
  shows   "distinct_adj (x # xs)"
  using assms by (cases xs) auto

lemma distinct_adj_Cons: "distinct_adj (x # xs) \<longleftrightarrow> xs = [] \<or> x \<noteq> hd xs \<and> distinct_adj xs"
  by (cases xs) auto

lemma distinct_adj_append:
  assumes "xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys" "distinct_adj xs" "distinct_adj ys"
  shows   "distinct_adj (xs @ ys)"
  using assms
  by (induction xs rule: distinct_adj.induct)
     (auto split: if_splits intro!: distinct_adj_ConsI)

lemma distinct_adj_rev: "distinct_adj xs \<Longrightarrow> distinct_adj (rev xs)"
proof (induction xs)
  case (Cons x xs)
  show ?case using Cons
    by (cases "xs = []") (auto intro!: distinct_adj_append simp: last_rev distinct_adj_Cons)
qed auto

subsection \<open>Reversing run-length encoding\<close>

definition unrle where "unrle = concat \<circ> map (\<lambda>(x, n). replicate n x)"

lemma unrle_Nil [simp]: "unrle (xs @ ys) = unrle xs @ unrle ys"
  by (simp add: unrle_def)

lemma unrle_append [simp]: "unrle [] = []"
  by (simp add: unrle_def)

lemma unrle_Cons [simp]: "unrle ((x, n) # xs) = replicate n x @ unrle xs"
  by (simp add: unrle_def)

lemma unrle_rev [simp]: "unrle (rev xs) = rev (unrle xs)"
  by (induction xs) auto

subsection \<open>Valid RLE encodings\<close>

definition valid
  where "valid xs \<longleftrightarrow> distinct_adj (map fst xs) \<and> 0 \<notin> snd ` set xs"

lemma valid_append:
  assumes "xs = [] \<or> ys = [] \<or> fst (last xs) \<noteq> fst (hd ys)" "valid xs" "valid ys"
  shows   "valid (xs @ ys)"
  using assms unfolding valid_def
  by (auto intro!: distinct_adj_append simp: hd_map last_map)

lemma valid_rev: "valid xs \<Longrightarrow> valid (rev xs)"
  using distinct_adj_rev[of "map fst xs"]
  by (auto simp: valid_def rev_map)

subsection \<open>Correctness of \<^const>\<open>unrle\<close>\<close>

lemma hd_rle: "xs \<noteq> [] \<Longrightarrow> hd (rle xs) = (hd xs, length (takeWhile (\<lambda>y. y = hd xs) xs))"
  by (cases xs) auto

lemma rle_eq_Nil_iff [simp]: "rle xs = [] \<longleftrightarrow> xs = []"
  by (cases xs) auto

lemma distinct_adj_rle: "distinct_adj (map fst (rle xs))"
  by (induction xs rule: rle.induct)
     (use hd_dropWhile in \<open>force intro!: distinct_adj_ConsI simp: hd_map hd_rle\<close>)+

lemma fst_hd_rle [simp]: "xs \<noteq> [] \<Longrightarrow> fst (hd (rle xs)) = hd xs"
  by (cases xs) auto

lemma fst_last_rle [simp]: "xs \<noteq> [] \<Longrightarrow> fst (last (rle xs)) = last xs"
  by (induction xs rule: rle.induct) (use last_in_set in \<open>force simp: dropWhile_last\<close>)+

lemma snd_rle_pos: "0 \<notin> snd ` set (rle xs)"
  by (induction xs rule: rle.induct) auto

lemma valid_rle [intro]: "valid (rle xs)"
  unfolding valid_def using distinct_adj_rle[of xs] snd_rle_pos[of xs]
  by auto

lemma hd_unrle:
  assumes "xs \<noteq> []" "valid xs"
  shows   "hd (unrle xs) = fst (hd xs)"
  using assms by (cases xs) (auto simp: valid_def unrle_def distinct_adj_Cons)

lemma unrle_eq_Nil_iff [simp]:
  assumes "valid xs"
  shows   "unrle xs = [] \<longleftrightarrow> xs = []"
proof (cases xs)
  case (Cons xn xs')
  obtain x n where [simp]: "xn = (x, n)"
    by (cases xn) auto
  from assms have "n > 0"
    by (auto simp: valid_def Cons)
  thus ?thesis
    by (auto simp: Cons)
qed auto

lemma unrle_rle [simp]: "unrle (rle xs) = xs"
proof (induction xs rule: rle.induct)
  case (2 x xs)
  have "unrle (rle (x # xs)) =
          x # replicate (length (takeWhile (\<lambda>y. y = x) xs)) x @ dropWhile (\<lambda>y. y = x) xs"
    using 2 by simp
  also have "replicate (length (takeWhile (\<lambda>y. y = x) xs)) x = takeWhile (\<lambda>y. y = x) xs"
    by (induction xs) auto
  also have "\<dots> @ dropWhile (\<lambda>y. y = x) xs = xs"
    by simp
  finally show ?case .
qed auto

lemma rle_unrle: "rle (unrle xs) = xs" if "valid xs"
  using that
proof (induction xs)
  case (Cons xn xs)
  obtain x n where [simp]: "xn = (x, n)" by (cases xn) auto
  have "valid xs"
    using Cons(2) by (auto simp: valid_def distinct_adj_Cons)
  from Cons have "n > 0"
    by (auto simp: valid_def)
  have "rle (unrle (xn # xs)) = rle (replicate n x @ unrle xs)"
    by simp
  also have "replicate n x = x # replicate (n - 1) x"
    using \<open>n > 0\<close> by (cases n) auto
  also have "rle (\<dots> @ unrle xs) =
               (x, Suc (length (takeWhile (\<lambda>y. y = x) (replicate (n - Suc 0) x @ unrle xs)))) #
               rle (dropWhile (\<lambda>y. y = x) (replicate (n - Suc 0) x @ unrle xs))"
    by simp
  also have "takeWhile (\<lambda>y. y = x) (replicate (n - Suc 0) x @ unrle xs) =
             replicate (n - Suc 0) x @ takeWhile (\<lambda>y. y = x) (unrle xs)"
    by (simp add: takeWhile_replicate_append)
  also have "dropWhile (\<lambda>y. y = x) (replicate (n - Suc 0) x @ unrle xs) = dropWhile (\<lambda>y. y = x) (unrle xs)"
    by (simp add: dropWhile_replicate_append)
  also have *: "x \<noteq> fst (hd xs)" if "xs \<noteq> []"
    using Cons that by (auto simp: valid_def distinct_adj_Cons hd_map)
  hence "takeWhile (\<lambda>y. y = x) (unrle xs) = []"
    using \<open>valid xs\<close>
    by (intro takeWhile_NilI) (auto simp: hd_unrle)
  also have "Suc (length (replicate (n - Suc 0) x @ [])) = n"
    using \<open>n > 0\<close> by simp
  also have "dropWhile (\<lambda>y. y = x) (unrle xs) = unrle xs"
    using \<open>valid xs\<close> * by (intro dropWhile_selfI) (auto simp: hd_unrle)
  also have "rle (unrle xs) = xs"
    by (intro Cons.IH) fact
  finally show ?case by simp
qed auto

lemma rle_unique:
  assumes "unrle ys = xs" and "valid ys"
  shows   "rle xs = ys"
  using rle_unrle assms by blast

subsection \<open>Main proofs\<close>

lemma rle_append: "xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys \<Longrightarrow> rle (xs @ ys) = rle xs @ rle ys"
  by (rule rle_unique) (auto intro!: valid_append)

lemma rle_rev [simp]: "rle (rev xs) = rev (rle xs)"
  by (rule rle_unique) (auto intro: valid_rev)

(* Given the append lemma show the reverse lemma - gives 70% of the points.
   Note: While this lemma gives more points, it might actually be easier to prove *)
lemma rle_rev_if_rle_append: "(xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys \<Longrightarrow> rle (xs @ ys) = rle xs @ rle ys)
       \<Longrightarrow> rle (rev xs) = rev (rle xs)"
  by simp

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>A simple cookbook example how to eliminate choice in programs.\<close>

theory Execute_Choice
imports Main "HOL-Library.AList_Mapping"
begin

text \<open>
  A trivial example:
\<close>

definition valuesum :: "('a, 'b :: ab_group_add) mapping \<Rightarrow> 'b" where
  "valuesum m = (\<Sum>k \<in> Mapping.keys m. the (Mapping.lookup m k))"

text \<open>
  Not that instead of defining @{term valuesum} with choice, we define it
  directly and derive a description involving choice afterwards:
\<close>

lemma valuesum_rec:
  assumes fin: "finite (dom (Mapping.lookup m))"
  shows "valuesum m = (if Mapping.is_empty m then 0 else
    let l = (SOME l. l \<in> Mapping.keys m) in the (Mapping.lookup m l) + valuesum (Mapping.delete l m))"
proof (cases "Mapping.is_empty m")
  case True then show ?thesis by (simp add: is_empty_def keys_def valuesum_def)
next
  case False
  then have l: "\<exists>l. l \<in> dom (Mapping.lookup m)" unfolding is_empty_def by transfer auto
  then have "(let l = SOME l. l \<in> dom (Mapping.lookup m) in
     the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
       (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
  proof (rule someI2_ex)
    fix l
    note fin
    moreover assume "l \<in> dom (Mapping.lookup m)"
    moreover obtain A where "A = dom (Mapping.lookup m) - {l}" by simp
    ultimately have "dom (Mapping.lookup m) = insert l A" and "finite A" and "l \<notin> A" by auto
    then show "(let l = l
        in the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
        (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
      by simp
   qed
  then show ?thesis unfolding is_empty_def valuesum_def by transfer simp
qed

text \<open>
  In the context of the else-branch we can show that the exact choice is
  irrelvant; in practice, finding this point where choice becomes irrelevant is the
  most difficult thing!
\<close>

lemma valuesum_choice:
  "finite (Mapping.keys M) \<Longrightarrow> x \<in> Mapping.keys M \<Longrightarrow> y \<in> Mapping.keys M \<Longrightarrow>
    the (Mapping.lookup M x) + valuesum (Mapping.delete x M) =
    the (Mapping.lookup M y) + valuesum (Mapping.delete y M)"
  unfolding valuesum_def  by transfer (simp add: sum_diff)

text \<open>
  Given \<open>valuesum_rec\<close> as initial description, we stepwise refine it to something executable;
  first, we formally insert the constructor @{term Mapping} and split the one equation into two,
  where the second one provides the necessary context:
\<close>

lemma valuesum_rec_Mapping:
  shows [code]: "valuesum (Mapping []) = 0"
  and "valuesum (Mapping (x # xs)) = (let l = (SOME l. l \<in> Mapping.keys (Mapping (x # xs))) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
  by (simp_all add: valuesum_rec finite_dom_map_of is_empty_Mapping null_def)

text \<open>
  As a side effect the precondition disappears (but note this has nothing to do with choice!).
  The first equation deals with the uncritical empty case and can already be used for code generation.

  Using \<open>valuesum_choice\<close>, we are able to prove an executable version of @{term valuesum}:
\<close>

lemma valuesum_rec_exec [code]:
  "valuesum (Mapping (x # xs)) = (let l = fst (hd (x # xs)) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
proof -
  let ?M = "Mapping (x # xs)"
  let ?l1 = "(SOME l. l \<in> Mapping.keys ?M)"
  let ?l2 = "fst (hd (x # xs))"
  have "finite (Mapping.keys ?M)" by (simp add: keys_Mapping)
  moreover have "?l1 \<in> Mapping.keys ?M"
    by (rule someI) (auto simp add: keys_Mapping)
  moreover have "?l2 \<in> Mapping.keys ?M"
    by (simp add: keys_Mapping)
  ultimately have "the (Mapping.lookup ?M ?l1) + valuesum (Mapping.delete ?l1 ?M) =
    the (Mapping.lookup ?M ?l2) + valuesum (Mapping.delete ?l2 ?M)"
    by (rule valuesum_choice)
  then show ?thesis by (simp add: valuesum_rec_Mapping)
qed

text \<open>
  See how it works:
\<close>

value "valuesum (Mapping [(''abc'', (42::int)), (''def'', 1705)])"

end


header{* One-Step Methods *}
theory One_Step_Method
imports
  "../IVP/Initial_Value_Problem"
begin

text{*\label{sec:osm}*}

subsection{* Grids *}
text{*\label{sec:osm-grid}*}

locale grid =
  fixes t::"nat \<Rightarrow> real"
  assumes steps: "\<And>i. t i \<le> t (Suc i)"
begin

lemmas grid = steps

lemma grid_ge_min:
  shows "t 0 \<le> t j"
  using assms
proof (induct j)
  fix j
  assume "t 0 \<le> t j"
  also from grid have "t j \<le> t (Suc j)" .
  finally show "t 0 \<le> t (Suc j)" .
qed simp

lemma grid_mono:
  assumes "j \<le> n"
  shows "t j \<le> t n"
using assms
proof (induct rule: inc_induct)
  fix j
  assume "j < n" "t (Suc j) \<le> t n"
  moreover
  with grid have "t j \<le> t (Suc j)" by auto
  ultimately
  show "t j \<le> t n" by simp
qed simp

text {* The size of the step from point j to j+1 in grid t *}

definition stepsize
where "stepsize j = t (Suc j) - t j"

lemma grid_stepsize_nonneg:
  shows "stepsize j \<ge> 0"
  using assms grid unfolding stepsize_def
  by (simp add: field_simps order_less_imp_le)

lemma grid_stepsize_sum:
  shows "(\<Sum>i\<in>{0..<n}. stepsize i) = t n - t 0"
  by (induct n) (simp_all add: stepsize_def)

definition max_stepsize
where "max_stepsize n = Max (stepsize ` {0..n})"

lemma max_stepsize_ge_stepsize:
  assumes "j \<le> n"
  shows "max_stepsize n \<ge> stepsize j"
  using assms by (auto simp: max_stepsize_def)

lemma max_stepsize_nonneg:
  shows "max_stepsize n \<ge> 0"
  using grid_stepsize_nonneg[of 0]
    max_stepsize_ge_stepsize[of 0 n]
  by simp

lemma max_stepsize_mono:
  assumes "j \<le> n"
  shows "max_stepsize j \<le> max_stepsize n"
  using assms by (auto intro!: Max_mono simp: max_stepsize_def)

definition min_stepsize
where "min_stepsize n = Min (stepsize ` {0..n})"

lemma min_stepsize_le_stepsize:
  assumes "j \<le> n"
  shows "min_stepsize n \<le> stepsize j"
  using grid assms
  by (auto simp add: min_stepsize_def)

end

lemma (in grid) grid_interval_notempty: "t 0 \<le> t n" using grid_ge_min[of n] .

subsection{* Definition *}
text{*\label{sec:osm-definition}*}

text{* Discrete evolution (noted @{text \<Psi>}) using incrementing function @{term incr} *}

definition discrete_evolution
where "discrete_evolution incr t1 t0 x = x + (t1 - t0) *\<^sub>R incr (t1 - t0) t0 x"

text {* Using the discrete evolution @{text \<Psi>} between each two points of the
  grid, define a function over the whole grid *}

fun grid_function
where
  "grid_function \<Psi> x0 t 0 = x0"
| "grid_function \<Psi> x0 t (Suc j) = \<Psi> (t (Suc j)) (t j) (grid_function \<Psi> x0 t j)"

subsection {* Consistency *}
text{*\label{sec:osm-consistent}*}

definition "consistent x t T B p incr \<longleftrightarrow>
  (\<forall>h\<ge>0. t + h \<le> T \<longrightarrow> dist (x (t + h)) (discrete_evolution incr (t + h) t (x t)) \<le> B * h ^ (p + 1))"

lemma consistentD:
  assumes "consistent x t T B p incr"
  assumes "h \<ge> 0" "t + h \<le> T"
  shows "dist (x (t + h)) (discrete_evolution incr (t + h) t (x t)) \<le> B * h ^ (p + 1)"
  using assms
  unfolding consistent_def by auto

lemma consistentI[intro]:
  fixes x::"real\<Rightarrow>'a::real_normed_vector"
  assumes "\<And>h. h > 0 \<Longrightarrow> t + h \<le> T \<Longrightarrow>
    dist (x (t + h)) (discrete_evolution incr (t + h) t (x t)) \<le> B * h ^ (p + 1)"
  shows "consistent x t T B p incr"
  using assms unfolding consistent_def
  by safe (case_tac "h = 0", auto simp: discrete_evolution_def)

lemma consistent_imp_nonneg_constant:
  assumes "consistent x t T B p incr"
  assumes "t < T"
  shows "B \<ge> 0"
proof -
  from assms have "T - t > 0" by simp
  have "0 \<le> dist (x T) (discrete_evolution incr T t (x t))" by simp
  also from assms
  have "... \<le> B * (T - t) ^ (p + 1)"
    unfolding consistent_def by (auto dest: spec[where x="T - t"])
  finally show ?thesis using zero_less_power[OF `T - t > 0`, of "p+1"]
    by (simp add: zero_le_mult_iff)
qed

lemma stepsize_inverse:
  assumes "L \<ge> 0" "h \<ge> 0" "B \<ge> 0" "r \<ge> 0" "p > 0" "T1 \<ge> T2" "T2 \<ge> 0"
  assumes max_step: "h \<le> root p (r * L / B / (exp (L * T1 + 1) - 1))"
  shows  "B / L * (exp (L * T2 + 1) - 1) * h ^ p \<le> r"
proof -
  { assume "L = 0" hence ?thesis using `r \<ge> 0` by simp
  } moreover {
    assume B_pos: "B > 0" assume "L > 0"
    from `0 \<le> T2` `T1 \<ge> T2` have "T1 \<ge> 0" by simp
    hence eg: "(exp (L * T1 + 1) - 1) > 0" using `L > 0`
      by (auto intro!: add_nonneg_pos simp add: diff_less_iff)
    have "B * (h ^ p * (exp (L * T2 + 1) - 1)) / L \<le>
      B * (root p (r * L / B / (exp (L * T1 + 1) - 1)) ^ p
      * (exp (L * T2 + 1) - 1)) / L"
      using assms
      by (auto simp add: ge_iff_diff_ge_0[symmetric] divide_simps
               intro!: mult_left_mono mult_right_mono power_mono)
    also
    have "root p (r * L / B / (exp (L * T1 + 1) - 1)) ^ p =
      (r * L / B / (exp (L * T1 + 1) - 1))"
      using assms B_pos `T1 \<ge> 0` `L > 0` `B > 0`
      by (subst real_root_pow_pos2[OF `p > 0`]) (auto simp add: diff_less_iff
        intro!: divide_nonneg_pos add_nonneg_pos mult_pos_pos)
    finally
    have "B * (h ^ p * (exp (L * T2 + 1) - 1)) / L \<le>
      r * ((exp (L * T2 + 1) - 1) / (exp (L * T1 + 1) - 1))"
      using B_pos `L > 0` eg `r \<ge> 0`
      by (simp add: ac_simps)
    also have "... \<le> r" using `T1 \<ge> T2` `0 \<le> T2`
    proof (cases "T1 = 0")
      assume "T1 \<noteq> 0" with `T1 \<ge> T2` `0 \<le> T2` have "T1 > 0" by simp
      show ?thesis using `L > 0` `0 \<le> T2` `T1 \<ge> 0` add_0_left `T1 > 0` `T1 \<ge> T2`
        by (intro mult_right_le_one_le `r \<ge> 0`)
      (subst pos_le_divide_eq pos_divide_le_eq,
        auto simp add: diff_le_iff diff_less_iff
        intro!: add_pos_pos)+
    qed simp
    finally have ?thesis by (simp add: ac_simps)
  } moreover {
    assume "\<not>0<B" hence "B = 0" using `B \<ge> 0` by simp
    hence ?thesis using `r \<ge> 0` by simp
  } ultimately show ?thesis using assms by arith
qed

subsection {* Accumulation of errors *}

text {* The concept of accumulating errors applies to convergence and stability. *}

lemma (in grid) error_accumulation:
  fixes x::"(nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> 'a::euclidean_space"
  assumes max_step: "max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (T - t 0) + 1) - 1))"
  defines "K \<equiv> {(s, y). \<exists>i \<le> j. s = t i \<and> y \<in> cball (x t i) r}"
  assumes "p > 0"
  assumes lipschitz: "\<And>j. t (Suc j) \<le> T \<Longrightarrow>
  dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j) \<le> \<bar>r\<bar> \<Longrightarrow>
  dist (\<psi> (stepsize j) (t j) (x t j))
     (\<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j))
    \<le> L * dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)" and "L \<ge> 0"
  assumes consistence_error: "\<And>j. t (Suc j) \<le> T \<Longrightarrow>
    dist (x t (Suc j)) (discrete_evolution \<psi> (t (Suc j)) (t j) (x t j)) \<le>
    B * stepsize j ^ (p + 1)" and "B \<ge> 0"
  assumes initial_error: "dist (x t 0) x0 \<le>
    B * (exp 1 - 1) * stepsize 0 ^ p / L"
  assumes "t j \<le> T"
  shows "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j) \<le>
    B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
using `t j \<le> T` max_step
proof (induct j)
  case 0 note initial_error
  also have "B * (exp 1 - 1) * stepsize 0 ^ p / L \<le>
    B * (exp 1 - 1) * max_stepsize 0 ^ p / L"
    using grid_stepsize_nonneg `B\<ge>0` `L\<ge>0`
    by (auto intro!: max_stepsize_ge_stepsize
      power_mono mult_left_mono divide_right_mono
      simp: diff_le_iff)
  finally show ?case by simp
next
  case (Suc j)
  have "t 0 \<le> T"
    using Suc grid_interval_notempty[of "Suc j"] by auto
  from Suc have j_in:"t j \<le> T" using grid_mono[of j "Suc j"] by simp
  moreover
  have "max_stepsize j \<le> max_stepsize (Suc j)"
    by (simp add: max_stepsize_mono)
  with Suc have IH1: "max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (T - t 0) + 1) - 1))" by simp
  ultimately have
    IH2: "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)
     \<le> B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
    by (rule Suc(1))
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j)) =
    norm (x t (Suc j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j) +
    ((discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    by (simp add: field_simps dist_norm)
  also have "... \<le> norm (x t (Suc j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j)) +
    norm (((discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    (is "_ \<le> _ + ?ej")
    by (rule norm_triangle_ineq)
  also have "?ej =
    norm (x t j - grid_function (discrete_evolution \<psi>) x0 t j + stepsize j *\<^sub>R
    (\<psi> (stepsize j) (t j) (x t j) -
    \<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    by (simp add: discrete_evolution_def stepsize_def algebra_simps)
  also have "... \<le>
    norm (x t j - grid_function (discrete_evolution \<psi>) x0 t j) + norm (stepsize j *\<^sub>R
    (\<psi> (stepsize j) (t j) (x t j) -
    \<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    by (rule norm_triangle_ineq)
  also have "... = norm (x t j - grid_function (discrete_evolution \<psi>) x0 t j) +
    stepsize j *
    dist (\<psi> (stepsize j) (t j) (x t j))
    (\<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j))"
    (is "_ = _ + _ * ?dj")
    using grid_stepsize_nonneg
    by (simp add: dist_norm)
  also
  have "?dj \<le> L * dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)"
  proof (intro lipschitz(1))
    from IH2 have
      "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)
      \<le> B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
      by (simp add: ac_simps)
    also have "... \<le>
      B / L * (exp (L * (T - t 0) + 1) - 1) * max_stepsize j ^ p"
      using `L\<ge>0` `B\<ge>0` `t j \<le> T` max_stepsize_nonneg
      by (auto intro!: mult_left_mono mult_right_mono divide_right_mono)
    also have "... \<le> \<bar>r\<bar>"
      using `B \<ge> 0` max_step max_stepsize_nonneg `L \<ge> 0` `p > 0`
        grid_ge_min using grid_mono[of 0 j] `t 0 \<le> T` IH1
      by (intro stepsize_inverse) auto
    finally show
      "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j) \<le> \<bar>r\<bar>" .
  qed (insert Suc, simp)
  finally
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
    \<le> norm (x t (Suc j) - (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j)) +
    (1 + stepsize j * L) *
      dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)"
    using grid_stepsize_nonneg
    by (auto simp: algebra_simps mult_right_mono dist_norm)
  also
  have "norm (x t (Suc j) - (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j)) \<le>
    B * stepsize j ^ (p + 1)"
    using consistence_error[OF `t (Suc j) \<le> T`] by (simp add: dist_norm)
  finally have rec:
    "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
      \<le> B * stepsize j ^ (p + 1) +
        (1 + stepsize j * L) *
        dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)"
    by simp
  also have "... \<le> B * stepsize j ^ (p + 1) +
    (1 + stepsize j * L) * (B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p)"
    using `B \<ge> 0` IH1 IH2 `t (Suc j) \<le> T` `0\<le>L` grid_stepsize_nonneg
    by (intro add_mono mult_left_mono) auto
  finally
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
    \<le> B * stepsize j ^ (p + 1) +
    (1 + stepsize j * L) * (B / L * (exp (L * (t j - t 0) + 1) - 1) *
      max_stepsize j ^ p)" .
  also have "... \<le> B * stepsize j * max_stepsize j ^ p +
    (1 + stepsize j * L) *
    (B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p)"
    using grid_stepsize_nonneg `B \<ge> 0` grid
    by (auto intro!: mult_left_mono power_mono
      simp add: max_stepsize_def field_simps)
  also have "... = max_stepsize j ^ p * B / L * (1 + stepsize j * L) *
      (exp (L * (t j - t 0) + 1))
    - max_stepsize j ^ p * B / L"
    using `B \<ge> 0` grid_stepsize_nonneg `p > 0` `L\<ge>0`
    apply (cases "L \<noteq> 0")
     apply (simp add: field_simps)
    apply (cases "max_stepsize j = 0")
     apply simp
    by (metis IH1 abs_not_less_zero abs_of_pos divide_zero_left less_eq_real_def max_stepsize_nonneg
      mult_zero_right real_root_zero)
  also
  have "B * (max_stepsize j ^ p * (exp (L * (t j - t 0) + 1) *
    (1 + L * (t (Suc j) - t j)))) / L
    \<le> B * (max_stepsize j ^ p * exp (L * (t (Suc j) - t 0) + 1)) / L"
    using `L \<ge> 0` `B \<ge> 0` max_stepsize_nonneg
  proof (intro divide_right_mono mult_left_mono)
    have "exp (L * (t j - t 0) + 1) * (1 + L * (t (Suc j) - t j)) \<le>
      exp (L * (t j - t 0) + 1) * exp (stepsize j * L)"
      unfolding stepsize_def[symmetric] by (auto simp add: ac_simps)
    also have "... \<le> exp (L * (t (Suc j) - t 0) + 1)"
      by (simp add: mult_exp_exp stepsize_def algebra_simps)
    finally
    show "exp (L * (t j - t 0) + 1) * (1 + L * (t (Suc j) - t j)) \<le>
      exp (L * (t (Suc j) - t 0) + 1)" .
  qed simp_all
  hence "max_stepsize j ^ p * B / L * (1 + stepsize j * L) *
    exp (L * (t j - t 0) + 1) \<le>
    max_stepsize j ^ p * B / L * exp (L * (t (Suc j) - t 0) + 1)"
    by (simp add: stepsize_def ac_simps)
  finally
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
    \<le> B / L * (exp (L * (t (Suc j) - t 0) + 1) - 1) *
    max_stepsize j ^ p" by (simp add: algebra_simps field_simps)
  also have "... \<le> B / L * (exp (L * (t (Suc j) - t 0) + 1) - 1) *
    max_stepsize (Suc j) ^ p"
    using `B\<ge>0``L\<ge>0` max_stepsize_nonneg
    by (intro mult_left_mono power_mono max_stepsize_mono) (auto
      simp: diff_le_iff intro!: divide_nonneg_nonneg mult_nonneg_nonneg
      add_nonneg_nonneg grid_mono)
  finally show ?case .
qed

subsection {* Consistency of order p implies convergence of order p *}
text{*\label{sec:osm-cons-imp-conv}*}

locale consistent_one_step =
  fixes t0 t1 and x::"real \<Rightarrow> 'a::ordered_euclidean_space" and incr p B r L
  assumes order_pos: "p > 0"
  assumes consistent_nonneg: "B \<ge> 0"
  assumes consistent: "\<And>s. s \<in> {t0..t1} \<Longrightarrow> consistent x s t1 B p incr"
  assumes lipschitz_nonneg: "L \<ge> 0"
  assumes lipschitz_incr: "\<And>s h. s \<in> {t0..t1} \<Longrightarrow> h \<in> {0..t1 - s} \<Longrightarrow>
    lipschitz (cball (x s) \<bar>r\<bar>) (\<lambda>x. incr h s x) L"

locale max_step = grid +
  fixes t1 p L B r
  assumes max_step: "\<And>j. t j \<le> t1 \<Longrightarrow> max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))"
begin

lemma max_step_mono_r:
  assumes "\<bar>s\<bar> \<ge> \<bar>r\<bar>" "L \<ge> 0" "B \<ge> 0" "t1 \<ge> t 0" "0 < p" "t j \<le> t1"
  shows "max_stepsize j \<le>
    root p (\<bar>s\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))"
proof -
  from max_step `t j \<le> t1` have "max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))" .
  also
  have "... \<le> root p (\<bar>s\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))"
    using assms
    apply (cases "B = 0", simp)
    apply (cases "L = 0", simp)
    by (auto simp add: mult_le_cancel_left1 diff_le_iff
      intro!: divide_right_mono add_increasing mult_left_mono)
  finally
  show "max_stepsize j \<le> root p (\<bar>s\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))" .
qed

end

locale convergent_one_step = consistent_one_step + max_step +
  assumes grid_from: "t0 = t 0"
begin

lemma (in convergent_one_step) convergence:
  assumes "t j \<le> t1"
  shows "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
        B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
proof -
  from order_pos consistent_nonneg lipschitz_nonneg
  have "p > 0" "B \<ge> 0" "L \<ge> 0" by simp_all
  {
    fix j::nat assume "t (Suc j) \<le> t1"
    from consistent have "dist (x (t j + stepsize j))
      (discrete_evolution incr (t j + stepsize j) (t j) (x (t j)))
      \<le> B * (stepsize j ^ (p + 1))"
      apply (rule consistentD)
      using `t (Suc j) \<le> t1` grid_mono[of j "Suc j"] grid_stepsize_nonneg
      by (auto intro: grid_mono simp: stepsize_def grid_from)
  } note consistence_error = this
  {
    fix j::nat
    assume "t (Suc j) \<le> t1"
    assume in_K:
      "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le> \<bar>r\<bar>"
    hence "stepsize j \<in> {0..t1 - t j}"
      using grid_stepsize_nonneg grid_mono `t (Suc j) \<le> t1`
      by (simp add: stepsize_def diff_le_iff)
    moreover
    have "t j \<in> {t 0..t1}" using grid[of j] `t (Suc j) \<le> t1`
      grid_mono[of j "Suc j"] grid_ge_min by simp
    moreover
    hence "x (t j) \<in> cball (x (t j)) \<bar>r\<bar>" by simp
    moreover
    hence  "grid_function (discrete_evolution incr) (x (t 0)) t j \<in>
      cball (x (t j)) \<bar>r\<bar>" using in_K by simp
    ultimately
    have "dist (incr (stepsize j) (t j) (x (t j)))
      (incr (stepsize j) (t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j))
      \<le> L *
      dist (x (t j))
      (grid_function (discrete_evolution incr) (x (t 0)) t j)"
      using lipschitz_incr grid_from
      unfolding lipschitz_def
      by blast
  } note lipschitz_grid = this
  have
    "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
    (B / L * (exp (L * (t j - t 0) + 1) - 1)) * max_stepsize j ^ p"
    using `p > 0` `L \<ge> 0` `B \<ge> 0` `t j \<le> t1`
      max_stepsize_nonneg
      consistence_error lipschitz_grid
    by (intro error_accumulation[OF max_step]) (auto intro!:
      divide_nonneg_nonneg mult_nonneg_nonneg zero_le_power grid_mono
      simp add: lipschitz_def diff_le_iff stepsize_def)
  also have "... \<le>
    (B / L * (exp (L * (t1 - t 0) + 1) - 1)) * max_stepsize j ^ p"
    using `t j \<le> t1` `0\<le>L` `0\<le>B` max_stepsize_nonneg
    by (auto intro!: divide_right_mono mult_right_mono mult_left_mono)
  finally show ?thesis by simp
qed

end

subsection{* Stability *}
text{*\label{sec:osm-stability}*}

locale disturbed_one_step = grid +
  fixes t1 s s0 x incr p B L
  assumes initial_error: "norm s0 \<le> B / L * (exp 1 - 1) * stepsize 0 ^ p"
  assumes error: "\<And>j. t (Suc j) \<le> t1 \<Longrightarrow>
  norm (s (stepsize j) (t j)
  (grid_function (discrete_evolution (\<lambda>h t x. incr h t x + s h t x))
    (x (t 0) + s0) t j)) \<le> B * stepsize j ^ p"

locale stable_one_step =
  consistent_one_step "t 0" + disturbed_one_step +
  max_step t t1 p L B "r / 2"
begin

lemma t0_le: "t i \<le> t1 \<Longrightarrow> t 0 \<le> t1"
  by (metis grid_interval_notempty order.trans)

lemma stability:
  assumes "t j \<le> t1"
  defines incrs: "incrs \<equiv> \<lambda>h t x. incr h t x + s h t x"
  shows "dist
    (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
    (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
        B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
proof -
  have "t 0 \<le> t1"
    by (metis assms(1) grid_ge_min order_trans)
  {
    fix j assume "t (Suc j) \<le> t1" from error[OF this]
    have "stepsize j * norm (s (stepsize j) (t j)
        (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
       \<le> stepsize j * (B * stepsize j ^ p)"
      using grid_stepsize_nonneg
      by (auto intro: mult_left_mono simp: incrs)
    hence "norm (stepsize j *\<^sub>R s (stepsize j) (t j)
        (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
      \<le> B * stepsize j ^ (p + 1)"
      using grid_stepsize_nonneg
      by (simp add: field_simps)
  } note error = this
  interpret c1: convergent_one_step "t 0" using max_step_r
    by unfold_locales simp_all
  { fix j assume "t (Suc j) \<le> t1"
    hence "t j \<le> t1" using grid_mono[of j "Suc j"] by auto
    have "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j)
      \<le> B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
      using `t j \<le> t1` by (rule c1.convergence)
    also have "... \<le> \<bar>r/2\<bar>" using max_stepsize_nonneg grid_interval_notempty max_step
      consistent_nonneg lipschitz_nonneg order_pos
      grid_mono `t j \<le> t1` t0_le
      apply (cases "L = 0", simp)
      by (intro stepsize_inverse) (auto simp: diff_le_iff)
    finally have
      "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
      \<bar>r / 2\<bar>" .
  } note incr_in = this
  { fix j assume "t (Suc j) \<le> t1"
    note incr_in[OF this]
    also have "\<bar>r/2\<bar> \<le> \<bar>r\<bar>" by simp
    finally have
      "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le> \<bar>r\<bar>".
  }
  note incr_in_r = this
  have "dist
    (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
    (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
    B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
  proof (intro error_accumulation[OF max_step])
    fix j assume j: "t (Suc j) \<le> t1"
    show "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t (Suc j))
      (discrete_evolution incr (t (Suc j)) (t j) (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
      \<le> B * stepsize j ^ (p + 1)"
      using error[OF j]
      by (simp add: incrs discrete_evolution_def[abs_def] dist_norm
        stepsize_def scaleR_right_distrib)
  next
    fix j assume "t (Suc j) \<le> t1" hence "t j \<le> t1" using grid_mono[of j "Suc j"]
      by simp
    have
      "dist (x (t j)) (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      \<le> dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) +
      dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j)"
      by (rule dist_triangle2)
    also have
      "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
      B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
      using `t j \<le> t1` by (rule c1.convergence)
    also have "... \<le> \<bar>r/2\<bar>"
      using max_stepsize_nonneg grid_interval_notempty max_step
        consistent_nonneg lipschitz_nonneg order_pos
        grid_mono `t j \<le> t1` `t 0 \<le> t1`
      by (intro stepsize_inverse) (auto simp: diff_le_iff)
    also
    assume "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le> \<bar>r / 2\<bar>"
    finally
    have "dist
      (x (t j))
      (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j) \<le> \<bar>r\<bar>" by simp
    thus "dist
      (incr (stepsize j) (t j)
      (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
      (incr (stepsize j) (t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j))
      \<le> L *
      dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j)"
      using  `t j \<le> t1` `t (Suc j) \<le> t1` incr_in_r
        max_stepsize_nonneg
        grid_ge_min
        grid_stepsize_nonneg
        grid_mono[of j]
      by (intro lipschitz_incr[THEN lipschitzD]) (auto simp: stepsize_def)
  next
    show "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t 0)
      (x (t 0))
      \<le> B * (exp 1 - 1) * stepsize 0 ^ p / L" using initial_error
      by (simp add: dist_norm)
  qed (simp_all add: consistent_nonneg order_pos lipschitz_nonneg `t j \<le> t1`)
  also have "... \<le>
    B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
    using grid lipschitz_nonneg consistent_nonneg
      max_stepsize_nonneg
      grid_ge_min grid_mono `t j \<le> t1`
    by  (auto simp add: ac_simps intro!: divide_right_mono mult_left_mono)
  finally have "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
   (grid_function (discrete_evolution incr) (x (t 0)) t j)
  \<le> B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p" .
  thus ?thesis by simp
qed

end

subsection{* Stability via implicit error *}

locale rounded_one_step = consistent_one_step "t 0" t1 x incr p B r L +
  max_step t t1 p L B "r / 2"
  for t::"nat\<Rightarrow>real" and t1 and x::"real\<Rightarrow>('a::ordered_euclidean_space)" and incr p B r L +
  fixes incr'::"real\<Rightarrow>real\<Rightarrow>'a\<Rightarrow>'a"
  fixes x0'::'a
  assumes initial_error: "dist (x (t 0)) x0' \<le>
    B / L * (exp 1 - 1) * stepsize 0 ^ p"
  assumes incr_approx: "\<And>h j x. t j \<le> t1 \<Longrightarrow> dist (incr h (t j) x) (incr' h (t j) x) \<le>
    B * stepsize j ^ p"
begin

lemma stability:
  assumes "t j \<le> t1"
  shows "dist
   ((grid_function (discrete_evolution incr') (x0') t j))
   (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
     B / L * (exp (L * (t1 - (t 0)) + 1) - 1) * max_stepsize j ^ p"
proof -
   note fg' = incr_approx
  def s0 \<equiv> "x0' - x (t 0)"
  hence x0': "x0' = x (t 0) + s0"
    by simp
  def s \<equiv> "\<lambda>x xa xb. (incr' x xa xb) - incr x xa xb"
  def incrs \<equiv> "\<lambda>h t x. incr h t x + s h t x"
  have s: "incr' = incrs"
    by (simp add: s_def incrs_def)
  interpret c: stable_one_step t1 x incr p B r L t s s0
  proof
    fix j
    assume "(t (Suc j)) \<le> t1"
    hence "t j \<le> t1" using grid_mono[of j "Suc j"] by simp
    have "norm (s (stepsize j) (t j) (grid_function
             (discrete_evolution (\<lambda>h t x. (incr' h t x)))
             (x (t 0) + s0) t j))
          \<le> B * stepsize j ^ p"
      unfolding s_def dist_norm[symmetric]
      unfolding dist_commute
      using `t j \<le> t1`
      by (rule fg')
    thus "norm
         (s (stepsize j) (t j)
           (grid_function (discrete_evolution (\<lambda>h t x. incr h t x + s h t x))
             (x (t 0) + s0) (\<lambda>x. (t x)) j))
        \<le> B * stepsize j ^ p" by (simp add: s incrs_def)
  next
    show "norm s0 \<le> B / L * (exp 1 - 1) * stepsize 0 ^ p"
      unfolding s0_def using initial_error by (simp add: dist_commute dist_norm)
  qed
  show ?thesis
    unfolding s x0'
    using `t j \<le> t1`
    by (rule c.stability[simplified incrs_def[symmetric]])
qed

end

end


(*  Title:      ZF/Bool.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section\<open>Booleans in Zermelo-Fraenkel Set Theory\<close>

theory Bool imports pair begin

abbreviation
  one  ("1") where
  "1 == succ(0)"

abbreviation
  two  ("2") where
  "2 == succ(1)"

text\<open>2 is equal to bool, but is used as a number rather than a type.\<close>

definition "bool == {0,1}"

definition "cond(b,c,d) == if(b=1,c,d)"

definition "not(b) == cond(b,0,1)"

definition
  "and"       :: "[i,i]=>i"      (infixl "and" 70)  where
    "a and b == cond(a,b,0)"

definition
  or          :: "[i,i]=>i"      (infixl "or" 65)  where
    "a or b == cond(a,1,b)"

definition
  xor         :: "[i,i]=>i"      (infixl "xor" 65) where
    "a xor b == cond(a,not(b),b)"

lemmas bool_defs = bool_def cond_def

lemma singleton_0: "{0} = 1"
by (simp add: succ_def)

(* Introduction rules *)

lemma bool_1I [simp,TC]: "1 \<in> bool"
by (simp add: bool_defs )

lemma bool_0I [simp,TC]: "0 \<in> bool"
by (simp add: bool_defs)

lemma one_not_0: "1\<noteq>0"
by (simp add: bool_defs )

(** 1=0 ==> R **)
lemmas one_neq_0 = one_not_0 [THEN notE]

lemma boolE:
    "[| c: bool;  c=1 ==> P;  c=0 ==> P |] ==> P"
by (simp add: bool_defs, blast)

(** cond **)

(*1 means true*)
lemma cond_1 [simp]: "cond(1,c,d) = c"
by (simp add: bool_defs )

(*0 means false*)
lemma cond_0 [simp]: "cond(0,c,d) = d"
by (simp add: bool_defs )

lemma cond_type [TC]: "[| b: bool;  c: A(1);  d: A(0) |] ==> cond(b,c,d): A(b)"
by (simp add: bool_defs, blast)

(*For Simp_tac and Blast_tac*)
lemma cond_simple_type: "[| b: bool;  c: A;  d: A |] ==> cond(b,c,d): A"
by (simp add: bool_defs )

lemma def_cond_1: "[| !!b. j(b)==cond(b,c,d) |] ==> j(1) = c"
by simp

lemma def_cond_0: "[| !!b. j(b)==cond(b,c,d) |] ==> j(0) = d"
by simp

lemmas not_1 = not_def [THEN def_cond_1, simp]
lemmas not_0 = not_def [THEN def_cond_0, simp]

lemmas and_1 = and_def [THEN def_cond_1, simp]
lemmas and_0 = and_def [THEN def_cond_0, simp]

lemmas or_1 = or_def [THEN def_cond_1, simp]
lemmas or_0 = or_def [THEN def_cond_0, simp]

lemmas xor_1 = xor_def [THEN def_cond_1, simp]
lemmas xor_0 = xor_def [THEN def_cond_0, simp]

lemma not_type [TC]: "a:bool ==> not(a) \<in> bool"
by (simp add: not_def)

lemma and_type [TC]: "[| a:bool;  b:bool |] ==> a and b \<in> bool"
by (simp add: and_def)

lemma or_type [TC]: "[| a:bool;  b:bool |] ==> a or b \<in> bool"
by (simp add: or_def)

lemma xor_type [TC]: "[| a:bool;  b:bool |] ==> a xor b \<in> bool"
by (simp add: xor_def)

lemmas bool_typechecks = bool_1I bool_0I cond_type not_type and_type
                         or_type xor_type

subsection\<open>Laws About 'not'\<close>

lemma not_not [simp]: "a:bool ==> not(not(a)) = a"
by (elim boolE, auto)

lemma not_and [simp]: "a:bool ==> not(a and b) = not(a) or not(b)"
by (elim boolE, auto)

lemma not_or [simp]: "a:bool ==> not(a or b) = not(a) and not(b)"
by (elim boolE, auto)

subsection\<open>Laws About 'and'\<close>

lemma and_absorb [simp]: "a: bool ==> a and a = a"
by (elim boolE, auto)

lemma and_commute: "[| a: bool; b:bool |] ==> a and b = b and a"
by (elim boolE, auto)

lemma and_assoc: "a: bool ==> (a and b) and c  =  a and (b and c)"
by (elim boolE, auto)

lemma and_or_distrib: "[| a: bool; b:bool; c:bool |] ==>
       (a or b) and c  =  (a and c) or (b and c)"
by (elim boolE, auto)

subsection\<open>Laws About 'or'\<close>

lemma or_absorb [simp]: "a: bool ==> a or a = a"
by (elim boolE, auto)

lemma or_commute: "[| a: bool; b:bool |] ==> a or b = b or a"
by (elim boolE, auto)

lemma or_assoc: "a: bool ==> (a or b) or c  =  a or (b or c)"
by (elim boolE, auto)

lemma or_and_distrib: "[| a: bool; b: bool; c: bool |] ==>
           (a and b) or c  =  (a or c) and (b or c)"
by (elim boolE, auto)

definition
  bool_of_o :: "o=>i" where
   "bool_of_o(P) == (if P then 1 else 0)"

lemma [simp]: "bool_of_o(False) = 0"
by (simp add: bool_of_o_def)

lemma [simp,TC]: "bool_of_o(P) \<in> bool"
by (simp add: bool_of_o_def)

lemma [simp]: "(bool_of_o(P) = 1) \<longleftrightarrow> P"
by (simp add: bool_of_o_def)

lemma [simp]: "(bool_of_o(P) = 0) \<longleftrightarrow> ~P"
by (simp add: bool_of_o_def)

end


(*  Title:      ZF/OrdQuant.thy
    Authors:    Krzysztof Grabczewski and L C Paulson
*)

section \<open>Special quantifiers\<close>

theory OrdQuant imports Ordinal begin

subsection \<open>Quantifiers and union operator for ordinals\<close>

definition
  (* Ordinal Quantifiers *)
  oall :: "[i, i => o] => o"  where
    "oall(A, P) == \<forall>x. x<A \<longrightarrow> P(x)"

definition
  oex :: "[i, i => o] => o"  where
    "oex(A, P)  == \<exists>x. x<A & P(x)"

definition
  (* Ordinal Union *)
  OUnion :: "[i, i => i] => i"  where
    "OUnion(i,B) == {z: \<Union>x\<in>i. B(x). Ord(i)}"

syntax
  "_oall"     :: "[idt, i, o] => o"        (\<open>(3\<forall>_<_./ _)\<close> 10)
  "_oex"      :: "[idt, i, o] => o"        (\<open>(3\<exists>_<_./ _)\<close> 10)
  "_OUNION"   :: "[idt, i, i] => i"        (\<open>(3\<Union>_<_./ _)\<close> 10)
translations
  "\<forall>x<a. P" \<rightleftharpoons> "CONST oall(a, \<lambda>x. P)"
  "\<exists>x<a. P" \<rightleftharpoons> "CONST oex(a, \<lambda>x. P)"
  "\<Union>x<a. B" \<rightleftharpoons> "CONST OUnion(a, \<lambda>x. B)"

subsubsection \<open>simplification of the new quantifiers\<close>

(*MOST IMPORTANT that this is added to the simpset BEFORE Ord_atomize
  is proved.  Ord_atomize would convert this rule to
    x < 0 ==> P(x) == True, which causes dire effects!*)

lemma [simp]: "~(\<exists>x<0. P(x))"
by (simp add: oex_def)

lemma [simp]: "(\<forall>x<succ(i). P(x)) <-> (Ord(i) \<longrightarrow> P(i) & (\<forall>x<i. P(x)))"
apply (simp add: oall_def le_iff)
apply (blast intro: lt_Ord2)
done

lemma [simp]: "(\<exists>x<succ(i). P(x)) <-> (Ord(i) & (P(i) | (\<exists>x<i. P(x))))"
apply (simp add: oex_def le_iff)
apply (blast intro: lt_Ord2)
done

subsubsection \<open>Union over ordinals\<close>

lemma Ord_OUN [intro,simp]:
     "[| !!x. x<A ==> Ord(B(x)) |] ==> Ord(\<Union>x<A. B(x))"
by (simp add: OUnion_def ltI Ord_UN)

lemma OUN_upper_lt:
     "[| a<A;  i < b(a);  Ord(\<Union>x<A. b(x)) |] ==> i < (\<Union>x<A. b(x))"
by (unfold OUnion_def lt_def, blast )

lemma OUN_upper_le:
     "[| a<A;  i\<le>b(a);  Ord(\<Union>x<A. b(x)) |] ==> i \<le> (\<Union>x<A. b(x))"
apply (unfold OUnion_def, auto)
apply (rule UN_upper_le )
apply (auto simp add: lt_def)
done

lemma Limit_OUN_eq: "Limit(i) ==> (\<Union>x<i. x) = i"
by (simp add: OUnion_def Limit_Union_eq Limit_is_Ord)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma OUN_least:
     "(!!x. x<A ==> B(x) \<subseteq> C) ==> (\<Union>x<A. B(x)) \<subseteq> C"
by (simp add: OUnion_def UN_least ltI)

lemma OUN_least_le:
     "[| Ord(i);  !!x. x<A ==> b(x) \<le> i |] ==> (\<Union>x<A. b(x)) \<le> i"
by (simp add: OUnion_def UN_least_le ltI Ord_0_le)

lemma le_implies_OUN_le_OUN:
     "[| !!x. x<A ==> c(x) \<le> d(x) |] ==> (\<Union>x<A. c(x)) \<le> (\<Union>x<A. d(x))"
by (blast intro: OUN_least_le OUN_upper_le le_Ord2 Ord_OUN)

lemma OUN_UN_eq:
     "(!!x. x \<in> A ==> Ord(B(x)))
      ==> (\<Union>z < (\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z < B(x). C(z))"
by (simp add: OUnion_def)

lemma OUN_Union_eq:
     "(!!x. x \<in> X ==> Ord(x))
      ==> (\<Union>z < \<Union>(X). C(z)) = (\<Union>x\<in>X. \<Union>z < x. C(z))"
by (simp add: OUnion_def)

(*So that rule_format will get rid of this quantifier...*)
lemma atomize_oall [symmetric, rulify]:
     "(!!x. x<A ==> P(x)) == Trueprop (\<forall>x<A. P(x))"
by (simp add: oall_def atomize_all atomize_imp)

subsubsection \<open>universal quantifier for ordinals\<close>

lemma oallI [intro!]:
    "[| !!x. x<A ==> P(x) |] ==> \<forall>x<A. P(x)"
by (simp add: oall_def)

lemma ospec: "[| \<forall>x<A. P(x);  x<A |] ==> P(x)"
by (simp add: oall_def)

lemma oallE:
    "[| \<forall>x<A. P(x);  P(x) ==> Q;  ~x<A ==> Q |] ==> Q"
by (simp add: oall_def, blast)

lemma rev_oallE [elim]:
    "[| \<forall>x<A. P(x);  ~x<A ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: oall_def, blast)

(*Trival rewrite rule.  @{term"(\<forall>x<a.P)<->P"} holds only if a is not 0!*)
lemma oall_simp [simp]: "(\<forall>x<a. True) <-> True"
by blast

(*Congruence rule for rewriting*)
lemma oall_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oall(a, %x. P(x)) <-> oall(a', %x. P'(x))"
by (simp add: oall_def)

subsubsection \<open>existential quantifier for ordinals\<close>

lemma oexI [intro]:
    "[| P(x);  x<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

(*Not of the general form for such rules... *)
lemma oexCI:
   "[| \<forall>x<A. ~P(x) ==> P(a);  a<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

lemma oexE [elim!]:
    "[| \<exists>x<A. P(x);  !!x. [| x<A; P(x) |] ==> Q |] ==> Q"
apply (simp add: oex_def, blast)
done

lemma oex_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oex(a, %x. P(x)) <-> oex(a', %x. P'(x))"
apply (simp add: oex_def cong add: conj_cong)
done

subsubsection \<open>Rules for Ordinal-Indexed Unions\<close>

lemma OUN_I [intro]: "[| a<i;  b \<in> B(a) |] ==> b: (\<Union>z<i. B(z))"
by (unfold OUnion_def lt_def, blast)

lemma OUN_E [elim!]:
    "[| b \<in> (\<Union>z<i. B(z));  !!a.[| b \<in> B(a);  a<i |] ==> R |] ==> R"
apply (unfold OUnion_def lt_def, blast)
done

lemma OUN_iff: "b \<in> (\<Union>x<i. B(x)) <-> (\<exists>x<i. b \<in> B(x))"
by (unfold OUnion_def oex_def lt_def, blast)

lemma OUN_cong [cong]:
    "[| i=j;  !!x. x<j ==> C(x)=D(x) |] ==> (\<Union>x<i. C(x)) = (\<Union>x<j. D(x))"
by (simp add: OUnion_def lt_def OUN_iff)

lemma lt_induct:
    "[| i<k;  !!x.[| x<k;  \<forall>y<x. P(y) |] ==> P(x) |]  ==>  P(i)"
apply (simp add: lt_def oall_def)
apply (erule conjE)
apply (erule Ord_induct, assumption, blast)
done

subsection \<open>Quantification over a class\<close>

definition
  "rall"     :: "[i=>o, i=>o] => o"  where
    "rall(M, P) == \<forall>x. M(x) \<longrightarrow> P(x)"

definition
  "rex"      :: "[i=>o, i=>o] => o"  where
    "rex(M, P) == \<exists>x. M(x) & P(x)"

syntax
  "_rall"     :: "[pttrn, i=>o, o] => o"        (\<open>(3\<forall>_[_]./ _)\<close> 10)
  "_rex"      :: "[pttrn, i=>o, o] => o"        (\<open>(3\<exists>_[_]./ _)\<close> 10)
translations
  "\<forall>x[M]. P" \<rightleftharpoons> "CONST rall(M, \<lambda>x. P)"
  "\<exists>x[M]. P" \<rightleftharpoons> "CONST rex(M, \<lambda>x. P)"

subsubsection\<open>Relativized universal quantifier\<close>

lemma rallI [intro!]: "[| !!x. M(x) ==> P(x) |] ==> \<forall>x[M]. P(x)"
by (simp add: rall_def)

lemma rspec: "[| \<forall>x[M]. P(x); M(x) |] ==> P(x)"
by (simp add: rall_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_rallE [elim]:
    "[| \<forall>x[M]. P(x);  ~ M(x) ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: rall_def, blast)

lemma rallE: "[| \<forall>x[M]. P(x);  P(x) ==> Q;  ~ M(x) ==> Q |] ==> Q"
by blast

(*Trival rewrite rule;   (\<forall>x[M].P)<->P holds only if A is nonempty!*)
lemma rall_triv [simp]: "(\<forall>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<longrightarrow> P)"
by (simp add: rall_def)

(*Congruence rule for rewriting*)
lemma rall_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<forall>x[M]. P(x)) <-> (\<forall>x[M]. P'(x))"
by (simp add: rall_def)

subsubsection\<open>Relativized existential quantifier\<close>

lemma rexI [intro]: "[| P(x); M(x) |] ==> \<exists>x[M]. P(x)"
by (simp add: rex_def, blast)

(*The best argument order when there is only one M(x)*)
lemma rev_rexI: "[| M(x);  P(x) |] ==> \<exists>x[M]. P(x)"
by blast

(*Not of the general form for such rules... *)
lemma rexCI: "[| \<forall>x[M]. ~P(x) ==> P(a); M(a) |] ==> \<exists>x[M]. P(x)"
by blast

lemma rexE [elim!]: "[| \<exists>x[M]. P(x);  !!x. [| M(x); P(x) |] ==> Q |] ==> Q"
by (simp add: rex_def, blast)

(*We do not even have (\<exists>x[M]. True) <-> True unless A is nonempty!!*)
lemma rex_triv [simp]: "(\<exists>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<and> P)"
by (simp add: rex_def)

lemma rex_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<exists>x[M]. P(x)) <-> (\<exists>x[M]. P'(x))"
by (simp add: rex_def cong: conj_cong)

lemma rall_is_ball [simp]: "(\<forall>x[%z. z\<in>A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by blast

lemma rex_is_bex [simp]: "(\<exists>x[%z. z\<in>A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by blast

lemma atomize_rall: "(!!x. M(x) ==> P(x)) == Trueprop (\<forall>x[M]. P(x))"
by (simp add: rall_def atomize_all atomize_imp)

declare atomize_rall [symmetric, rulify]

lemma rall_simps1:
     "(\<forall>x[M]. P(x) & Q)   <-> (\<forall>x[M]. P(x)) & ((\<forall>x[M]. False) | Q)"
     "(\<forall>x[M]. P(x) | Q)   <-> ((\<forall>x[M]. P(x)) | Q)"
     "(\<forall>x[M]. P(x) \<longrightarrow> Q) <-> ((\<exists>x[M]. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x[M]. P(x))) <-> (\<exists>x[M]. ~P(x))"
by blast+

lemma rall_simps2:
     "(\<forall>x[M]. P & Q(x))   <-> ((\<forall>x[M]. False) | P) & (\<forall>x[M]. Q(x))"
     "(\<forall>x[M]. P | Q(x))   <-> (P | (\<forall>x[M]. Q(x)))"
     "(\<forall>x[M]. P \<longrightarrow> Q(x)) <-> (P \<longrightarrow> (\<forall>x[M]. Q(x)))"
by blast+

lemmas rall_simps [simp] = rall_simps1 rall_simps2

lemma rall_conj_distrib:
    "(\<forall>x[M]. P(x) & Q(x)) <-> ((\<forall>x[M]. P(x)) & (\<forall>x[M]. Q(x)))"
by blast

lemma rex_simps1:
     "(\<exists>x[M]. P(x) & Q) <-> ((\<exists>x[M]. P(x)) & Q)"
     "(\<exists>x[M]. P(x) | Q) <-> (\<exists>x[M]. P(x)) | ((\<exists>x[M]. True) & Q)"
     "(\<exists>x[M]. P(x) \<longrightarrow> Q) <-> ((\<forall>x[M]. P(x)) \<longrightarrow> ((\<exists>x[M]. True) & Q))"
     "(~(\<exists>x[M]. P(x))) <-> (\<forall>x[M]. ~P(x))"
by blast+

lemma rex_simps2:
     "(\<exists>x[M]. P & Q(x)) <-> (P & (\<exists>x[M]. Q(x)))"
     "(\<exists>x[M]. P | Q(x)) <-> ((\<exists>x[M]. True) & P) | (\<exists>x[M]. Q(x))"
     "(\<exists>x[M]. P \<longrightarrow> Q(x)) <-> (((\<forall>x[M]. False) | P) \<longrightarrow> (\<exists>x[M]. Q(x)))"
by blast+

lemmas rex_simps [simp] = rex_simps1 rex_simps2

lemma rex_disj_distrib:
    "(\<exists>x[M]. P(x) | Q(x)) <-> ((\<exists>x[M]. P(x)) | (\<exists>x[M]. Q(x)))"
by blast

subsubsection\<open>One-point rule for bounded quantifiers\<close>

lemma rex_triv_one_point1 [simp]: "(\<exists>x[M]. x=a) <-> ( M(a))"
by blast

lemma rex_triv_one_point2 [simp]: "(\<exists>x[M]. a=x) <-> ( M(a))"
by blast

lemma rex_one_point1 [simp]: "(\<exists>x[M]. x=a & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rex_one_point2 [simp]: "(\<exists>x[M]. a=x & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rall_one_point1 [simp]: "(\<forall>x[M]. x=a \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

lemma rall_one_point2 [simp]: "(\<forall>x[M]. a=x \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

subsubsection\<open>Sets as Classes\<close>

definition
  setclass :: "[i,i] => o"       (\<open>##_\<close> [40] 40)  where
   "setclass(A) == %x. x \<in> A"

lemma setclass_iff [simp]: "setclass(A,x) <-> x \<in> A"
by (simp add: setclass_def)

lemma rall_setclass_is_ball [simp]: "(\<forall>x[##A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by auto

lemma rex_setclass_is_bex [simp]: "(\<exists>x[##A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by auto

ML
\<open>
val Ord_atomize =
  atomize ([(\<^const_name>\<open>oall\<close>, @{thms ospec}), (\<^const_name>\<open>rall\<close>, @{thms rspec})] @
    ZF_conn_pairs, ZF_mem_pairs);
\<close>
declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

text \<open>Setting up the one-point-rule simproc\<close>

simproc_setup defined_rex ("\<exists>x[M]. P(x) & Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_Bex
    (fn ctxt => unfold_tac ctxt @{thms rex_def})
\<close>

simproc_setup defined_rall ("\<forall>x[M]. P(x) \<longrightarrow> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_Ball
    (fn ctxt => unfold_tac ctxt @{thms rall_def})
\<close>

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Verification Tool Prototype  *}

theory Verification_Tool_Proto
  imports KAT_Models HoareLogic
begin

text {*
  We show how a simple verification tool prototype can be obtained from our formalisation of Kleene
  algebra with tests and its relational model. So far, only natural numbers are admitted as datatypes.
  A more versatile implementation is under construction.

  First, we implement states and stores of a program in the relational model.
*}

type_synonym state = "string \<Rightarrow> nat"
notation times (infixr ";" 64)

text {*
  Next, we define assignement.
*}

definition lift_fn :: "(state \<Rightarrow> state) \<Rightarrow> state relation" where
  "lift_fn f = Abs_relation {(x, f x) |x. True}"

definition assign_fn :: "string \<Rightarrow> (state \<Rightarrow> nat) \<Rightarrow> state \<Rightarrow> state" where
  "assign_fn x f \<sigma> = (\<lambda>y. if x = y then f \<sigma> else \<sigma> y)"

definition assign :: "string \<Rightarrow> (state \<Rightarrow> nat) \<Rightarrow> state relation" (infix ":=" 99) where
  "x := e = lift_fn (assign_fn x e)"

lemma lift_fn_compose [simp]: "lift_fn f \<cdot> lift_fn g = lift_fn (g \<circ> f)"
  apply (simp add: lift_fn_def)
  apply transfer
  by auto

text {*
  Then, we lift tests to the relational model.
*}

definition assert :: "'a set \<Rightarrow> 'a relation" where
  "assert X \<equiv> Abs_relation (Id_on X)"

lemma test_assert [intro!, simp]: "test (assert X)"
  apply (simp add: assert_def test_def comp_op_relation_def)
  apply transfer
  by auto

lemma test_not_assert [intro!, simp]: "test (!(assert X))"
  apply (simp add: assert_def test_def comp_op_relation_def)
  apply transfer
  by auto

lemma [simp]: "assert X ; assert Y = assert (X \<inter> Y)"
  apply (simp add: assert_def)
  apply transfer
  by auto

lemma [simp]: "assert X ; !assert Y = assert (X - Y)"
  apply (simp add: assert_def)
  apply transfer
  by auto

text {*
  Now, we implement Hoare's assignement axiom.
*}

abbreviation assigns_notation :: "state set \<Rightarrow> string \<Rightarrow> (state \<Rightarrow> nat) \<Rightarrow> state set"
  ("_[_|_]" [100,100,100] 101) where
  "P[x|m] \<equiv> (\<lambda>state. assign_fn x m state) ` P"

lemma hoare_assignment': "P[x|m] \<subseteq> Q \<Longrightarrow> assert P \<cdot> x := m \<le> x := m \<cdot> assert Q"
  apply (simp add: assert_def assign_def image_def lift_fn_def)
  apply transfer
  by auto

lemma hoare_assignment: "P[x|m] \<subseteq> Q \<Longrightarrow> \<lbrace>assert P\<rbrace> x := m \<lbrace>assert Q\<rbrace>"
  by (metis (full_types) hoare_assignment' hoare_triple_def_var test_assert)

text {*
  This a variant of the sequential rule where tests are assertions.
*}

lemma hoare_seq: "\<lbrace>assert p\<rbrace>x\<lbrace>assert q'\<rbrace> \<Longrightarrow> \<lbrace>assert q'\<rbrace>x'\<lbrace>assert q\<rbrace> \<Longrightarrow> \<lbrace>assert p\<rbrace>x\<cdot>x'\<lbrace>assert q\<rbrace>"
  by (metis sequence_rule)

text {*
  We write a simple tactic for verification condition generation.
*}

named_theorems hoare_simp "simplification rules for the hoare tactic"
named_theorems hoare_rule "extra Hoare Rules"

ML {*
fun hoare_step_tac ctxt n =
  rtac @{thm hoare_assignment} n THEN TRY (rtac @{thm subset_refl} n)
  ORELSE (rtac @{thm hoare_while_inv} n THEN asm_full_simp_tac ( ctxt) 1)
  ORELSE (FIRST'
    (map (fn thm => rtac thm) (rev (Named_Theorems.get ctxt @{named_theorems hoare_rule}))) n)

val hoare_tac = Subgoal.FOCUS (fn {context = ctxt, ...} =>
  REPEAT (hoare_step_tac ctxt 1)
  THEN auto_tac ((fn ss => ss addsimps Named_Theorems.get ctxt @{named_theorems hoare_simp}) ctxt))
*}

declare hoare_seq [hoare_rule]

method_setup hoare_auto = {*
Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT (CHANGED (hoare_tac ctxt 1))))
*}

declare assign_fn_def [hoare_simp]
declare image_def [hoare_simp]

text {*
  We add some syntactic sugar.
*}
abbreviation assign_sugar :: "string \<Rightarrow> string \<Rightarrow> state relation" (infix ":=" 99) where
  "x := y \<equiv> x := (\<lambda>\<sigma>. \<sigma> y)"

abbreviation hoare_sugar :: "'a set \<Rightarrow> 'a relation \<Rightarrow> 'a set \<Rightarrow> bool" ("\<lbrace>_\<rbrace>_\<lbrace>_\<rbrace>") where
  "\<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> \<lbrace>assert p\<rbrace> c \<lbrace>assert q\<rbrace>"

abbreviation mod_sugar :: "string \<Rightarrow> string \<Rightarrow> state \<Rightarrow> nat" (infix "mod" 100) where
  "x mod y \<equiv> \<lambda>\<sigma>. (\<sigma> x) mod (\<sigma> y)"

abbreviation while_inv_sugar :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a relation \<Rightarrow> 'a relation" ("while _ inv _ do _" [64,64,64] 63) where
  "while b inv i do p \<equiv> while (assert b) inv (assert i) do p "

text {*
  As a complex example, we verify the partial correctness of Euclid's algorithm.
*}

lemma euclids_algorithm:
  "\<lbrace>{\<sigma>. \<sigma> ''x'' = x \<and> \<sigma> ''y'' = y}\<rbrace>
   while {\<sigma>. \<sigma> ''y'' \<noteq> 0}
   inv {\<sigma>. gcd (\<sigma> ''x'') (\<sigma> ''y'') = gcd x y}
   do (
     ''z'' := ''y'';
     ''y'' := ''x'' mod ''y'';
     ''x'' := ''z''
   )
   \<lbrace>{\<sigma>. \<sigma> ''x'' = gcd x y}\<rbrace>"
   apply hoare_auto
   by (metis gcd_red_nat)

end


theory BEXPC_PPS
imports Boolean_Expression_Checkers.Boolean_Expression_Checkers "Propositional_Proof_Systems.Sema"
begin

text \<open>Easy: @{typ "'a ifex \<Rightarrow> 'a formula"}.\<close>

primrec form_of_ifex where
"form_of_ifex Trueif = \<^bold>\<not> \<bottom>" |
"form_of_ifex Falseif = \<bottom>" |
"form_of_ifex (IF n t1 t2) =
  (Atom n \<^bold>\<and> form_of_ifex t1) \<^bold>\<or> (\<^bold>\<not> (Atom n) \<^bold>\<and> form_of_ifex t2)"

lemma form_of_ifex: "\<A> \<Turnstile> form_of_ifex T \<longleftrightarrow> val_ifex T \<A>"
  by(induction T; simp)

text \<open>A little bit tricky: @{typ "'a formula \<Rightarrow> 'a ifex"}.\<close>

(* abusing normif as a kind of IfThenElse-operator *)
text\<open>Does what @{const ifex_of} does.\<close>
find_consts "'b ifex \<Rightarrow> 'b ifex \<Rightarrow> 'b ifex \<Rightarrow> 'b ifex"
find_theorems normif
primrec ifex_of_form where
"ifex_of_form \<bottom> = Falseif" |
"ifex_of_form (Atom n) = IF n Trueif Falseif" |
"ifex_of_form (\<^bold>\<not>F) = normif Mapping.empty (ifex_of_form F) Falseif Trueif" |
"ifex_of_form (F \<^bold>\<and> G) = normif Mapping.empty (ifex_of_form F) (ifex_of_form G) Falseif" |
"ifex_of_form (F \<^bold>\<or> G) = normif Mapping.empty (ifex_of_form F) Trueif (ifex_of_form G)" |
"ifex_of_form (F \<^bold>\<rightarrow> G) = normif Mapping.empty (ifex_of_form F) (ifex_of_form G) Trueif"

lemma ifex_of_form: "val_ifex (ifex_of_form T) \<A> \<longleftrightarrow> \<A> \<Turnstile> T"
  by(induction T; simp add: agree_Nil val_normif)

text\<open>The rest is obvious.\<close>

primrec bool_expr_of_form where
"bool_expr_of_form \<bottom> = Const_bool_expr False" |
"bool_expr_of_form (Atom n) = Atom_bool_expr n" |
"bool_expr_of_form (\<^bold>\<not>F) = Neg_bool_expr (bool_expr_of_form F)" |
"bool_expr_of_form (F \<^bold>\<and> G) = And_bool_expr (bool_expr_of_form F) (bool_expr_of_form G)" |
"bool_expr_of_form (F \<^bold>\<or> G) = Or_bool_expr (bool_expr_of_form F) (bool_expr_of_form G)" |
"bool_expr_of_form (F \<^bold>\<rightarrow> G) = Imp_bool_expr (bool_expr_of_form F) (bool_expr_of_form G)"

lemma bool_expr_of_form: "val_bool_expr (bool_expr_of_form F) \<A> \<longleftrightarrow> \<A> \<Turnstile> F"
  by(induction F; simp)

primrec form_of_bool_expr where
"form_of_bool_expr (Const_bool_expr c) = (if c then \<top> else \<bottom>)" |
"form_of_bool_expr (Atom_bool_expr n) = Atom n" |
"form_of_bool_expr (Neg_bool_expr b) = \<^bold>\<not>(form_of_bool_expr b)" |
"form_of_bool_expr (And_bool_expr b1 b2) = (form_of_bool_expr b1) \<^bold>\<and> (form_of_bool_expr b2)" |
"form_of_bool_expr (Or_bool_expr b1 b2) = (form_of_bool_expr b1) \<^bold>\<or> (form_of_bool_expr b2)" |
"form_of_bool_expr (Imp_bool_expr b1 b2) = (form_of_bool_expr b1) \<^bold>\<rightarrow> (form_of_bool_expr b2)" |
"form_of_bool_expr (Iff_bool_expr b1 b2) =
  (let F = (form_of_bool_expr b1); G = (form_of_bool_expr b2) in
  (F \<^bold>\<rightarrow> G) \<^bold>\<and> (G \<^bold>\<rightarrow> F))" (* potentially exponential\<dots> *)

lemma form_of_bool_expr: "val_bool_expr b \<A> \<longleftrightarrow> \<A> \<Turnstile> (form_of_bool_expr b)"
  by(induction b; auto simp add: Let_def)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_mul3_assoc2
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 (mul3 x1 x2 x3) x4 x5) = (mul3 x1 (mul3 x2 x3 x4) x5))"
  oops

end


section \<open> Autonomous Marine Vehicle \<close>

theory AMV
  imports "Hybrid-Verification.Hybrid_Verification"
begin

subsection \<open> Preliminaries \<close>

lit_vars

no_notation (ASCII)
  comp  (infixl "o" 55)

lemma self_dot [simp]: "\<parallel>v\<parallel> * \<parallel>v\<parallel> = v \<bullet> v"
  by (metis norm_cauchy_schwarz_eq)

lemma orth_mag [simp]: "a \<bullet> b = \<parallel>a\<parallel> * \<parallel>b\<parallel> \<Longrightarrow> \<parallel>a + b\<parallel> = \<parallel>a\<parallel> + \<parallel>b\<parallel>"
  by (simp add: norm_cauchy_schwarz_eq norm_triangle_eq)

lemma orth_mag' [simp]: "b \<bullet> a = \<parallel>b\<parallel> * \<parallel>a\<parallel> \<Longrightarrow> \<parallel>a + b\<parallel> = \<parallel>a\<parallel> + \<parallel>b\<parallel>"
  by (simp add: norm_cauchy_schwarz_eq norm_triangle_eq)

lemma "a \<noteq> 0 \<Longrightarrow> \<parallel>sgn a\<parallel> = 1"
  by (simp add: norm_sgn)

lemma "a \<noteq> 0 \<Longrightarrow> sgn a \<bullet> sgn a = 1"
  by (meson norm_eq_1 norm_sgn)

lemma sgn_self_dot:
  assumes "a \<noteq> 0"
  shows "(sgn a) \<bullet> (sgn a) = 1"
  by (meson assms norm_eq_1 norm_sgn)

lemma "a \<noteq> 0 \<Longrightarrow> (a / \<parallel>a\<parallel>) \<bullet> (a / \<parallel>a\<parallel>) = 1"
  by simp

lemma "\<lbrakk> a \<ge> 0; a\<^sup>2 = b \<rbrakk> \<Longrightarrow> a = sqrt(b)"
  by (simp add: real_sqrt_unique)

lemma
  assumes "(a::'a::ordered_euclidean_space) \<noteq> 0"
  shows "a \<bullet> b / \<parallel>a\<parallel> = sgn a \<bullet> b"
  by (simp add: divide_inverse_commute sgn_div_norm)

lemma "v \<noteq> 0 \<Longrightarrow> arccos(v \<bullet> v / (\<parallel>v\<parallel> * \<parallel>v\<parallel>)) = 0"
  by (simp)

declare num1_eq1 [simp del]

lemma exhaust_2':
  fixes x :: 2
  shows "x = 0 \<or> x = 1"
  using exhaust_2 by fastforce

lemma forall_2': "(\<forall>i::2. P i) \<longleftrightarrow> P 0 \<and> P 1"
  by (metis exhaust_2')

declare UNIV_1 [simp del]
declare UNIV_2 [simp del]

lemma UNIV_1 [simp]: "(UNIV :: 1 set) = {0}"
  by (metis UNIV_1 num1_eq1)

lemma UNIV_2 [simp]: "(UNIV :: 2 set) = {0,1}"
  by (simp add: UNIV_eq_I exhaust_2')

subsection \<open> Vector Theorems and Simplifications \<close>

lemma vec_norm: "\<parallel>\<^bold>[[x, y]\<^bold>]\<parallel> = sqrt(x\<^sup>2 + y\<^sup>2)"
  by (simp add: norm_vec_def)

lemma vec_simps [simp]:
  "k *\<^sub>R \<^bold>[[x, y]\<^bold>] = \<^bold>[[k *\<^sub>R x, k *\<^sub>R y]\<^bold>]"
  "\<^bold>[[x\<^sub>1::real, y\<^sub>1]\<^bold>] \<bullet> \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = x\<^sub>1 * x\<^sub>2 + y\<^sub>1 * y\<^sub>2"
  "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] + \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = \<^bold>[[x\<^sub>1 + x\<^sub>2, y\<^sub>1 + y\<^sub>2]\<^bold>]"
  "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] - \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = \<^bold>[[x\<^sub>1 - x\<^sub>2, y\<^sub>1 - y\<^sub>2]\<^bold>]"
  "\<^bold>[[0, 0]\<^bold>] = 0"
     apply (subst scaleR_Mat, simp_all)
  apply (simp add: inner_vec_def)
    apply (subst plus_Mat, simp_all)
   apply (subst minus_Mat, simp_all)
   apply (simp add: matrix_eq_iff nat_of_num1_def forall_2')
  done

lemma orient_vec_mag_1 [simp]: "\<parallel>\<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel> = 1"
  by (simp add: vec_norm)

lemma orient_vec_mag_n [simp]:
  assumes "n \<ge> 0"
  shows "\<parallel>\<^bold>[[n * sin \<theta> :: real, n * cos \<theta>]\<^bold>]\<parallel> = n" (is "?P = ?Q")
proof -
  have "?P = \<parallel>\<^bold>[[n *\<^sub>R sin \<theta> :: real, n *\<^sub>R cos \<theta>]\<^bold>]\<parallel>"
    by (metis real_scaleR_def)
  also have "... = \<parallel>n *\<^sub>R \<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel>"
    by simp
  also have "... = \<parallel>n\<parallel> * \<parallel>\<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel>"
    by (metis norm_scaleR real_norm_def)
  also from assms have "... = n"
    by simp
  finally show ?thesis .
qed

lemma sin_cos_self_dot [simp]: "\<^bold>[[sin(\<theta>::real), cos(\<theta>)]\<^bold>] \<bullet> \<^bold>[[sin(\<theta>), cos(\<theta>)]\<^bold>] = 1"
  by (simp, metis power2_eq_square sin_cos_squared_add)

lemma vector_2_cases [cases type]:
  fixes x
  assumes "\<And> x\<^sub>1 x\<^sub>2. x = \<^bold>[[x\<^sub>1, x\<^sub>2]\<^bold>] \<Longrightarrow> P"
  shows "P"
proof -
  have "x = \<^bold>[[x$1$0, x$1$1]\<^bold>]"
    by (simp add: matrix_eq_iff nat_of_num1_def forall_2')
  thus ?thesis
    using assms by metis
qed

lemma cos_r1:
  assumes "- 1 \<le> y" "y < 1"
  shows "0 < arccos y"
proof -
  have "arccos 1 < arccos y"
    by (rule arccos_less_arccos, simp_all add: assms)
  thus ?thesis
    by simp
qed

lemma cos_r2:
  assumes "0 < x" "x \<le> 1"
  shows "arccos x * 2 < pi"
proof -
  have "arccos x < arccos 0"
    by (rule arccos_less_arccos, simp_all add: assms)
  thus ?thesis
    by simp
qed

lemma vec_2_eq_iff [simp]: "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] = \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] \<longleftrightarrow> (x\<^sub>1 = x\<^sub>2 \<and> y\<^sub>1 = y\<^sub>2)"
  by (auto simp add: Mat_eq_iff')

lemma vec_2_eq_zero_off [simp]: "\<^bold>[[x, y]\<^bold>] = 0 \<longleftrightarrow> (x = 0 \<and> y = 0)"
  by (subst vec_simps(5) [THEN sym], simp only: vec_2_eq_iff)

subsection \<open> Angle Calculations \<close>

definition
  "angOfVec x \<equiv>
    (let a = vangle \<^bold>[[0::real,1]\<^bold>] x in
     if (x 0 0 \<ge> 0) then a else (2*pi) - a)"

abbreviation "\<phi>\<^sub>m\<^sub>a\<^sub>x \<equiv> pi / 3"

definition angDiff :: "real \<Rightarrow> real \<Rightarrow> bool \<Rightarrow> real" where
"angDiff \<phi>\<^sub>A \<phi>\<^sub>B rotRestr \<equiv>
  let dphi =
  (if (abs(\<phi>\<^sub>A - \<phi>\<^sub>B) <= pi) then
    \<phi>\<^sub>A - \<phi>\<^sub>B
  else
    -sgn(\<phi>\<^sub>A - \<phi>\<^sub>B) * (2 * pi - abs(\<phi>\<^sub>A - \<phi>\<^sub>B)))
  in
  if (rotRestr) then
    -sgn(dphi) * min(abs(dphi)) \<phi>\<^sub>m\<^sub>a\<^sub>x
  else dphi"

lemma "angOfVec (Matrix[[0,1]]) = 0" \<comment> \<open> 0 degree angOfVector \<close>
  by (simp add: angOfVec_def vangle_def vec_norm)

lemma arccos_inv_sqrt2: "arccos (1 / sqrt 2) = pi / 4"
  by (smt arccos_cos arccos_minus_1 arcsin_minus_1 arcsin_plus_arccos arctan arctan_less_pi4_pos arctan_one arctan_zero_zero cos_45 eq_divide_eq mult_cancel_left1 real_div_sqrt real_divide_square_eq)

lemma "angOfVec (Matrix[[1,1]]) = pi / 4" \<comment> \<open> 45 degree angOfVector \<close>
  by (simp add: angOfVec_def vangle_def arccos_inv_sqrt2 vec_norm)

lemma "angOfVec (Matrix[[1,0]]) = pi / 2" \<comment> \<open> 90 degree angOfVector \<close>
  by (simp add: angOfVec_def vangle_def)

lemma "sqrt 2 \<ge> 0"
  by (metis real_sqrt_ge_0_iff zero_le_numeral)

lemma arccos_minus_inv_sqrt2: "arccos (- (1 / sqrt 2)) = 3 * (pi / 4)"
  apply (subst arccos_minus, simp_all add: field_simps)
  apply (metis le_minus_one_simps(2) one_le_numeral order_trans real_sqrt_ge_1_iff)
  apply (metis arccos_inv_sqrt2 divide_cancel_right nonzero_mult_div_cancel_left zero_neq_numeral)
  done

lemma "angOfVec (Matrix[[1,-1]]) = 3 * (pi / 4)" \<comment> \<open> 135 degree angOfVector \<close>
  apply (simp add: angOfVec_def vangle_def vec_norm arccos_minus)
  apply (metis arccos_minus_inv_sqrt2 eq_divide_eq_numeral1(1) times_divide_eq_right zero_neq_numeral)
  done

lemma "angDiff (pi/2) (pi/4) False = pi/4"
  by (simp add: angDiff_def)

lemma "angDiff (pi) (pi/4) False = 3 / 4 * pi"
  by (simp add: angDiff_def)

subsection \<open> AMV Constants \<close>

abbreviation "m \<equiv> 12"            \<comment> \<open> Mass \<close>
abbreviation "S \<equiv> 1.5"           \<comment> \<open> Maximum speed \<close>
definition [expr_defs]: "f\<^sub>m\<^sub>a\<^sub>x \<equiv> 9 * 9.80665" \<comment> \<open> Maximum force \<close>
abbreviation "\<phi>\<^sub>\<epsilon> \<equiv> 0.001"        \<comment> \<open> Angular tolerance \<close>
abbreviation "s\<^sub>\<epsilon> \<equiv> 0.001"        \<comment> \<open> Linear tolerance \<close>

abbreviation "kp\<^sub>g\<^sub>v \<equiv> 5"
abbreviation "kp\<^sub>g\<^sub>r \<equiv> 5"

abbreviation "w\<^sub>\<epsilon> \<equiv> 0.5" \<comment> \<open> Waypoint tolerance \<close>

definition "(\<epsilon>::real) \<equiv> 0.1"

subsection \<open> AMV State Space \<close>

datatype OPMode = OCM | HCM | MOM

alphabet 's AMVs =
  old :: 's
  \<comment> \<open> Continuous Variables \<close>
  p :: "real vec[2]" \<comment> \<open> Position \<close>
  v :: "real vec[2]" \<comment> \<open> Velocity \<close>
  a :: "real vec[2]" \<comment> \<open> Acceleration \<close>
  \<phi> :: "real" \<comment> \<open> Heading \<close>
  s :: "real" \<comment> \<open> Linear Speed \<close>
  t :: "real" \<comment> \<open> Timer \<close>
  \<comment> \<open> Discrete Variables\<close>
  path    :: "(real vec[2]) list" \<comment> \<open> Path of way points \<close>
  nextWP  :: "real vec[2]" \<comment> \<open> Location of next way point \<close>
  obsReg  :: "(real vec[2]) set" \<comment> \<open> Obstacle register \<close>
  rs      :: "real" \<comment> \<open> Requested speed \<close>
  rh      :: "real" \<comment> \<open> Requested heading \<close>
  ft      :: "real"
  fl      :: "real"
  F       :: "real vec[2]" \<comment> \<open> Force vector \<close>
  mode    :: OPMode \<comment> \<open> LRE Operating Mode \<close>

abbreviation "w\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L nextWP"
abbreviation "w\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L nextWP"

abbreviation "p\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L p"
abbreviation "p\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L p"

abbreviation "v\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L v"
abbreviation "v\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L v"

abbreviation "a\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L a"
abbreviation "a\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L a"

abbreviation "\<phi>\<^sub>A\<^sub>V \<equiv> (angOfVec v)\<^sub>e"
abbreviation "\<phi>\<^sub>W\<^sub>P \<equiv> (angOfVec (v - nextWP))\<^sub>e"

subsection \<open> AMV Hybrid Model \<close>

abbreviation "\<omega> \<equiv> (if (\<parallel>v\<parallel> = 0) then 0 else arccos((v + a) \<bullet> v / (\<parallel>v + a\<parallel> * \<parallel>v\<parallel>)))\<^sub>e"

subsubsection \<open> AMV Kinematics \<close>

text \<open> Shows the derivative of each continuous variable. \<close>

abbreviation "ax\<^sub>A\<^sub>V \<equiv> (t < \<epsilon> \<and> s *\<^sub>R \<^bold>[[sin(\<phi>), cos(\<phi>)]\<^bold>] = v \<and> 0 \<le> s \<and> s \<le> S)\<^sup>e"

abbreviation "ODE \<equiv>
   { p` = v
   , v` = a
   , a` = 0
   , \<phi>` = @\<omega>
   , s` = if s \<noteq> 0 then (v \<bullet> a) / s else \<parallel>a\<parallel>
   , t` = 1
   | @ax\<^sub>A\<^sub>V }"

abbreviation "Kinematics \<equiv> t ::= 0 ; ODE"

subsubsection \<open> Navigation System \<close>

abbreviation "atWP \<equiv> (\<parallel>nextWP - p\<parallel> < w\<^sub>\<epsilon>)\<^sup>e"

abbreviation "steerToWP \<equiv> rh ::= angOfVec(nextWP - p)" \<comment> \<open> Calculation of heading \<close>

abbreviation "FullStop \<equiv> (rs ::= 0)"

abbreviation "NextWayPoint \<equiv>
  (IF (path = []) THEN FullStop ELSE nextWP ::= hd(path); path ::= tl(path); steerToWP)"

abbreviation
  "Navigation \<equiv> (IF @atWP THEN NextWayPoint ELSE steerToWP)"

subsubsection \<open> Last Response Engine \<close>

abbreviation
  "LRE \<equiv> (\<questiondown>mode = HCM? ; rs ::= 0.1 ; steerToWP)
       \<sqinter> (\<questiondown>mode = OCM? ; skip)
       \<sqinter> (\<questiondown>mode = MOM? ; rs ::= 1 ; steerToWP ;
             IF (\<exists> o. o \<in> obsReg \<and> \<parallel>p - o\<parallel> \<le> 7.5) THEN mode ::= HCM ; rs ::= 0.1 ELSE skip)"

subsubsection \<open> Autopilot \<close>

abbreviation "AP \<equiv>
  IF \<parallel>rs - s\<parallel> > s\<^sub>\<epsilon>
    THEN ft ::= sgn(rs - s)*min(kp\<^sub>g\<^sub>v * \<parallel>rs - s\<parallel>) f\<^sub>m\<^sub>a\<^sub>x
    ELSE ft ::= 0 ;
  IF \<parallel>rh - \<phi>\<parallel> > \<phi>\<^sub>\<epsilon>
    THEN fl ::= sgn(rh - \<phi>)*min(kp\<^sub>g\<^sub>r * \<parallel>rh - \<phi>\<parallel>) f\<^sub>m\<^sub>a\<^sub>x
    ELSE fl ::= 0 ;
  F ::= fl *\<^sub>R \<^bold>[[cos(\<phi>), sin(\<phi>)]\<^bold>]
      + ft *\<^sub>R \<^bold>[[sin(\<phi>), cos(\<phi>)]\<^bold>] ;
  a ::= F /\<^sub>R m"

subsubsection \<open> AMV System \<close>

abbreviation "AMV \<equiv> (Navigation ; LRE ; AP ; Kinematics)\<^sup>*"

subsection \<open> Structural Properties \<close>

lemma AP_nmods: "AP nmods {p, v, s, \<phi>, t}"
  by (simp add: closure)

lemma LRE_nmods: "LRE nmods {p, v, a, s, \<phi>, t}"
  by (simp add: closure)

lemma axAV_LRE_inv: "\<^bold>{@ax\<^sub>A\<^sub>V\<^bold>}LRE\<^bold>{@ax\<^sub>A\<^sub>V\<^bold>}"
  by (rule nmods_invariant[OF LRE_nmods], unrest)

lemma axAV_AP_inv: "\<^bold>{@ax\<^sub>A\<^sub>V\<^bold>}AP\<^bold>{@ax\<^sub>A\<^sub>V\<^bold>}"
  by (rule nmods_invariant[OF AP_nmods], unrest)

subsection \<open> Invariants \<close>

lemma time_pos:
"\<^bold>{t \<ge> 0\<^bold>} ODE \<^bold>{t \<ge> 0\<^bold>}"
  by (dInduct)

lemma "\<^bold>{s = \<parallel>v\<parallel>\<^bold>} ODE \<^bold>{s = \<parallel>v\<parallel>\<^bold>}"
  by (rule diff_weak_on_rule, expr_auto)

lemma "\<^bold>{rs = s \<and> rh = \<phi>\<^bold>} AP \<^bold>{a = 0\<^bold>}"
  by hoare_wp_simp

lemma AP_no_accel_lemma: "\<^bold>{\<parallel>rs - s\<parallel> \<le> s\<^sub>\<epsilon> \<and> rh = \<phi>\<^bold>}AP\<^bold>{a = 0\<^bold>}"
  by hoare_wp_simp

lemma AP_no_accel: "\<^bold>{s \<in> {rs - s\<^sub>\<epsilon>..rs + s\<^sub>\<epsilon>} \<and> rh = \<phi>\<^bold>}AP\<^bold>{a = 0\<^bold>}"
  using AP_no_accel_lemma
  by (rule hoare_conseq, simp_all add: abs_diff_le_iff[THEN sym] abs_minus_commute)

lemma "\<^bold>{rs < s - s\<^sub>\<epsilon> \<and> rh = \<phi>\<^bold>}AP\<^bold>{\<parallel>a\<parallel> > 0\<^bold>}"
  using sin_zero_abs_cos_one by (hoare_wp_auto, fastforce)

declare vec_simps [simp del]

lemma collinear_AP:
  "\<^bold>{s \<ge> 0 \<and> rs \<ge> s \<and> v = s *\<^sub>R \<^bold>[[sin(\<phi>),cos(\<phi>)]\<^bold>] \<and> \<parallel>rh - \<phi>\<parallel> < \<phi>\<^sub>\<epsilon>\<^bold>}
   AP
   \<^bold>{a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel>\<^bold>}"
  by hoare_wp_auto

declare vec_simps [simp]

lemma "\<^bold>{path = [] \<and> @atWP\<^bold>} Navigation \<^bold>{path = [] \<and> rs = 0 \<and> @atWP\<^bold>}"
  by (hoare_wp_simp)

text \<open> If the LRE is in MOM, the way point is in the north-east quadrant wrt. the AMV, and there
  are no nearby obstacles, then the LRE will stay in MOM and request maximum velocity and heading
  within the north-east quadrant. \<close>

lemma LRE_quad1_heading:
  "\<^bold>{mode = MOM \<and> w\<^sub>x > p\<^sub>x \<and> w\<^sub>y > p\<^sub>y \<and> (\<forall> o. o \<in> obsReg \<longrightarrow> \<parallel>p - o\<parallel> > 7.5)\<^bold>}
  LRE
  \<^bold>{mode = MOM \<and> rs = 1 \<and> rh \<in> {0<..<pi / 2}\<^bold>}"
  apply hoare_wp_auto
   apply (rename_tac p w r)
   apply (case_tac p rule: vector_2_cases)
   apply (simp)
   apply (case_tac w rule: vector_2_cases)
   apply (simp)
   apply (auto simp add: angOfVec_def vangle_def vec_norm)
  apply (rule cos_r1)
   apply (rename_tac x\<^sub>1 x\<^sub>2 x\<^sub>1' x\<^sub>2')
   apply (subgoal_tac "0 \<le> (100 * x\<^sub>2' - 100 * x\<^sub>2)")
  apply (subgoal_tac "0 \<le> (100 * sqrt ((x\<^sub>1' - x\<^sub>1)\<^sup>2 + (x\<^sub>2' - x\<^sub>2)\<^sup>2))")
  apply (smt divide_nonneg_nonneg mult_nonneg_nonneg norm_ge_zero vec_simps(2) vec_simps(4))
    apply (simp_all add: vec_simps)
  apply (subst divide_less_eq_1_pos)
  apply (simp_all)
  apply (simp add: sum_power2_gt_zero_iff)
  apply (smt sqrt_le_D zero_less_power)
   apply (rename_tac p w r)
   apply (case_tac p rule: vector_2_cases)
   apply (simp)
   apply (case_tac w rule: vector_2_cases)
   apply (simp)
   apply (auto simp add: vangle_def)
  apply (rule cos_r2)
    apply (simp_all add: vec_norm)
   apply (rename_tac x\<^sub>1 x\<^sub>2 x\<^sub>1' x\<^sub>2')
   apply (subgoal_tac "0 < (100 * x\<^sub>2' - 100 * x\<^sub>2)")
  apply (subgoal_tac "0 < (100 * sqrt ((x\<^sub>1' - x\<^sub>1)\<^sup>2 + (x\<^sub>2' - x\<^sub>2)\<^sup>2))")
  apply simp
  apply (simp add: power2_eq_square sum_squares_gt_zero_iff)
    apply (simp_all)
  apply (smt divide_le_eq_1_pos real_le_rsqrt zero_less_power)
  done

lemma LRE_HCM:
  "\<^bold>{mode = MOM \<and> (\<exists> o. o \<in> obsReg \<and> \<parallel>p - o\<parallel> \<le> 7.5) \<and> \<parallel>angOfVec(nextWP - p) - \<phi>\<parallel> < \<phi>\<^sub>\<epsilon>\<^bold>}
     LRE
   \<^bold>{mode = HCM \<and> rs = 0.1 \<and> \<parallel>rh - \<phi>\<parallel> < \<phi>\<^sub>\<epsilon>\<^bold>}"
  by hoare_wp_simp

lemma
  "\<^bold>{rs = s \<and> \<phi> = 0 \<and> rh = pi\<^bold>}
    AP
   \<^bold>{a = \<^bold>[[kp\<^sub>g\<^sub>r * pi / m, 0]\<^bold>]\<^bold>}"
proof -
  have 1: "(kp\<^sub>g\<^sub>r * pi) < (1765197 / 20000)"
    by (approximation 20)
  show ?thesis
    apply hoare_wp_auto
    using "1" apply linarith
    using pi_gt3 apply auto
    done
qed

lemma "\<^bold>{t = 0 \<and> v = $old:v\<^bold>}ODE\<^bold>{v = $old:v + t *\<^sub>R a\<^bold>}"
proof -
  have 1: "\<^bold>{v = $old:v + t *\<^sub>R a\<^bold>}ODE\<^bold>{v = $old:v + t *\<^sub>R a\<^bold>}"
    by (dInduct)
  thus ?thesis
    by (rule hoare_conseq, simp_all)
qed

text \<open> If the AMV is accelerating in the same direction as the velocity, then it will continue
  to do so. \<close>

lemma collinear_vector_accel:
  "\<^bold>{a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel>\<^bold>}
    ODE
   \<^bold>{a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel>\<^bold>}"
proof -
  have "\<^bold>{a \<bullet> v \<ge> 0 \<and> (a \<bullet> v)\<^sup>2 = (a \<bullet> a) * (v \<bullet> v)\<^bold>}
        ODE
       \<^bold>{a \<bullet> v \<ge> 0 \<and> (a \<bullet> v)\<^sup>2 = (a \<bullet> a) * (v \<bullet> v)\<^bold>}"
    apply (dInduct_mega)
    using inner_commute by blast
  hence "\<^bold>{a \<bullet> v \<ge> 0 \<and> a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel>\<^bold>}
          ODE
         \<^bold>{a \<bullet> v \<ge> 0 \<and> a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel>\<^bold>}"
    apply (rule hoare_conseq)
    apply (expr_auto)
     apply (simp add: power2_norm_eq_inner power_mult_distrib)
    apply (expr_auto)
    apply (metis Cauchy_Schwarz_eq2_iff Cauchy_Schwarz_eq_iff abs_of_nonneg)
    done

  thus ?thesis
    by (rule hoare_conseq; expr_auto)
qed

text \<open> Collinearity of the acceleration and velocity implies no rotational velocity \<close>

lemma "`a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel> \<longrightarrow> @\<omega> = 0`"
  apply (simp add: expr_defs lens_defs alpha_splits)
  apply (simp add: algebra_simps)
  by (smt inner_gt_zero_iff mult_nonneg_nonneg norm_ge_zero)

lemma "\<^bold>{(a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel> \<and> s = \<parallel>v\<parallel>) \<and> t \<ge> 0 \<and> t < \<epsilon> \<and>
        v = t *\<^sub>R a + $old:v \<and>
        p = (t\<^sup>2 * 0.5) *\<^sub>R a + t *\<^sub>R $old:v + $old:p\<^bold>}
        ODE
       \<^bold>{t \<ge> 0 \<and> t < \<epsilon> \<and>
        v = t *\<^sub>R a + $old:v \<and>
        p = (t\<^sup>2 * 0.5) *\<^sub>R a + t *\<^sub>R $old:v + $old:p\<^bold>}"
  by (dInduct_mega facts: collinear_vector_accel)

lemma "\<^bold>{a = 0 \<and> v = V\<^bold>}ODE\<^bold>{a = 0 \<and> v = V\<^bold>}"
  by (dInduct_mega)

declare eq_divide_eq_numeral1 [simp del]

lemma [simp]: "sqrt (1/100) = 1/10"
  by (rule real_sqrt_unique, simp_all add: field_simps)

lemma [simp]: "sqrt (9 / 64) = 0.375"
  by (rule real_sqrt_unique, simp_all add: field_simps)

text \<open> If the AMV is on course then the calculate acceleration vector is always
  collinear with the velocity vector. \<close>

lemma "\<^bold>{s \<ge> 0 \<and> rs > s \<and> \<phi> = pi / 2 \<and> rh = pi / 2
        \<and> v = s *\<^sub>R \<^bold>[[sin(\<phi>),cos(\<phi>)]\<^bold>]\<^bold>}
        AP
       \<^bold>{a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel>\<^bold>}"
  apply (hoare_wp_auto)
  apply (rename_tac s rs)
  apply (simp add: vec_norm)
  done

declare vec_simps [simp del]

lemma vs1: "\<^bold>[[k * x, k * y]\<^bold>] = k *\<^sub>R \<^bold>[[x, y]\<^bold>]"
  by (simp add: vec_simps(1))

lemma "\<^bold>{s \<ge> 0 \<and> rs > s \<and> \<parallel>rh - \<phi>\<parallel> < \<phi>\<^sub>\<epsilon>
        \<and> v = s *\<^sub>R \<^bold>[[sin(\<phi>),cos(\<phi>)]\<^bold>]\<^bold>}
        AP
       \<^bold>{a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel>\<^bold>}"
  by (hoare_wp_auto)

text \<open> If the AMV is accelerating towards its orientation then the speed increases. \<close>

lemma
  "\<^bold>{(a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel> \<and> (a \<bullet> a) > 0) \<and> s \<ge> $old:s\<^bold>}
    ODE
   \<^bold>{s \<ge> $old:s\<^bold>}"
  by (dInduct_mega facts: collinear_vector_accel, simp add: inner_commute)

lemma no_turn_no_accel:
"\<^bold>{(a = 0 \<and> s > 0) \<and> \<phi> = X\<^bold>} ODE \<^bold>{\<phi> = X\<^bold>}"
  by (dInduct_mega)

lemma no_turn_when_straight:
 "\<^bold>{a \<bullet> v = \<parallel>a\<parallel> * \<parallel>v\<parallel> \<and> \<phi> = X\<^bold>} ODE \<^bold>{\<phi> = X\<^bold>}"
  apply (dInduct_mega facts: collinear_vector_accel)
  oops

text \<open> Link with CyPhyCircus. Differentiation on a domain. Unit vector d? DAEs via unknowns in ODE? \<close>

lemma "\<lbrakk> \<And> x y. P \<^bold>[[x, y]\<^bold>] \<rbrakk> \<Longrightarrow> P X"
  by (metis vector_2_cases)

lemma translational_speed: "\<^bold>{s\<^sup>2 = (v \<bullet> v)\<^bold>}  ODE \<^bold>{s\<^sup>2 = (v \<bullet> v)\<^bold>}" by (dWeaken)

lemma "`s > 0 \<and> s\<^sup>2 = (v \<bullet> v) \<longrightarrow> s = \<parallel>v\<parallel>`"
  by (expr_simp, metis less_eq_real_def norm_eq_square)

find_theorems "(differentiable)" norm

lemma "\<lbrakk> (x::real) \<ge> 0; y \<ge> 0 \<rbrakk> \<Longrightarrow> x < y \<longleftrightarrow> x\<^sup>2 < y\<^sup>2"
  by (smt power2_le_imp_le)

lemma "0 \<le> arccos x \<longleftrightarrow> (-1 \<le> x \<and> x \<le> 1)"
  oops

lemma "\<^bold>{True\<^bold>} AP \<^bold>{ft \<le> f\<^sub>m\<^sub>a\<^sub>x\<^bold>}"
  apply (simp add: wlp usubst_eval)
  oops

(*
lemma "\<^bold>{\<parallel>a\<parallel> \<le> f\<^sub>m\<^sub>a\<^sub>x / m\<^bold>} AP \<^bold>{\<parallel>a\<parallel> \<le> f\<^sub>m\<^sub>a\<^sub>x / m\<^bold>}"
  apply (hoare_wp_auto)
*)

lemma "\<^bold>{\<parallel>a\<parallel> \<le> f\<^sub>m\<^sub>a\<^sub>x / m\<^bold>} ODE \<^bold>{\<parallel>a\<parallel> \<le> f\<^sub>m\<^sub>a\<^sub>x / m\<^bold>}"
  oops

lemma "\<^bold>{\<phi> \<ge> 0\<^bold>} ODE \<^bold>{\<phi> \<ge> 0\<^bold>}"
  apply (dInduct)
  apply (expr_auto)
   apply (auto intro!: arccos_lbound)
  oops

lemma "\<^bold>{ (\<parallel>angOfVec(nextWP - p) - \<phi>\<parallel>)\<^sup>2 < \<phi>\<^sub>\<epsilon>\<^sup>2 \<^bold>} ODE \<^bold>{ (\<parallel>angOfVec(nextWP - p) - \<phi>\<parallel>)\<^sup>2 < \<phi>\<^sub>\<epsilon>\<^sup>2 \<^bold>}"
  apply (subst hoare_diff_inv_on')
  apply (subgoal_tac "(Collect ((\<le>) 0))\<^sub>e = ({t. t \<ge> 0})\<^sub>e")
   prefer 2 apply simp
  apply simp
  apply (rule_tac lderiv_rules)
     apply (simp_all add: ldifferentiable closure)
   apply (rule ldifferentiable, simp, expr_simp)
  oops

lemma "\<^bold>{ \<parallel>angOfVec(nextWP - p) - \<phi>\<parallel> < \<phi>\<^sub>\<epsilon> \<^bold>} ODE \<^bold>{ \<parallel>angOfVec(nextWP - p) - \<phi>\<parallel> < \<phi>\<^sub>\<epsilon> \<^bold>}"
  apply (dInduct)
  oops

end