(*
  Verified Knuth-Morris-Pratt String Search Algorithm in LLVM.
  Adapted from Fabian Hellauer, Peter Lammich: AFP/Knuth_Morris_Pratt by
*)
theory KMP
  imports "../sepref/IICF/IICF"
    "HOL-Library.Sublist"
begin

declare len_greater_imp_nonempty[simp del] min_absorb2[simp]

section\<open>Specification\<close>text_raw\<open>\label{sec:spec}\<close>

subsection\<open>Sublist-predicate with a position check\<close>

subsubsection\<open>Definition\<close>

text \<open>One could define\<close>
definition "sublist_at' xs ys i \<equiv> take (length xs) (drop i ys) = xs"

text\<open>However, this doesn't handle out-of-bound indexes uniformly:\<close>
value[nbe] "sublist_at' [] [a] 5"
value[nbe] "sublist_at' [a] [a] 5"
value[nbe] "sublist_at' [] [] 5"

text\<open>Instead, we use a recursive definition:\<close>
fun sublist_at :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> bool" where
  "sublist_at (x#xs) (y#ys) 0 \<longleftrightarrow> x=y \<and> sublist_at xs ys 0" |
  "sublist_at xs (y#ys) (Suc i) \<longleftrightarrow> sublist_at xs ys i" |
  "sublist_at [] ys 0 \<longleftrightarrow> True" |
  "sublist_at _ [] _ \<longleftrightarrow> False"

text\<open>In the relevant cases, both definitions agree:\<close>
lemma "i \<le> length ys \<Longrightarrow> sublist_at xs ys i \<longleftrightarrow> sublist_at' xs ys i"
  unfolding sublist_at'_def
  by (induction xs ys i rule: sublist_at.induct) auto

text\<open>However, the new definition has some reasonable properties:\<close>
subsubsection\<open>Properties\<close>
lemma sublist_lengths: "sublist_at xs ys i \<Longrightarrow> i + length xs \<le> length ys"
  by (induction xs ys i rule: sublist_at.induct) auto

text\<open>Furthermore, we need:\<close>
lemma sublist_step[intro]:
  "\<lbrakk>i + length xs < length ys; sublist_at xs ys i; ys!(i + length xs) = x\<rbrakk> \<Longrightarrow> sublist_at (xs@[x]) ys i"
  apply (induction xs ys i rule: sublist_at.induct)
      apply auto
  using sublist_at.elims(3) by fastforce

lemma all_positions_sublist:
"\<lbrakk>i + length xs \<le> length ys; \<forall>jj<length xs. ys!(i+jj) = xs!jj\<rbrakk> \<Longrightarrow> sublist_at xs ys i"
proof (induction xs rule: rev_induct)
  case Nil
  then show ?case by (simp add: Nil_is_sublist)
next
  case (snoc x xs)
  from \<open>i + length (xs @ [x]) \<le> length ys\<close> have "i + length xs \<le> length ys" by simp
  moreover have "\<forall>jj<length xs. ys!(i + jj) = xs!jj"
    by (simp add: nth_append snoc.prems(2))
  ultimately have "sublist_at xs ys i"
    using snoc.IH by simp
  then show ?case
    using snoc.prems by auto
qed

lemma sublist_all_positions: "sublist_at xs ys i \<Longrightarrow> \<forall>jj<length xs. ys!(i+jj) = xs!jj"
  by (induction xs ys i rule: sublist_at.induct) (auto simp: nth_Cons')

text\<open>It also connects well to theory @{theory "HOL-Library.Sublist"} (compare @{thm[source] sublist_def}):\<close>
lemma sublist_at_altdef:
  "sublist_at xs ys i \<longleftrightarrow> (\<exists>ps ss. ys = ps@xs@ss \<and> i = length ps)"
proof (induction xs ys i rule: sublist_at.induct)
  case (2 ss t ts i)
  show "sublist_at ss (t#ts) (Suc i) \<longleftrightarrow> (\<exists>xs ys. t#ts = xs@ss@ys \<and> Suc i = length xs)"
    (is "?lhs \<longleftrightarrow> ?rhs")
  proof
    assume ?lhs
    then have "sublist_at ss ts i" by simp
    with "2.IH" obtain xs where "\<exists>ys. ts = xs@ss@ys \<and> i = length xs" by auto
    then have "\<exists>ys. t#ts = (t#xs)@ss@ys \<and> Suc i = length (t#xs)" by simp
    then show ?rhs by blast
  next
    assume ?rhs
    then obtain xs where "\<exists>ys. t#ts = xs@ss@ys \<and> Suc i = length xs" by blast
    then have "\<exists>ys. ts = (tl xs)@ss@ys \<and> i = length (tl xs)"
      by (metis hd_Cons_tl length_0_conv list.sel(3) nat.simps(3) size_Cons_lem_eq tl_append2)
    then have "\<exists>xs ys. ts = xs@ss@ys \<and> i = length xs" by blast
    with "2.IH" show ?lhs by simp
  qed
qed auto

corollary sublist_iff_sublist_at: "Sublist.sublist xs ys \<longleftrightarrow> (\<exists>i. sublist_at xs ys i)"
  by (simp add: sublist_at_altdef Sublist.sublist_def)

subsection\<open>Sublist-check algorithms\<close>

text\<open>
  We use the Isabelle Refinement Framework to
  phrase the specification and the algorithm.
\<close>
text\<open>@{term s} for "searchword" / "searchlist", @{term t} for "text"\<close>
definition "kmp_SPEC s t = SPEC (\<lambda>
  None \<Rightarrow> \<nexists>i. sublist_at s t i |
  Some i \<Rightarrow> sublist_at s t i \<and> (\<forall>ii<i. \<not>sublist_at s t ii))"

lemma is_arg_min_id: "is_arg_min id P i \<longleftrightarrow> P i \<and> (\<forall>ii<i. \<not>P ii)"
  unfolding is_arg_min_def by auto

lemma kmp_result: "kmp_SPEC s t =
  RETURN (if sublist s t then Some (LEAST i. sublist_at s t i) else None)"
  unfolding kmp_SPEC_def sublist_iff_sublist_at
  apply (auto intro: LeastI dest: not_less_Least split: option.splits)
  by (meson LeastI nat_neq_iff not_less_Least)

corollary weak_kmp_SPEC: "kmp_SPEC s t \<le> SPEC (\<lambda>pos. pos\<noteq>None \<longleftrightarrow> Sublist.sublist s t)"
  by (simp add: kmp_result)

lemmas kmp_SPEC_altdefs =
  kmp_SPEC_def[folded is_arg_min_id]
  kmp_SPEC_def[folded sublist_iff_sublist_at]
  kmp_result

section\<open>Naive algorithm\<close>

text\<open>Since KMP is a direct advancement of the naive "test-all-starting-positions" approach, we provide it here for comparison:\<close>

subsection\<open>Invariants\<close>
definition "I_out_na s t \<equiv> \<lambda>(i,j,pos).
  (\<forall>ii<i. \<not>sublist_at s t ii) \<and>
  (case pos of None \<Rightarrow> j = 0
    | Some p \<Rightarrow> p=i \<and> sublist_at s t i)"
definition "I_in_na s t i \<equiv> \<lambda>(j,pos).
  case pos of None \<Rightarrow> j < length s \<and> (\<forall>jj<j. t!(i+jj) = s!(jj))
    | Some p \<Rightarrow> sublist_at s t i"

subsection\<open>Algorithm\<close>

(*Algorithm is common knowledge \<longrightarrow> remove citation here, move explanations to KMP below?*)
text\<open>The following definition is taken from Helmut Seidl's lecture on algorithms and data structures@{cite GAD} except that we
\<^item> output the identified position @{term \<open>pos :: nat option\<close>} instead of just @{const True}
\<^item> use @{term \<open>pos :: nat option\<close>} as break-flag to support the abort within the loops
\<^item> rewrite @{prop \<open>i \<le> length t - length s\<close>} in the first while-condition to @{prop \<open>i + length s \<le> length t\<close>} to avoid having to use @{typ int} for list indexes (or the additional precondition @{prop \<open>length s \<le> length t\<close>})
\<close>

definition "naive_algorithm s t \<equiv> do {
  let i=0;
  let j=0;
  let pos=None;
  (_,_,pos) \<leftarrow> WHILEIT (I_out_na s t) (\<lambda>(i,_,pos). i + length s \<le> length t \<and> pos=None) (\<lambda>(i,j,pos). do {
    (_,pos) \<leftarrow> WHILEIT (I_in_na s t i) (\<lambda>(j,pos). t!(i+j) = s!j \<and> pos=None) (\<lambda>(j,_). do {
      let j=j+1;
      if j=length s then RETURN (j,Some i) else RETURN (j,None)
    }) (j,pos);
    if pos=None then do {
      let i = i + 1;
      let j = 0;
      RETURN (i,j,None)
    } else RETURN (i,j,Some i)
  }) (i,j,pos);

  RETURN pos
}"

subsection\<open>Correctness\<close>

text\<open>The basic lemmas on @{const sublist_at} from the previous chapter together
  with the Refinement Framework's verification condition generator / solver suffice:\<close>

lemma "s \<noteq> [] \<Longrightarrow> naive_algorithm s t \<le> kmp_SPEC s t"
  unfolding naive_algorithm_def kmp_SPEC_def I_out_na_def I_in_na_def
  apply (refine_vcg
    WHILEIT_rule[where R="measure (\<lambda>(i,_,pos). length t - i + (if pos = None then 1 else 0))"]
    WHILEIT_rule[where R="measure (\<lambda>(j,_::nat option). length s - j)"]
    )
                 apply (all \<open>clarsimp;(auto; fail)?\<close>)
  subgoal by (metis add_Suc_right all_positions_sublist less_antisym)
  subgoal using less_Suc_eq by blast
  subgoal by (metis less_SucE sublist_all_positions)
  subgoal by (auto split: option.splits) (metis sublist_lengths add_less_cancel_right leI le_less_trans)
  done

text\<open>Note that the precondition cannot be removed without an extra branch: If @{prop \<open>s = []\<close>}, the inner while-condition accesses out-of-bound memory. This will apply to KMP, too.\<close>

section\<open>Knuth--Morris--Pratt algorithm\<close>

text\<open>Just like our templates@{cite KMP77}@{cite GAD}, we first verify the main routine and discuss the computation of the auxiliary values @{term \<open>\<ff> s\<close>} only in a later section.\<close>

subsection\<open>Preliminaries: Borders of lists\<close>

definition "border xs ys \<longleftrightarrow> prefix xs ys \<and> suffix xs ys"
definition "strict_border xs ys \<longleftrightarrow> border xs ys \<and> length xs < length ys"
definition "intrinsic_border ls \<equiv> ARG_MAX length b. strict_border b ls"

subsubsection\<open>Properties\<close>

interpretation border_order: order border strict_border
  by standard (auto simp: border_def suffix_def strict_border_def)
interpretation border_bot: order_bot Nil border strict_border
  by standard (simp add: border_def)

lemma borderE[elim]:
  fixes xs ys :: "'a list"
  assumes "border xs ys"
  obtains "prefix xs ys" and "suffix xs ys"
  using assms unfolding border_def by blast

lemma strict_borderE[elim]:
  fixes xs ys :: "'a list"
  assumes "strict_border xs ys"
  obtains "border xs ys" and "length xs < length ys"
  using assms unfolding strict_border_def by blast

lemma strict_border_simps[simp]:
  "strict_border xs [] \<longleftrightarrow> False"
  "strict_border [] (x # xs) \<longleftrightarrow> True"
  by (simp_all add: strict_border_def)

lemma strict_border_prefix: "strict_border xs ys \<Longrightarrow> strict_prefix xs ys"
  and strict_border_suffix: "strict_border xs ys \<Longrightarrow> strict_suffix xs ys"
  and strict_border_imp_nonempty: "strict_border xs ys \<Longrightarrow> ys \<noteq> []"
  and strict_border_prefix_suffix: "strict_border xs ys \<longleftrightarrow> strict_prefix xs ys \<and> strict_suffix xs ys"
  by (auto simp: border_order.order.strict_iff_order border_def)

lemma border_length_le: "border xs ys \<Longrightarrow> length xs \<le> length ys"
  unfolding border_def by (simp add: prefix_length_le)

lemma border_length_r_less (*rm*): "\<forall>xs. strict_border xs ys \<longrightarrow> length xs < length ys"
  using strict_borderE by auto

lemma all_positions_drop_length_take: "\<lbrakk>i \<le> length w; i \<le> length x;
  \<forall>j<i. x ! j = w ! (length w + j - i)\<rbrakk>
    \<Longrightarrow> drop (length w - i) w = take i x"
  by (cases "i = length x") (auto intro: nth_equalityI)

lemma all_positions_suffix_take: "\<lbrakk>i \<le> length w; i \<le> length x;
  \<forall>j<i. x ! j = w ! (length w + j - i)\<rbrakk>
    \<Longrightarrow> suffix (take i x) w"
  by (metis all_positions_drop_length_take suffix_drop)

lemma suffix_butlast: "suffix xs ys \<Longrightarrow> suffix (butlast xs) (butlast ys)"
  unfolding suffix_def by (metis append_Nil2 butlast.simps(1) butlast_append)

lemma positions_border: "\<forall>j<l. w!j = w!(length w - l + j) \<Longrightarrow> border (take l w) w"
  by (cases "l < length w") (simp_all add: border_def all_positions_suffix_take take_is_prefix)

lemma positions_strict_border: "l < length w \<Longrightarrow> \<forall>j<l. w!j = w!(length w - l + j) \<Longrightarrow> strict_border (take l w) w"
  by (simp add: positions_border strict_border_def)

lemmas intrinsic_borderI = arg_max_natI[OF _ border_length_r_less, folded intrinsic_border_def]

lemmas intrinsic_borderI' = border_bot.bot.not_eq_extremum[THEN iffD1, THEN intrinsic_borderI]

lemmas intrinsic_border_max = arg_max_nat_le[OF _ border_length_r_less, folded intrinsic_border_def]

lemma nonempty_is_arg_max_ib: "ys \<noteq> [] \<Longrightarrow> is_arg_max length (\<lambda>xs. strict_border xs ys) (intrinsic_border ys)"
  by (simp add: intrinsic_borderI' intrinsic_border_max is_arg_max_linorder)

lemma intrinsic_border_less: "w \<noteq> [] \<Longrightarrow> length (intrinsic_border w) < length w"
  using intrinsic_borderI[of w] border_length_r_less intrinsic_borderI' by blast

lemma intrinsic_border_take_less: "j > 0 \<Longrightarrow> w \<noteq> [] \<Longrightarrow> length (intrinsic_border (take j w)) < length w"
  by (metis intrinsic_border_less length_take less_not_refl2 min_less_iff_conj take_eq_Nil)

subsubsection\<open>Examples\<close>

lemma border_example: "{b. border b ''aabaabaa''} = {'''', ''a'', ''aa'', ''aabaa'', ''aabaabaa''}"
  (is "{b. border b ?l} = {?take0, ?take1, ?take2, ?take5, ?l}")
proof
  show "{?take0, ?take1, ?take2, ?take5, ?l} \<subseteq> {b. border b ?l}"
    by simp eval
  have "\<not>border ''aab'' ?l" "\<not>border ''aaba'' ?l" "\<not>border ''aabaab'' ?l" "\<not>border ''aabaaba'' ?l"
    by eval+
  moreover have "{b. border b ?l} \<subseteq> set (prefixes ?l)"
    using border_def in_set_prefixes by blast
  ultimately show "{b. border b ?l} \<subseteq> {?take0, ?take1, ?take2, ?take5, ?l}"
    by auto
qed

corollary strict_border_example: "{b. strict_border b ''aabaabaa''} = {'''', ''a'', ''aa'', ''aabaa''}"
  (is "?l = ?r")
proof
  have "?l \<subseteq> {b. border b ''aabaabaa''}"
    by auto
  also have "\<dots> = {'''', ''a'', ''aa'', ''aabaa'', ''aabaabaa''}"
    by (fact border_example)
  finally show "?l \<subseteq> ?r" by auto
  show "?r \<subseteq> ?l" by simp eval
qed

corollary "intrinsic_border ''aabaabaa'' = ''aabaa''"
proof - \<comment> \<open>We later obtain a fast algorithm for that.\<close>
  have exhaust: "strict_border b ''aabaabaa'' \<longleftrightarrow> b \<in> {'''', ''a'', ''aa'', ''aabaa''}" for b
    using strict_border_example by auto
  then have
    "\<not>is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''''"
    "\<not>is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''a''"
    "\<not>is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''aa''"
    "is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''aabaa''"
    unfolding is_arg_max_linorder by auto
  moreover have "strict_border (intrinsic_border ''aabaabaa'') ''aabaabaa''"
    using intrinsic_borderI' by blast
  note this[unfolded exhaust]
  ultimately show ?thesis
    by simp (metis list.discI nonempty_is_arg_max_ib)
qed

subsection\<open>Main routine\<close>

text\<open>The following is Seidl's "border"-table@{cite GAD} (values shifted by 1 so we don't need @{typ int}),
or equivalently, "f" from Knuth's, Morris' and Pratt's paper@{cite KMP77} (with indexes starting at 0).\<close>
fun \<ff> :: "'a list \<Rightarrow> nat \<Rightarrow> nat" where
  "\<ff> s 0 = 0" \<comment> \<open>This increments the compare position while @{prop \<open>j=(0::nat)\<close>}\<close> |
  "\<ff> s j = length (intrinsic_border (take j s)) + 1"
text\<open>Note that we use their "next" only implicitly.\<close>

subsubsection\<open>Invariants\<close>
definition "I_outer s t \<equiv> \<lambda>(i,j,pos).
  (\<forall>ii<i. \<not>sublist_at s t ii) \<and>
  (i\<le>length t) \<and>
  (case pos of None \<Rightarrow> (\<forall>jj<j. t!(i+jj) = s!(jj)) \<and> j < length s
    | Some p \<Rightarrow> p=i \<and> sublist_at s t i)"
text\<open>For the inner loop, we can reuse @{const I_in_na}.\<close>

subsubsection\<open>Algorithm\<close>
text\<open>First, we use the non-evaluable function @{const \<ff>} directly:\<close>
definition "kmp s t \<equiv> do {
  ASSERT (s \<noteq> []);
  let i=0;
  let j=0;
  let pos=None;
  (_,_,pos) \<leftarrow> WHILEIT (I_outer s t) (\<lambda>(i,j,pos). i + length s \<le> length t \<and> pos=None) (\<lambda>(i,j,pos). do {
    ASSERT (i + length s \<le> length t);
    (j,pos) \<leftarrow> WHILEIT (I_in_na s t i) (\<lambda>(j,pos). t!(i+j) = s!j \<and> pos=None) (\<lambda>(j,pos). do {
      let j=j+1;
      if j=length s then RETURN (j,Some i) else RETURN (j,None)
    }) (j,pos);
    if pos=None then do {
      ASSERT (j < length s \<and> \<ff> s j \<le> j);
      let i = i + (j - \<ff> s j + 1);
      let j = max 0 (\<ff> s j - 1); \<comment> \<open>\<open>max\<close> not necessary, but indicates that subtraction may actually underflow\<close>
      RETURN (i,j,None)
    } else RETURN (i,j,Some i)
  }) (i,j,pos);

  RETURN pos
}"

subsubsection\<open>Correctness\<close>
lemma \<ff>_eq_0_iff_j_eq_0[simp]: "\<ff> s j = 0 \<longleftrightarrow> j = 0"
  by (cases j) simp_all

lemma j_le_\<ff>_le: "j \<le> length s \<Longrightarrow> \<ff> s j \<le> j"
  apply (cases j)
  apply simp_all
  by (metis Suc_leI intrinsic_border_less length_take list.size(3) min.absorb2 nat.simps(3) not_less)

lemma j_le_\<ff>_le': "0 < j \<Longrightarrow> j \<le> length s \<Longrightarrow> \<ff> s j - 1 < j"
  by (metis diff_less j_le_\<ff>_le le_eq_less_or_eq less_imp_diff_less less_one)

lemma \<ff>_le: "s \<noteq> [] \<Longrightarrow> \<ff> s j - 1 < length s"
  by (cases j) (simp_all add: intrinsic_border_take_less)

(*
  Only needed for run-time analysis
*)
lemma "p576 et seq":
  assumes
    "j \<le> length s" and
    assignments:
    "i' = i + (j + 1 - \<ff> s j)"
    "j' = max 0 (\<ff> s j - 1)"
  shows
    sum_no_decrease: "i' + j' \<ge> i + j" and
    i_increase: "i' > i"
  using assignments by (simp_all add: j_le_\<ff>_le[OF assms(1), THEN le_imp_less_Suc])

lemma reuse_matches:
  assumes j_le: "j \<le> length s"
  and old_matches: "\<forall>jj<j. t ! (i + jj) = s ! jj"
  shows "\<forall>jj<\<ff> s j - 1. t ! (i + (j - \<ff> s j + 1) + jj) = s ! jj"
    (is "\<forall>jj<?j'. t ! (?i' + jj) = s ! jj")
proof (cases "j>0")
  assume "j>0"
  have \<ff>_le: "\<ff> s j \<le> j"
    by (simp add: j_le j_le_\<ff>_le)
  with old_matches have 1: "\<forall>jj<?j'. t ! (?i' + jj) = s ! (j - \<ff> s j + 1 + jj)"
    by (metis ab_semigroup_add_class.add.commute add.assoc diff_diff_cancel less_diff_conv)
  have [simp]: "length (take j s) = j" "length (intrinsic_border (take j s)) = ?j'"
    by (simp add: j_le) (metis \<open>0 < j\<close> diff_add_inverse2 \<ff>.elims nat_neq_iff)
  then have "\<forall>jj<?j'. take j s ! jj = take j s ! (j - (\<ff> s j - 1) + jj)"
    by (metis intrinsic_borderI' \<open>0 < j\<close> border_positions length_greater_0_conv strict_border_def)
  then have "\<forall>jj<?j'. take j s ! jj = take j s ! (j - \<ff> s j + 1 + jj)"
    by (simp add: \<ff>_le)
  then have 2: "\<forall>jj<?j'. s ! (j - \<ff> s j + 1 + jj) = s ! jj"
    using \<ff>_le by simp
  from 1 2 show ?thesis by simp
qed simp

theorem shift_safe:
  assumes
    "\<forall>ii<i. \<not>sublist_at s t ii"
    "t!(i+j) \<noteq> s!j" and
    [simp]: "j < length s" and
    matches: "\<forall>jj<j. t!(i+jj) = s!jj"
  defines
    assignment: "i' \<equiv> i + (j - \<ff> s j + 1)"
  shows
    "\<forall>ii<i'. \<not>sublist_at s t ii"
proof (standard, standard)
  fix ii
  assume "ii < i'"
  then consider \<comment> \<open>The position falls into one of three categories:\<close>
    (old) "ii < i" |
    (current) "ii = i" |
    (skipped) "ii > i"
    by linarith
  then show "\<not>sublist_at s t ii"
  proof cases
    case old \<comment> \<open>Old position, use invariant.\<close>
    with \<open>\<forall>ii<i. \<not>sublist_at s t ii\<close> show ?thesis by simp
  next
    case current \<comment> \<open>The mismatch occurred while testing this alignment.\<close>
    with \<open>t!(i+j) \<noteq> s!j\<close> show ?thesis
      using sublist_all_positions[of s t i] by auto
  next
    case skipped \<comment> \<open>The skipped positions.\<close>
    then have "0<j"
      using \<open>ii < i'\<close> assignment by linarith
    then have less_j[simp]: "j + i - ii < j" and le_s: "j + i - ii \<le> length s"
      using \<open>ii < i'\<close> assms(3) skipped by linarith+
    note \<ff>_le[simp] = j_le_\<ff>_le[OF assms(3)[THEN less_imp_le]]
    have "0 < \<ff> s j"
      using \<open>0 < j\<close> \<ff>_eq_0_iff_j_eq_0 neq0_conv by blast
    then have "j + i - ii > \<ff> s j - 1"
      using \<open>ii < i'\<close> assignment \<ff>_le by linarith
    then have contradiction_goal: "j + i - ii > length (intrinsic_border (take j s))"
      by (metis \<ff>.elims \<open>0 < j\<close> add_diff_cancel_right' not_gr_zero)
    show ?thesis
    proof
      assume "sublist_at s t ii"
      note sublist_all_positions[OF this]
      with le_s have a: "\<forall>jj < j+i-ii. t!(ii+jj) = s!jj"
        by simp
      have ff1: "\<not> ii < i"
        by (metis not_less_iff_gr_or_eq skipped)
      then have "i + (ii - i + jj) = ii + jj" for jj
        by (metis add.assoc add_diff_inverse_nat)
      then have "\<not> jj < j + i - ii \<or> t ! (ii + jj) = s ! (ii - i + jj)" if "ii - i + jj < j" for jj
        using that ff1 by (metis matches)
      then have "\<not> jj < j + i - ii \<or> t ! (ii + jj) = s ! (ii - i + jj)" for jj
        using ff1 by auto
      with matches have "\<forall>jj < j+i-ii. t!(ii+jj) = s!(ii-i+jj)" by metis
      then have "\<forall>jj < j+i-ii. s!jj = s!(ii-i+jj)"
        using a by auto
      then have "\<forall>jj < j+i-ii. (take j s)!jj = (take j s)!(ii-i+jj)"
        using \<open>i<ii\<close> by auto
      with positions_strict_border[of "j+i-ii" "take j s", simplified]
      have "strict_border (take (j+i-ii) s) (take j s)".
      note intrinsic_border_max[OF this]
      also note contradiction_goal
      also have "j+i-ii \<le> length s" by (fact le_s)
      ultimately
      show False by simp
    qed
  qed
qed

lemma kmp_correct: "s \<noteq> []
  \<Longrightarrow> kmp s t \<le> kmp_SPEC s t"
  unfolding kmp_def kmp_SPEC_def I_outer_def I_in_na_def
  apply (refine_vcg
    WHILEIT_rule[where R="measure (\<lambda>(i,_,pos). length t - i + (if pos = None then 1 else 0))"]
    WHILEIT_rule[where R="measure (\<lambda>(j,_::nat option). length s - j)"]
    )
  apply (all \<open>clarsimp;(auto; fail)?\<close>)
  subgoal by (metis add_Suc_right all_positions_sublist less_antisym)
  subgoal using less_antisym by blast
  subgoal for i jout j using j_le_\<ff>_le[of j s] by simp
  subgoal for i jout j using shift_safe[of i s t j] by fastforce
  subgoal for i jout j using reuse_matches[of j s t i] \<ff>_le by simp
  subgoal by (auto split: option.splits) (metis sublist_lengths add_less_cancel_right leI le_less_trans)
  done

subsubsection\<open>Storing the @{const \<ff>}-values\<close>
text\<open>We refine the algorithm to compute the @{const \<ff>}-values only once at the start:\<close>
definition compute_\<ff>s_SPEC :: "'a list \<Rightarrow> nat list nres" where
  "compute_\<ff>s_SPEC s \<equiv> SPEC (\<lambda>\<ff>s. length \<ff>s = length s + 1 \<and> (\<forall>j\<le>length s. \<ff>s!j = \<ff> s j))"

definition "kmp1 s t \<equiv> do {
  ASSERT (s \<noteq> []);
  let i=0;
  let j=0;
  let pos=None;
  \<ff>s \<leftarrow> compute_\<ff>s_SPEC (butlast s); \<comment> \<open>At the last char, we abort instead.\<close>
  ASSERT (length \<ff>s = length s);
  (_,_,pos) \<leftarrow> WHILEIT (I_outer s t) (\<lambda>(i,j,pos). i + length s \<le> length t \<and> pos=None) (\<lambda>(i,j,pos). do {
    ASSERT (i + length s \<le> length t);
    (j,pos) \<leftarrow> WHILEIT (I_in_na s t i) (\<lambda>(j,pos). t!(i+j) = s!j \<and> pos=None) (\<lambda>(j,pos). do {
      let j=j+1;
      if j=length s then RETURN (j,Some i) else RETURN (j,None)
    }) (j,pos);
    if pos=None then do {
      ASSERT (j < length \<ff>s \<and> \<ff>s!j \<le> j);
      let i = i + (j - \<ff>s!j + 1);
      let j = max 0 (\<ff>s!j - 1); \<comment> \<open>\<open>max\<close> not necessary\<close>
      RETURN (i,j,None)
    } else RETURN (i,j,Some i)
  }) (i,j,pos);

  RETURN pos
}"

lemma \<ff>_butlast[simp]: "j < length s \<Longrightarrow> \<ff> (butlast s) j = \<ff> s j"
  by (cases j) (simp_all add: take_butlast)

lemma kmp1_refine: "kmp1 s t \<le> kmp s t"
  apply (rule refine_IdD)
  unfolding kmp1_def kmp_def Let_def compute_\<ff>s_SPEC_def nres_monad_laws
  apply (intro ASSERT_refine_right ASSERT_refine_left)
   apply simp
  apply (rule Refine_Basic.intro_spec_refine)
  apply refine_rcg
                apply refine_dref_type
                apply auto
  done

text\<open>Next, an algorithm that satisfies @{const compute_\<ff>s_SPEC}:\<close>
subsection\<open>Computing @{const \<ff>}\<close>
subsubsection\<open>Invariants\<close>

definition "I_out_cb s \<equiv> \<lambda>(\<ff>s,i,j).
  length s + 1 = length \<ff>s \<and>
  (\<forall>jj<j. \<ff>s!jj = \<ff> s jj) \<and>
  \<ff>s!(j-1) = i \<and>
  0 < j"
definition "I_in_cb s j \<equiv> \<lambda>i.
  if j=1 then i=0 \<comment> \<open>first iteration\<close>
  else
    strict_border (take (i-1) s) (take (j-1) s) \<and>
    \<ff> s j \<le> i + 1"

subsubsection\<open>Algorithm\<close>

text\<open>Again, we follow Seidl@{cite GAD}, p.582. Apart from the +1-shift, we make another modification:
Instead of directly setting @{term \<open>\<ff>s!1\<close>}, we let the first loop-iteration (if there is one) do that for us.
This allows us to remove the precondition @{prop \<open>s \<noteq> []\<close>}, as the index bounds are respected even in that corner case.\<close>

definition compute_\<ff>s :: "'a list \<Rightarrow> nat list nres" where
  "compute_\<ff>s s = do {
  let \<ff>s=replicate (length s + 1) 0; \<comment> \<open>only the first 0 is needed\<close>
  let i=0;
  let j=1;
  (\<ff>s,_,_) \<leftarrow> WHILEIT (I_out_cb s) (\<lambda>(\<ff>s,_,j). j < length \<ff>s) (\<lambda>(\<ff>s,i,j). do {
    i \<leftarrow> WHILEIT (I_in_cb s j) (\<lambda>i. i>0 \<and> s!(i-1) \<noteq> s!(j-1)) (\<lambda>i. do {
      ASSERT (i-1 < length \<ff>s);
      let i=\<ff>s!(i-1);
      RETURN i
    }) i;
    ASSERT (i < length \<ff>s);
    let i=i+1;
    ASSERT (j < length \<ff>s);
    let \<ff>s=\<ff>s[j:=i];
    let j=j+1;
    RETURN (\<ff>s,i,j)
  }) (\<ff>s,i,j);

  RETURN \<ff>s
}"

subsubsection\<open>Correctness\<close>
lemma take_length_ib[simp]:
  assumes "0 < j" "j \<le> length s"
    shows "take (length (intrinsic_border (take j s))) s = intrinsic_border (take j s)"
proof -
  from assms have "prefix (intrinsic_border (take j s)) (take j s)"
    by (metis intrinsic_borderI' border_def list.size(3) neq0_conv not_less strict_border_def take_eq_Nil)
  also have "prefix (take j s) s"
    by (simp add: \<open>j \<le> length s\<close> take_is_prefix)
  finally show ?thesis
    by (metis append_eq_conv_conj prefixE)
qed

lemma ib_singleton[simp]: "intrinsic_border [z] = []"
  by (metis intrinsic_border_less length_Cons length_greater_0_conv less_Suc0 list.size(3))

lemma border_butlast: "border xs ys \<Longrightarrow> border (butlast xs) (butlast ys)"
  apply (auto simp: border_def)
   apply (metis butlast_append prefixE prefix_order.eq_refl prefix_prefix prefixeq_butlast)
  apply (metis Sublist.suffix_def append.right_neutral butlast.simps(1) butlast_append)
  done

corollary strict_border_butlast: "xs \<noteq> [] \<Longrightarrow> strict_border xs ys \<Longrightarrow> strict_border (butlast xs) (butlast ys)"
  unfolding strict_border_def by (simp add: border_butlast less_diff_conv)

lemma border_take_lengths: "i \<le> length s \<Longrightarrow> border (take i s) (take j s) \<Longrightarrow> i \<le> j"
  using border_length_le by fastforce

lemma border_step: "border xs ys \<longleftrightarrow> border (xs@[ys!length xs]) (ys@[ys!length xs])"
  apply (auto simp: border_def suffix_def)
  using append_one_prefix prefixE apply fastforce
  using append_prefixD apply blast
  done

corollary strict_border_step: "strict_border xs ys \<longleftrightarrow> strict_border (xs@[ys!length xs]) (ys@[ys!length xs])"
  unfolding strict_border_def using border_step by auto

lemma ib_butlast: "length w \<ge> 2 \<Longrightarrow> length (intrinsic_border w) \<le> length (intrinsic_border (butlast w)) + 1"
proof -
  assume "length w \<ge> 2"
  then have "w \<noteq> []" by auto
  then have "strict_border (intrinsic_border w) w"
    by (fact intrinsic_borderI')
  with \<open>2 \<le> length w\<close> have "strict_border (butlast (intrinsic_border w)) (butlast w)"
    by (metis One_nat_def border_bot.bot.not_eq_extremum butlast.simps(1) len_greater_imp_nonempty length_butlast lessI less_le_trans numerals(2) strict_border_butlast zero_less_diff)
  then have "length (butlast (intrinsic_border w)) \<le> length (intrinsic_border (butlast w))"
    using intrinsic_border_max by blast
  then show ?thesis
    by simp
qed

lemma take_Suc0:
  "l\<noteq>[] \<Longrightarrow> take (Suc 0) l = [l!0]"
  "0 < length l \<Longrightarrow> take (Suc 0) l = [l!0]"
  "Suc n \<le> length l \<Longrightarrow> take (Suc 0) l = [l!0]"
  by (cases l, auto)+

corollary \<ff>_Suc(*rm*): "Suc i \<le> length w \<Longrightarrow> \<ff> w (Suc i) \<le> \<ff> w i + 1"
  apply (cases i)
  apply (simp_all add: take_Suc0)
  by (metis One_nat_def Suc_eq_plus1 Suc_to_right butlast_take diff_is_0_eq ib_butlast length_take min.absorb2 nat.simps(3) not_less_eq_eq numerals(2))

lemma \<ff>_step_bound(*rm*):
  assumes "j \<le> length w"
  shows "\<ff> w j \<le> \<ff> w (j-1) + 1"
  using assms[THEN j_le_\<ff>_le] \<ff>_Suc assms
  by (metis One_nat_def Suc_pred le_SucI not_gr_zero trans_le_add2)

lemma border_take_\<ff>: "border (take (\<ff> s i - 1) s ) (take i s)"
  apply (cases i, simp_all)
  by (metis intrinsic_borderI' border_order.eq_iff border_order.less_imp_le border_positions nat.simps(3) nat_le_linear positions_border take_all take_eq_Nil take_length_ib zero_less_Suc)

corollary \<ff>_strict_borderI: "y = \<ff> s (i-1) \<Longrightarrow> strict_border (take (i-1) s) (take (j-1) s) \<Longrightarrow> strict_border (take (y-1) s) (take (j-1) s)"
  using border_order.less_le_not_le border_order.order.trans border_take_\<ff> by blast

corollary strict_border_take_\<ff>: "0 < i \<Longrightarrow> i \<le> length s \<Longrightarrow> strict_border (take (\<ff> s i - 1) s ) (take i s)"
  by (meson border_order.less_le_not_le border_take_\<ff> border_take_lengths j_le_\<ff>_le' leD)

lemma \<ff>_is_max: "j \<le> length s \<Longrightarrow> strict_border b (take j s) \<Longrightarrow> \<ff> s j \<ge> length b + 1"
  by (metis \<ff>.elims add_le_cancel_right add_less_same_cancel2 border_length_r_less intrinsic_border_max length_take min_absorb2 not_add_less2)

theorem skipping_ok:
  assumes j_bounds[simp]: "1 < j" "j \<le> length s"
    and mismatch: "s!(i-1) \<noteq> s!(j-1)"
    and greater_checked: "\<ff> s j \<le> i + 1"
    and "strict_border (take (i-1) s) (take (j-1) s)"
  shows "\<ff> s j \<le> \<ff> s (i-1) + 1"
proof (rule ccontr)
  assume "\<not>\<ff> s j \<le> \<ff> s (i-1) + 1"
  then have i_bounds: "0 < i" "i \<le> length s"
    using greater_checked assms(5) take_Nil by fastforce+
  then have i_less_j: "i < j"
    using assms(5) border_length_r_less nz_le_conv_less by auto
  from \<open>\<not>\<ff> s j \<le> \<ff> s (i-1) + 1\<close> greater_checked consider
    (tested) "\<ff> s j = i + 1" \<comment> \<open>This contradicts @{thm mismatch}\<close> |
    (skipped) "\<ff> s (i-1) + 1 < \<ff> s j" "\<ff> s j \<le> i"
      \<comment> \<open>This contradicts @{thm \<ff>_is_max[of "i-1" s]}\<close>
    by linarith
  then show False
  proof cases
    case tested
    then have "\<ff> s j - 1 = i" by simp
    moreover note border_positions[OF border_take_\<ff>[of s j, unfolded this]]
    ultimately have "take j s ! (i-1) = s!(j-1)" using i_bounds i_less_j by simp
    with \<open>i < j\<close> have "s!(i-1) = s!(j-1)"
      by (simp add: less_imp_diff_less)
    with mismatch show False..
  next
    case skipped
    let ?border = "take (i-1) s"
      \<comment> \<open>This border of @{term \<open>take (j-1) s\<close>} could not be extended to a border of @{term \<open>take j s\<close>} due to the mismatch.\<close>
    let ?impossible = "take (\<ff> s j - 2) s"
      \<comment> \<open>A strict border longer than @{term \<open>intrinsic_border ?border\<close>}, a contradiction.\<close>
    have "length (take j s) = j"
      by simp
    have "\<ff> s j - 2 < i - 1"
      using skipped by linarith
    then have less_s: "\<ff> s j - 2 < length s" "i - 1 < length s"
      using \<open>i < j\<close> j_bounds(2) by linarith+
    then have strict: "length ?impossible < length ?border"
      using \<open>\<ff> s j - 2 < i - 1\<close> by auto
    moreover {
      have "prefix ?impossible (take j s)"
        using prefix_length_prefix take_is_prefix
        by (metis (no_types, lifting) \<open>length (take j s) = j\<close> j_bounds(2) diff_le_self j_le_\<ff>_le length_take less_s(1) min_simps(2) order_trans)
      moreover have "prefix ?border (take j s)"
        by (metis (no_types, lifting) \<open>length (take j s) = j\<close> diff_le_self i_less_j le_trans length_take less_or_eq_imp_le less_s(2) min_simps(2) prefix_length_prefix take_is_prefix)
      ultimately have "prefix ?impossible ?border"
        using strict less_imp_le_nat prefix_length_prefix by blast
    } moreover {
      have "suffix (take (\<ff> s j - 1) s) (take j s)" using border_take_\<ff>
        by (auto simp: border_def)
      note suffix_butlast[OF this]
      then have "suffix ?impossible (take (j-1) s)"
        by (metis One_nat_def j_bounds(2) butlast_take diff_diff_left \<ff>_le len_greater_imp_nonempty less_or_eq_imp_le less_s(2) one_add_one)
      then have "suffix ?impossible (take (j-1) s)" "suffix ?border (take (j-1) s)"
        using assms(5) by auto
      from suffix_length_suffix[OF this strict[THEN less_imp_le]]
        have "suffix ?impossible ?border".
    }
    ultimately have "strict_border ?impossible ?border"
      unfolding strict_border_def[unfolded border_def] by blast
    note \<ff>_is_max[of "i-1" s, OF _ this]
    then have "length (take (\<ff> s j - 2) s) + 1 \<le> \<ff> s (i-1)"
      using less_imp_le_nat less_s(2) by blast
    then have "\<ff> s j - 1 \<le> \<ff> s (i-1)"
      by (simp add: less_s(1))
    then have "\<ff> s j \<le> \<ff> s (i-1) + 1"
      using le_diff_conv by blast
    with skipped(1) show False
      by linarith
  qed
qed

lemma extend_border:
  assumes "j \<le> length s"
  assumes "s!(i-1) = s!(j-1)"
  assumes "strict_border (take (i-1) s) (take (j-1) s)"
  assumes "\<ff> s j \<le> i + 1"
  shows "\<ff> s j = i + 1"
proof -
  from assms(3) have pos_in_range: "i - 1 < length s " "length (take (i-1) s) = i - 1"
    using border_length_r_less min_less_iff_conj by auto
  with strict_border_step[THEN iffD1, OF assms(3)] have "strict_border (take (i-1) s @ [s!(i-1)]) (take (j-1) s @ [s!(i-1)])"
    by (metis assms(3) border_length_r_less length_take min_less_iff_conj nth_take)
  with pos_in_range have "strict_border (take i s) (take (j-1) s @ [s!(i-1)])"
    by (metis Suc_eq_plus1 Suc_pred add.left_neutral border_bot.bot.not_eq_extremum border_order.less_asym neq0_conv take_0 take_Suc_conv_app_nth)
  then have "strict_border (take i s) (take (j-1) s @ [s!(j-1)])"
    by (simp only: \<open>s!(i-1) = s!(j-1)\<close>)
  then have "strict_border (take i s) (take j s)"
    by (metis One_nat_def Suc_pred assms(1,3) diff_le_self less_le_trans neq0_conv nz_le_conv_less strict_border_imp_nonempty take_Suc_conv_app_nth take_eq_Nil)
  with \<ff>_is_max[OF assms(1) this] have "\<ff> s j \<ge> i + 1"
    using Suc_leI by fastforce
  with \<open>\<ff> s j \<le> i + 1\<close> show ?thesis
    using le_antisym by presburger
qed

lemma compute_\<ff>s_correct: "compute_\<ff>s s \<le> compute_\<ff>s_SPEC s"
  unfolding compute_\<ff>s_SPEC_def compute_\<ff>s_def I_out_cb_def I_in_cb_def
  apply (simp, refine_vcg
    WHILEIT_rule[where R="measure (\<lambda>(\<ff>s,i,j). length s + 1 - j)"]
    WHILEIT_rule[where R="measure id"] \<comment> \<open>@{term \<open>i::nat\<close>} decreases with every iteration.\<close>
    )
  apply (clarsimp_all, fold One_nat_def)
  subgoal for b j by (rule strict_border_take_\<ff>, auto)
  subgoal by (metis Suc_eq_plus1 \<ff>_step_bound less_Suc_eq_le)
  subgoal by fastforce
  subgoal
    by (metis (no_types, lifting) One_nat_def Suc_lessD Suc_pred border_length_r_less \<ff>_strict_borderI length_take less_Suc_eq less_Suc_eq_le min.absorb2)
  subgoal for b j i
    by (metis (no_types, lifting) One_nat_def Suc_diff_1 Suc_eq_plus1 Suc_leI border_take_lengths less_Suc_eq_le less_antisym skipping_ok strict_border_def)
  subgoal by (metis Suc_diff_1 border_take_lengths j_le_\<ff>_le less_Suc_eq_le strict_border_def)
  subgoal by (metis Suc_eq_plus1 \<ff>_le border_order.less_irrefl diff_Suc_1 extend_border less_SucI less_Suc_eq_le take_Nil zero_less_Suc)
  subgoal for b j i jj
    by (metis Suc_eq_plus1 Suc_eq_plus1_left add.right_neutral extend_border \<ff>_eq_0_iff_j_eq_0 j_le_\<ff>_le le_zero_eq less_Suc_eq less_Suc_eq_le nth_list_update_eq nth_list_update_neq)
  subgoal by linarith
  done

subsubsection\<open>Index shift\<close>
text\<open>To avoid inefficiencies, we refine @{const compute_\<ff>s} to take @{term s}
instead of @{term \<open>butlast s\<close>} (it still only uses @{term \<open>butlast s\<close>}).\<close>
definition compute_butlast_\<ff>s :: "'a list \<Rightarrow> nat list nres" where
  "compute_butlast_\<ff>s s = do {
  let \<ff>s=replicate (length s) 0;
  let i=0;
  let j=1;
  (\<ff>s,_,_) \<leftarrow> WHILEIT (I_out_cb (butlast s)) (\<lambda>(b,i,j). j < length b) (\<lambda>(\<ff>s,i,j). do {
    ASSERT (1\<le>j \<and> j < length \<ff>s);
    i \<leftarrow> WHILEIT (I_in_cb (butlast s) j) (\<lambda>i. i>0 \<and> s!(i-1) \<noteq> s!(j-1)) (\<lambda>i. do {
      ASSERT (1\<le>i \<and> i-1 < length \<ff>s);
      let i=\<ff>s!(i-1);
      RETURN i
    }) i;
    ASSERT (length \<ff>s = length s);
    ASSERT (i < length \<ff>s);
    let i=i+1;
    ASSERT (j < length \<ff>s);
    let \<ff>s=\<ff>s[j:=i];
    let j=j+1;
    RETURN (\<ff>s,i,j)
  }) (\<ff>s,i,j);

  RETURN \<ff>s
}"

lemma compute_\<ff>s_inner_bounds:
  assumes "I_out_cb s (\<ff>s,ix,j)"
  assumes "j < length \<ff>s"
  assumes "I_in_cb s j i"
  shows "1\<le>j" "i-1 < length s" "j-1 < length s"
  using assms by (auto simp: I_out_cb_def I_in_cb_def split: if_splits)

lemma compute_butlast_\<ff>s_refine[refine]:
  assumes "(s,s') \<in> br butlast ((\<noteq>) [])"
  shows "compute_butlast_\<ff>s s \<le> \<Down> Id (compute_\<ff>s_SPEC s')"
proof -
  have "compute_butlast_\<ff>s s \<le> \<Down> Id (compute_\<ff>s s')"
    unfolding compute_butlast_\<ff>s_def compute_\<ff>s_def
    apply (refine_rcg)
              apply (refine_dref_type)
    using assms apply (clarsimp_all simp: in_br_conv)
     apply (metis Suc_pred length_greater_0_conv replicate_Suc)
     apply (simp add: I_out_cb_def)
     apply (metis One_nat_def compute_\<ff>s_inner_bounds(2-) nth_butlast)
     apply (simp add: I_out_cb_def)
     done

  also note compute_\<ff>s_correct
  finally show ?thesis by simp
qed

subsection\<open>Conflation\<close>
text\<open>We replace @{const compute_\<ff>s_SPEC} with @{const compute_butlast_\<ff>s}\<close>
definition "kmp2 s t \<equiv> do {
  ASSERT (s \<noteq> []);
  let i=0;
  let j=0;
  let pos=None;
  \<ff>s \<leftarrow> compute_butlast_\<ff>s s;
  ASSERT (length \<ff>s = length s);
  (_,_,pos) \<leftarrow> monadic_WHILEIT (I_outer s t)
    (\<lambda>(i,j,pos). do { ASSERT(i\<le>length t); RETURN (i + length s \<le> length t \<and> pos=None)} )
    (\<lambda>(i,j,pos). do {
      ASSERT (i + length s \<le> length t \<and> pos=None);
      (j,pos) \<leftarrow> monadic_WHILEIT (I_in_na s t i)
        (\<lambda>(j,pos). do { ASSERT(pos=None \<longrightarrow> i+j<length t \<and> j<length s); RETURN (pos=None \<and> t!(i+j) = s!j) })
        (\<lambda>(j,pos). do {
          ASSERT (j<length s);
          let j=j+1;
          if j=length s then RETURN (j,Some i) else RETURN (j,None)
        }) (j,pos);
      if pos=None then do {
        ASSERT (j < length \<ff>s \<and> \<ff>s!j \<le> j);
        let i = i + (j - \<ff>s!j + 1);
        let j = op_nat_sub_ovf (\<ff>s!j) 1; \<comment> \<open>Explicitly select 0-saturating subtraction\<close>
        RETURN (i,j,None)
      } else RETURN (i,j,Some i)
    }) (i,j,pos);

  RETURN pos
}"

text\<open>Using @{thm [source] compute_butlast_\<ff>s_refine} (it has attribute @{attribute refine}), the proof is trivial:\<close>
lemma kmp2_refine: "kmp2 s t \<le> kmp1 s t"
  apply (rule refine_IdD)
  unfolding kmp2_def kmp1_def
  apply refine_rcg
                  apply refine_dref_type
                  apply (auto simp: in_br_conv I_outer_def I_in_na_def split: option.splits)
  done

lemma kmp2_correct: "s \<noteq> []
  \<Longrightarrow> kmp2 s t \<le> kmp_SPEC s t"
proof -
  assume "s \<noteq> []"
  have "kmp2 s t \<le> kmp1 s t" by (fact kmp2_refine)
  also have "... \<le> kmp s t" by (fact kmp1_refine)
  also have "... \<le> kmp_SPEC s t" by (fact kmp_correct[OF \<open>s \<noteq> []\<close>])
  finally show ?thesis.
qed

text\<open>For convenience, we also remove the precondition:\<close>
definition "kmp3 s t \<equiv> do {
  if s=[] then RETURN (Some 0) else kmp2 s t
}"

lemma kmp3_correct: "kmp3 s t \<le> kmp_SPEC s t"
  unfolding kmp3_def by (simp add: kmp2_correct) (simp add: kmp_SPEC_def)

section \<open>Refinement to Imperative/HOL\<close>

(* TODO: Use monadic_WHILEIT also in compute_\<ff>s *)
lemmas in_bounds_aux = compute_\<ff>s_inner_bounds[of "butlast s" for s, simplified]

subsection \<open>Setup\<close>
text \<open>We fix a 64 bit type for string positions,
  and an 8 bit type for string content (characters)
\<close>

type_synonym size_t = 64
abbreviation "size_t_assn \<equiv> snat_assn' TYPE(size_t)"

abbreviation "char_assn \<equiv> word_assn' TYPE(8)"

text \<open>A string is represented as array with length value\<close>
abbreviation "string_assn \<equiv> larray_assn' TYPE(size_t) char_assn"

text \<open>Also the lookup table is represented as array with length value.\<close>
(* TODO: Do we ever need length of lookup table?
  We do, but could easily change algorithm such that it does not lookup this length!
*)
abbreviation "tab_assn \<equiv> larray_assn' TYPE(size_t) size_t_assn"
(*abbreviation "tab_assn \<equiv> array_assn size_t_assn" *)

subsection \<open>Refinement of Lookup Table Computation\<close>
sepref_def compute_butlast_\<ff>s_impl is compute_butlast_\<ff>s
  :: "[\<lambda>s. length s < max_snat LENGTH(size_t)]\<^sub>a (string_assn)\<^sup>k \<rightarrow> tab_assn"
  unfolding compute_butlast_\<ff>s_def
  apply (rewrite in "WHILEIT _ \<hole>" short_circuit_conv)+
  supply [[goals_limit = 1]]
  apply (annot_snat_const "TYPE(size_t)")
  apply (rewrite larray.fold_replicate_init)
  supply in_bounds_aux[dest]
  apply sepref
  done

(*prepare_code_thms (LLVM) [llvm_code] compute_butlast_\<ff>s_impl_def*)
(*declare compute_butlast_\<ff>s_impl_def[llvm_code]*)

llvm_deps compute_butlast_\<ff>s_impl
export_llvm compute_butlast_\<ff>s_impl

(*declare compute_butlast_\<ff>s_impl.refine[sepref_fr_rules]*)

sepref_register compute_\<ff>s

subsection \<open>Refinement of Main Algorithm\<close>

abbreviation "result_assn \<equiv> snat_option_assn' TYPE(size_t)"

sepref_def kmp_impl is "uncurry kmp3"
  :: "[\<lambda>(s,t). length s + length t < max_snat LENGTH(size_t) ]\<^sub>a
      (string_assn)\<^sup>k *\<^sub>a (string_assn)\<^sup>k \<rightarrow> result_assn"
  unfolding kmp3_def kmp2_def
  apply (rewrite in "RETURN \<hole>" in "monadic_WHILEIT (I_in_na _ _ _) \<hole>" short_circuit_conv)
  supply [[goals_limit = 3]]
  apply (annot_snat_const "TYPE(size_t)")

  apply sepref_dbg_keep
  done

definition [llvm_code,llvm_inline]: "kmp_impl' ap bp \<equiv> doM {
  a \<leftarrow> ll_load ap;
  b \<leftarrow> ll_load bp;
  kmp_impl a b
}"

export_llvm
  compute_butlast_\<ff>s_impl
  kmp_impl' is "_ kmp(string*,string*)"
  defines \<open>
    typedef struct {int64_t len; char *str;} string;
  \<close>
  file "code/kmp.ll"

export_llvm
  kmp_impl' is "_ kmp(string*,string*)"
  defines \<open>
    typedef struct {int64_t len; char *str;} string;
  \<close>
  file "../../regression/gencode/kmp.ll"

section \<open>Overall Correctness Theorem\<close>

lemmas kmp_impl_correct' = kmp_impl.refine[FCOMP kmp3_correct']

text \<open>The following theorem relates the final Imperative HOL algorithm to its specification,
  using, beyond basic HOL concepts
    \<^item> Hoare triples for LLVM;
    \<^item> The assertion @{const larray_assn} to specify array-lists, which we use to represent the input strings of the algorithm;
    \<^item> The @{const sublist_at} function that we defined in section \ref{sec:spec}.
  \<close>

theorem kmp_impl_correct:
  "llvm_htriple
    (larray_assn id_assn s si ** larray_assn id_assn t ti ** \<up>(length s + length t < max_snat 64))
    (kmp_impl si ti)
    (\<lambda>i. larray_assn id_assn s si ** larray_assn id_assn t ti
      ** \<up>(if i=-1 then \<nexists>i. sublist_at s t i
          else i\<ge>0 \<and> sublist_at s t (unat i) \<and> (\<forall>ii<unat i. \<not> sublist_at s t ii)))
    "
proof -
  have 1: "snat_option_assn' TYPE(size_t) a c = \<up>(if c=-1 then a = None else a = Some (unat c) \<and> snat_invar c)" for a c
    unfolding snat.option_assn_def
    unfolding snat_rel_def pure_def snat.rel_def in_br_conv
    by (auto simp: pred_lift_extract_simps snat_eq_unat)

  note R = kmp_impl_correct'[THEN hfrefD, THEN hn_refineD, of "(s,t)" "(si,ti)", simplified]
  note R = R[unfolded kmp_SPEC_def 1, simplified]
  note [vcg_rules] = R

  show ?thesis
   apply vcg'
   done

qed

theorem kmp_impl'_correct:
  "llvm_htriple
    (\<upharpoonleft>ll_pto si sip ** \<upharpoonleft>ll_pto ti tip ** larray_assn id_assn s si ** larray_assn id_assn t ti ** \<up>(length s + length t < max_snat 64))
    (kmp_impl' sip tip)
    (\<lambda>i. \<upharpoonleft>ll_pto si sip ** \<upharpoonleft>ll_pto ti tip ** larray_assn id_assn s si ** larray_assn id_assn t ti
      ** \<up>(if i=-1 then \<nexists>i. sublist_at s t i
          else i\<ge>0 \<and> sublist_at s t (unat i) \<and> (\<forall>ii<unat i. \<not> sublist_at s t ii)))
    "
proof -
  interpret llvm_prim_setup .

  show ?thesis
    unfolding kmp_impl'_def
    supply [vcg_rules] = kmp_impl_correct
    by (vcg )
qed

thm hnr_bind[of \<Gamma> m\<^sub>i \<Gamma>\<^sub>1 R\<^sub>1 m f\<^sub>i \<Gamma>\<^sub>2 R\<^sub>2 f R\<^sub>x \<Gamma>' free]

thm kmp_impl_def

term \<open>foo bar \<^cancel>\<open>  @{d} } \<close>\<close>

end


(* Author: Lei Yu, University of Cambridge
   Author: Fabian Hellauer
           Fabian Immler
*)

section \<open>Proofs of Properties about Floating Point Arithmetic\<close>

theory IEEE_Properties
imports IEEE
begin

subsection \<open>Theorems derived from definitions\<close>

lemma valof_eq:
  "valof x =
    (if exponent x = 0
       then (- 1) ^ sign x * (2 / 2 ^ bias TYPE(('a, 'b) float)) *
            (real (fraction x) / 2 ^ LENGTH('b))
       else (- 1) ^ sign x * (2 ^ exponent x / 2 ^ bias TYPE(('a, 'b) float)) *
            (1 + real (fraction x) / 2 ^ LENGTH('b)))"
  for x::"('a, 'b) float"
  unfolding Let_def
  by transfer (auto simp: bias_def divide_simps unat_eq_0)

lemma exponent_le[simp]:
  "exponent a \<le> unat (-1::'a word)" for a::"('a, _)float"
  by transfer (auto intro!: unat_mono simp: word_le_nat_alt[symmetric])

lemma
  max_word_le_exponent_iff[simp]:
  "unat (- 1::'a word) \<le> exponent a \<longleftrightarrow> unat (- 1::'a word) = exponent a"
  for a::"('a, _)float"
  using le_antisym by fastforce

lemma infinity_simps:
  "sign (plus_infinity::('e, 'f)float) = 0"
  "sign (minus_infinity::('e, 'f)float) = 1"
  "exponent (plus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)"
  "exponent (minus_infinity::('e, 'f)float) = emax TYPE(('e, 'f)float)"
  "fraction (plus_infinity::('e, 'f)float) = 0"
  "fraction (minus_infinity::('e, 'f)float) = 0"
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer (auto simp: emax_def)
  subgoal by transfer (auto simp: emax_def)
  subgoal by transfer auto
  subgoal by transfer auto
  done

lemma zero_simps:
  "sign (0::('e, 'f)float) = 0"
  "sign (- 0::('e, 'f)float) = 1"
  "exponent (0::('e, 'f)float) = 0"
  "exponent (- 0::('e, 'f)float) = 0"
  "fraction (0::('e, 'f)float) = 0"
  "fraction (- 0::('e, 'f)float) = 0"
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  subgoal by transfer auto
  done

lemma emax_eq: "emax x = 2^LENGTH('e) - 1"
  for x::"('e, 'f)float itself"
  by (simp add: emax_def unat_minus_one_word)

lemma topfloat_simps:
  "sign (topfloat::('e, 'f)float) = 0"
  "exponent (topfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1"
  "fraction (topfloat::('e, 'f)float) = 2^fracwidth TYPE(('e, 'f)float) - 1"
  and bottomfloat_simps:
  "sign (bottomfloat::('e, 'f)float) = 1"
  "exponent (bottomfloat::('e, 'f)float) = emax TYPE(('e, 'f)float) - 1"
  "fraction (bottomfloat::('e, 'f)float) = 2^fracwidth TYPE(('e, 'f)float) - 1"
  subgoal by transfer simp
  subgoal by transfer (simp add: emax_eq take_bit_minus_small_eq
    nat_diff_distrib nat_power_eq)
  subgoal by transfer (simp add: unat_minus_one_word)
  subgoal by transfer simp
  subgoal by transfer (simp add: emax_eq take_bit_minus_small_eq
    unat_minus_one_word nat_diff_distrib nat_power_eq)
  subgoal by transfer (simp add: unat_minus_one_word)
  done

lemmas float_defs =
  is_finite_def is_infinity_def is_zero_def is_nan_def
  is_normal_def is_denormal_def valof_eq
  less_eq_float_def less_float_def
  flt_def fgt_def fle_def fge_def feq_def
  fcompare_def
  infinity_simps
  zero_simps
  topfloat_simps
  bottomfloat_simps
  float_eq_def

lemma float_cases: "is_nan a \<or> is_infinity a \<or> is_normal a \<or> is_denormal a \<or> is_zero a"
  by (auto simp: emax_def float_defs not_less)

lemma float_cases_finite: "is_nan a \<or> is_infinity a \<or> is_finite a"
  by (simp add: float_cases is_finite_def)

lemma float_zero1[simp]: "is_zero 0"
  unfolding float_defs
  by transfer auto

lemma float_zero2[simp]: "is_zero (- x) \<longleftrightarrow> is_zero x"
  unfolding float_defs
  by transfer auto

lemma emax_pos[simp]: "0 < emax x" "emax x \<noteq> 0"
  by (auto simp: emax_def)

text \<open>The types of floating-point numbers are mutually distinct.\<close>
lemma float_distinct:
  "\<not> (is_nan a \<and> is_infinity a)"
  "\<not> (is_nan a \<and> is_normal a)"
  "\<not> (is_nan a \<and> is_denormal a)"
  "\<not> (is_nan a \<and> is_zero a)"
  "\<not> (is_infinity a \<and> is_normal a)"
  "\<not> (is_infinity a \<and> is_denormal a)"
  "\<not> (is_infinity a \<and> is_zero a)"
  "\<not> (is_normal a \<and> is_denormal a)"
  "\<not> (is_denormal a \<and> is_zero a)"
  by (auto simp: float_defs)

lemma denormal_imp_not_zero: "is_denormal f \<Longrightarrow> \<not>is_zero f"
  by (simp add: is_denormal_def is_zero_def)

lemma normal_imp_not_zero: "is_normal f \<Longrightarrow> \<not>is_zero f"
  by (simp add: is_normal_def is_zero_def)

lemma normal_imp_not_denormal: "is_normal f \<Longrightarrow> \<not>is_denormal f"
  by (simp add: is_normal_def is_denormal_def)

lemma denormal_zero[simp]: "\<not>is_denormal 0" "\<not>is_denormal minus_zero"
  using denormal_imp_not_zero float_zero1 float_zero2 by blast+

lemma normal_zero[simp]: "\<not>is_normal 0" "\<not>is_normal minus_zero"
  using normal_imp_not_zero float_zero1 float_zero2 by blast+

lemma float_distinct_finite: "\<not> (is_nan a \<and> is_finite a)" "\<not>(is_infinity a \<and> is_finite a)"
  by (auto simp: float_defs)

lemma finite_infinity: "is_finite a \<Longrightarrow> \<not> is_infinity a"
  by (auto simp: float_defs)

text \<open>For every real number, the floating-point numbers closest to it always exist.\<close>
lemma is_closest_exists:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
    and s :: "('e, 'f)float set"
  assumes finite: "finite s"
    and non_empty: "s \<noteq> {}"
  shows "\<exists>a. is_closest v s x a"
  using finite non_empty
proof (induct s rule: finite_induct)
  case empty
  then show ?case by simp
next
  case (insert z s)
  show ?case
  proof (cases "s = {}")
    case True
    then have "is_closest v (insert z s) x z"
      by (auto simp: is_closest_def)
    then show ?thesis by metis
  next
    case False
    then obtain a where a: "is_closest v s x a"
      using insert by metis
    then show ?thesis
    proof (cases "\<bar>v a - x\<bar>" "\<bar>v z - x\<bar>" rule: le_cases)
      case le
      then show ?thesis
        by (metis insert_iff a is_closest_def)
    next
      case ge
      have "\<forall>b. b \<in> s \<longrightarrow> \<bar>v a - x\<bar> \<le> \<bar>v b - x\<bar>"
        by (metis a is_closest_def)
      then have "\<forall>b. b \<in> insert z s \<longrightarrow> \<bar>v z - x\<bar> \<le> \<bar>v b - x\<bar>"
        by (metis eq_iff ge insert_iff order.trans)
      then show ?thesis using is_closest_def a
        by (metis insertI1)
    qed
  qed
qed

lemma closest_is_everything:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
    and s :: "('e, 'f)float set"
  assumes finite: "finite s"
    and non_empty: "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x) \<and>
    ((\<exists>b. is_closest v s x b \<and> p b) \<longrightarrow> p (closest v p s x))"
  unfolding closest_def
  by (rule someI_ex) (metis assms is_closest_exists [of s v x])

lemma closest_in_set:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
  assumes "finite s" and "s \<noteq> {}"
  shows "closest v p s x \<in> s"
  by (metis assms closest_is_everything is_closest_def)

lemma closest_is_closest_finite:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
  assumes "finite s" and "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x)"
  by (metis closest_is_everything assms)

instance float::(len, len) finite proof qed (transfer, simp)

lemma closest_is_closest:
  fixes v :: "('e, 'f)float \<Rightarrow> real"
  assumes "s \<noteq> {}"
  shows "is_closest v s x (closest v p s x)"
  by (rule closest_is_closest_finite) (auto simp: assms)

subsection \<open>Properties about ordering and bounding\<close>

text \<open>Lifting of non-exceptional comparisons.\<close>
lemma float_lt [simp]:
  assumes "is_finite a" "is_finite b"
  shows "a < b \<longleftrightarrow> valof a < valof b"
proof
  assume "valof a < valof b"
  moreover have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  ultimately have "fcompare a b = Lt"
    by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def)
  then show "a < b" by (auto simp: float_defs)
next
  assume "a < b"
  then have lt: "fcompare a b = Lt"
    by (simp add: float_defs)
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  then show "valof a < valof b"
    using lt assms
    by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm)
qed

lemma float_eq [simp]:
  assumes "is_finite a" "is_finite b"
  shows "a \<doteq> b \<longleftrightarrow> valof a = valof b"
proof
  assume *: "valof a = valof b"
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  with * have "fcompare a b = Eq"
    by (auto simp add: is_infinity_def is_nan_def valof_def fcompare_def)
  then show "a \<doteq> b" by (auto simp: float_defs)
next
  assume "a \<doteq> b"
  then have eq: "fcompare a b = Eq"
    by (simp add: float_defs)
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  then show "valof a = valof b"
    using eq assms
    by (simp add: fcompare_def is_nan_def is_infinity_def valof_def split: if_split_asm)
qed

lemma float_le [simp]:
  assumes "is_finite a" "is_finite b"
  shows "a \<le> b \<longleftrightarrow> valof a \<le> valof b"
proof -
  have "a \<le> b \<longleftrightarrow>  a < b \<or> a \<doteq> b"
    by (auto simp add: float_defs)
  then show ?thesis
    by (auto simp add: assms)
qed

text \<open>Reflexivity of equality for non-NaNs.\<close>
lemma float_eq_refl [simp]: "a \<doteq> a \<longleftrightarrow> \<not> is_nan a"
  by (auto simp: float_defs)

text \<open>Properties about Ordering.\<close>
lemma float_lt_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a < b \<Longrightarrow> b < c \<Longrightarrow> a < c"
  by (auto simp: le_trans)

lemma float_le_less_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a \<le> b \<Longrightarrow> b < c \<Longrightarrow> a < c"
  by (auto simp: le_trans)

lemma float_le_trans: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite c \<Longrightarrow> a \<le> b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
  by (auto simp: le_trans)

lemma float_le_neg: "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> \<not> a < b \<longleftrightarrow> b \<le> a"
  by auto

text \<open>Properties about bounding.\<close>

lemma float_le_infinity [simp]: "\<not> is_nan a \<Longrightarrow> a \<le> plus_infinity"
  unfolding float_defs
  by auto

lemma zero_le_topfloat[simp]: "0 \<le> topfloat" "- 0 \<le> topfloat"
  by (auto simp: float_defs field_simps power_gt1_lemma of_nat_diff)

lemma LENGTH_contr:
  "Suc 0 < LENGTH('e) \<Longrightarrow> 2 ^ LENGTH('e::len) \<le> Suc (Suc 0) \<Longrightarrow> False"
  by (metis le_antisym len_gt_0 n_less_equal_power_2 not_less_eq numeral_2_eq_2 one_le_numeral
      self_le_power)

lemma valof_topfloat: "valof (topfloat::('e, 'f)float) = largest TYPE(('e, 'f)float)"
  if "LENGTH('e) > 1"
  using that LENGTH_contr
  by (auto simp add: emax_eq largest_def divide_simps float_defs of_nat_diff)

lemma float_frac_le: "fraction a \<le> 2^LENGTH('f) - 1"
  for a::"('e, 'f)float"
  unfolding float_defs
  using less_Suc_eq_le
  by transfer fastforce

lemma float_exp_le: "is_finite a \<Longrightarrow> exponent a \<le> emax TYPE(('e, 'f)float) - 1"
  for a::"('e, 'f)float"
  unfolding float_defs
  by auto

lemma float_sign_le: "(-1::real)^(sign a) = 1 \<or> (-1::real)^(sign a) = -1"
  by (metis neg_one_even_power neg_one_odd_power)

lemma exp_less: "a \<le> b \<Longrightarrow> (2::real)^a \<le> 2^b" for a b :: nat
  by auto

lemma div_less: "a \<le> b \<and> c > 0 \<Longrightarrow> a/c \<le> b/c" for a b c :: "'a::linordered_field"
  by (metis divide_le_cancel less_asym)

lemma finite_topfloat: "is_finite topfloat"
  unfolding float_defs
  by auto

lemmas float_leI = float_le[THEN iffD2]

lemma factor_minus: "x * a - x = x * (a - 1)"
  for x a::"'a::comm_semiring_1_cancel"
  by (simp add: algebra_simps)

lemma real_le_power_numeral_diff: "real a \<le> numeral b ^ n - 1 \<longleftrightarrow> a \<le> numeral b ^ n - 1"
  by (metis (mono_tags, lifting) of_nat_1 of_nat_diff of_nat_le_iff of_nat_numeral
      one_le_numeral one_le_power semiring_1_class.of_nat_power)

definition denormal_exponent::"('e, 'f)float itself \<Rightarrow> int" where
  "denormal_exponent x = 1 - (int (LENGTH('f)) + int (bias TYPE(('e, 'f)float)))"

definition normal_exponent::"('e, 'f)float \<Rightarrow> int" where
  "normal_exponent x = int (exponent x) - int (bias TYPE(('e, 'f)float)) - int (LENGTH('f))"

definition denormal_mantissa::"('e, 'f)float \<Rightarrow> int" where
  "denormal_mantissa x = (-1::int)^sign x * int (fraction x)"

definition normal_mantissa::"('e, 'f)float \<Rightarrow> int" where
  "normal_mantissa x = (-1::int)^sign x * (2^LENGTH('f) + int (fraction x))"

lemma unat_one_word_le: "unat a \<le> Suc 0" for a::"1 word"
  using unat_lt2p[of a]
  by auto

lemma one_word_le: "a \<le> 1" for a::"1 word"
  by (auto simp: word_le_nat_alt unat_one_word_le)

lemma sign_cases[case_names pos neg]:
  obtains "sign x = 0" | "sign x = 1"
proof cases
  assume "sign x = 0"
  then show ?thesis ..
next
  assume "sign x \<noteq> 0"
  have "sign x \<le> 1"
    by transfer (auto simp: unat_one_word_le)
  then have "sign x = 1" using \<open>sign x \<noteq> 0\<close>
    by auto
  then show ?thesis ..
qed

lemma is_infinity_cases:
  assumes "is_infinity x"
  obtains "x = plus_infinity" | "x = minus_infinity"
proof (cases rule: sign_cases[of x])
  assume "sign x = 0"
  then have "x = plus_infinity" using assms
    unfolding float_defs
    by transfer (auto simp: emax_def unat_eq_0 simp flip: word_eq_iff_unsigned)
  then show ?thesis ..
next
  assume "sign x = 1"
  then have "x = minus_infinity" using assms
    unfolding float_defs
    by transfer (auto simp: emax_def unat_eq_of_nat)
  then show ?thesis ..
qed

lemma is_zero_cases:
  assumes "is_zero x"
  obtains "x = 0" | "x = - 0"
proof (cases rule: sign_cases[of x])
  assume "sign x = 0"
  then have "x = 0" using assms
    unfolding float_defs
    by transfer (auto simp: emax_def unat_eq_0)
  then show ?thesis ..
next
  assume "sign x = 1"
  then have "x = minus_zero" using assms
    unfolding float_defs
    by transfer (auto simp: emax_def unat_eq_of_nat)
  then show ?thesis ..
qed

lemma minus_minus_float[simp]: "- (-f) = f" for f::"('e, 'f)float"
  by transfer auto

lemma sign_minus_float: "sign (-f) = (1 - sign f)" for f::"('e, 'f)float"
  by transfer (auto simp: unat_eq_1 one_word_le unat_sub)

lemma exponent_uminus[simp]: "exponent (- f) = exponent f" by transfer auto
lemma fraction_uminus[simp]: "fraction (- f) = fraction f" by transfer auto

lemma is_normal_minus_float[simp]: "is_normal (-f) = is_normal f" for f::"('e, 'f)float"
  by (auto simp: is_normal_def)

lemma is_denormal_minus_float[simp]: "is_denormal (-f) = is_denormal f" for f::"('e, 'f)float"
  by (auto simp: is_denormal_def)

lemma bitlen_normal_mantissa:
  "bitlen (abs (normal_mantissa x)) = Suc LENGTH('f)" for x::"('e, 'f)float"
proof -
  have "fraction x < 2 ^ LENGTH('f)"
    using float_frac_le[of x]
    by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power)
  moreover have "- int (fraction x) \<le> 2 ^ LENGTH('f)"
    using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast
  ultimately show ?thesis
    by (cases x rule: sign_cases)
      (auto simp: bitlen_le_iff_power bitlen_ge_iff_power nat_add_distrib
        normal_mantissa_def intro!: antisym)
qed

lemma less_int_natI: "x < y" if "0 \<le> x" "nat x < nat y"
  using that by arith

lemma normal_exponent_bounds_int:
  "2 - 2 ^ (LENGTH('e) - 1) - int LENGTH('f) \<le> normal_exponent x"
  "normal_exponent x \<le> 2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1"
  if "is_normal x"
  for x::"('e, 'f)float"
  using that
  unfolding normal_exponent_def is_normal_def emax_eq bias_def
  by (auto simp del: zless_nat_conj intro!: less_int_natI
      simp: of_nat_diff nat_add_distrib nat_mult_distrib nat_power_eq
      power_Suc[symmetric])

lemmas of_int_leI = of_int_le_iff[THEN iffD2]

lemma normal_exponent_bounds_real:
  "2 - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) \<le> normal_exponent x"
  "normal_exponent x \<le> 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1"
  if "is_normal x"
  for x::"('e, 'f)float"
  subgoal by (rule order_trans[OF _ of_int_leI[OF normal_exponent_bounds_int(1)[OF that]]]) auto
  subgoal by (rule order_trans[OF of_int_leI[OF normal_exponent_bounds_int(2)[OF that]]]) auto
  done

lemma float_eqI:
  "x = y" if "sign x = sign y" "fraction x = fraction y" "exponent x = exponent y"
  using that by transfer (auto simp add: word_unat_eq_iff)

lemma float_induct[induct type:float, case_names normal denormal neg zero infinity nan]:
  fixes a::"('e, 'f)float"
  assumes normal:
    "\<And>x. is_normal x \<Longrightarrow> valof x = normal_mantissa x * 2 powr normal_exponent x \<Longrightarrow> P x"
  assumes denormal:
    "\<And>x. is_denormal x \<Longrightarrow>
      valof x = denormal_mantissa x * 2 powr denormal_exponent TYPE(('e, 'f)float) \<Longrightarrow>
      P x"
  assumes zero: "P 0" "P minus_zero"
  assumes infty: "P plus_infinity" "P minus_infinity"
  assumes nan: "\<And>x. is_nan x \<Longrightarrow> P x"
  shows "P a"
proof -
  from float_cases[of a]
  consider "is_nan a" | "is_infinity a" | "is_normal a" | "is_denormal a" | "is_zero a" by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis by (rule nan)
  next
    case 2
    then consider "a = plus_infinity" | "a = minus_infinity" by (rule is_infinity_cases)
    then show ?thesis
      by cases (auto intro: infty)
  next
    case hyps: 3
    from hyps have "valof a = normal_mantissa a * 2 powr normal_exponent a"
      by (cases a rule: sign_cases)
        (auto simp: valof_eq normal_mantissa_def normal_exponent_def is_normal_def
          powr_realpow[symmetric] powr_diff powr_add divide_simps algebra_simps)
    from hyps this show ?thesis
      by (rule normal)
  next
    case hyps: 4
    from hyps have "valof a = denormal_mantissa a * 2 powr denormal_exponent TYPE(('e, 'f)float)"
      by (cases a rule: sign_cases)
        (auto simp: valof_eq denormal_mantissa_def denormal_exponent_def is_denormal_def
          powr_realpow[symmetric] powr_diff powr_add divide_simps algebra_simps)
    from hyps this show ?thesis
      by (rule denormal)
  next
    case 5
    then consider "a = 0" | "a = minus_zero" by (rule is_zero_cases)
    then show ?thesis
      by cases (auto intro: zero)
  qed
qed

lemma infinite_infinity[simp]: "\<not> is_finite plus_infinity" "\<not> is_finite minus_infinity"
  by (auto simp: is_finite_def is_normal_def infinity_simps is_denormal_def is_zero_def)

lemma nan_not_finite[simp]: "is_nan x \<Longrightarrow> \<not> is_finite x"
  using float_distinct_finite(1) by blast

lemma valof_nonneg:
  "valof x \<ge> 0" if "sign x = 0" for x::"('e, 'f)float"
  by (auto simp: valof_eq that)

lemma valof_nonpos:
  "valof x \<le> 0" if "sign x = 1" for x::"('e, 'f)float"
  using that
  by (auto simp: valof_eq is_finite_def)

lemma real_le_intI: "x \<le> y" if "floor x \<le> floor y" "x \<in> \<int>" for x y::real
  using that(2,1)
  by (induction rule: Ints_induct) (auto elim!: Ints_induct simp: le_floor_iff)

lemma real_of_int_le_2_powr_bitlenI:
  "real_of_int x \<le> 2 powr n - 1" if "bitlen (abs x) \<le> m" "m \<le> n"
proof -
  have "real_of_int x \<le> abs (real_of_int x)" by simp
  also have "\<dots> < 2 powr (bitlen (abs x))"
    by (rule abs_real_le_2_powr_bitlen)
  finally have "real_of_int x \<le> 2 powr (bitlen (abs x)) - 1"
    by (auto simp: powr_real_of_int bitlen_nonneg intro!: real_le_intI)
  also have "\<dots> \<le> 2 powr m - 1"
    by (simp add: that)
  also have "\<dots> \<le> 2 powr n - 1"
    by (simp add: that)
  finally show ?thesis .
qed

lemma largest_eq:
  "largest TYPE(('e, 'f)float) =
    (2 ^ (LENGTH('f) + 1) - 1) * 2 powr real_of_int (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
proof -
  have "2 ^ LENGTH('e) - 1 - 1 = (2::nat) ^ LENGTH('e) - 2"
    by arith
  then have "largest TYPE(('e, 'f)float) =
    (2 ^ (LENGTH('f) + 1) - 1) *
    2 powr (real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f))"
    unfolding largest_def emax_eq bias_def
    by (auto simp: largest_def powr_realpow[symmetric]
        powr_minus divide_simps algebra_simps powr_diff powr_add of_nat_diff)
  also
  have "2 ^ LENGTH('e) \<ge> (2::nat)"
    by (simp add: self_le_power)
  then have "(real (2 ^ LENGTH('e) - 2) + 1 - real (2 ^ (LENGTH('e) - 1)) - LENGTH('f)) =
    (real (2 ^ LENGTH('e)) - 2 ^ (LENGTH('e) - 1) - LENGTH('f)) - 1"
    by (auto simp add: of_nat_diff)
  also have "real (2 ^ LENGTH('e)) = 2 ^ LENGTH('e)" by auto
  also have "(2 ^ LENGTH('e) - 2 ^ (LENGTH('e) - 1) - real LENGTH('f) - 1) =
    real_of_int ((2 ^ (LENGTH('e) - 1) - int (LENGTH('f)) - 1))"
    by (simp, subst power_Suc[symmetric], simp)
  finally show ?thesis by simp
qed

lemma bitlen_denormal_mantissa:
  "bitlen (abs (denormal_mantissa x)) \<le> LENGTH('f)" for x::"('e, 'f)float"
proof -
  have "fraction x < 2 ^ LENGTH('f)"
    using float_frac_le[of x]
    by (metis One_nat_def Suc_pred le_imp_less_Suc pos2 zero_less_power)
  moreover have "- int (fraction x) \<le> 2 ^ LENGTH('f)"
    using negative_zle_0 order_trans zero_le_numeral zero_le_power by blast
  ultimately show ?thesis
    by (cases x rule: sign_cases)
      (auto simp: bitlen_le_iff_power denormal_mantissa_def intro!: antisym)
qed

lemma float_le_topfloat:
  fixes a::"('e, 'f)float"
  assumes "is_finite a" "LENGTH('e) > 1"
  shows "a \<le> topfloat"
  using assms(1)
proof (induction a rule: float_induct)
  case (normal x)
  note normal(2)
  also have "real_of_int (normal_mantissa x) * 2 powr real_of_int (normal_exponent x) \<le>
    (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
    using normal_exponent_bounds_real(2)[OF \<open>is_normal x\<close>]
    by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI
        simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero)
  also have "\<dots> = largest TYPE(('e, 'f) IEEE.float)"
    unfolding largest_eq
    by (auto simp: powr_realpow powr_add)
  also have "\<dots> = valof (topfloat::('e, 'f) float)"
    using assms
    by (simp add: valof_topfloat)
  finally show ?case
    by (intro float_leI normal finite_topfloat)
next
  case (denormal x)
  note denormal(2)
  also
  have "3 \<le> 2 powr (1 + real (LENGTH('e) - Suc 0))"
  proof -
    have "3 \<le> 2 powr (2::real)" by simp
    also have "\<dots> \<le> 2 powr (1 + real (LENGTH('e) - Suc 0))"
      using assms
      by (subst powr_le_cancel_iff) auto
    finally show ?thesis .
  qed
  then have "real_of_int (denormal_mantissa x) * 2 powr real_of_int (denormal_exponent TYPE(('e, 'f)float)) \<le>
    (2 powr (LENGTH('f) + 1) - 1) * 2 powr (2 ^ (LENGTH('e) - 1) - int LENGTH('f) - 1)"
    using bitlen_denormal_mantissa[of x]
    by (auto intro!: mult_mono real_of_int_le_2_powr_bitlenI
        simp: bitlen_normal_mantissa powr_realpow[symmetric] ge_one_powr_ge_zero
        denormal_exponent_def bias_def powr_mult_base of_nat_diff)
  also have "\<dots> \<le> largest TYPE(('e, 'f) IEEE.float)"
    unfolding largest_eq
    by (rule mult_mono)
      (auto simp: powr_realpow powr_add power_Suc[symmetric] simp del: power_Suc)
  also have "\<dots> = valof (topfloat::('e, 'f) float)"
    using assms
    by (simp add: valof_topfloat)
  finally show ?case
    by (intro float_leI denormal finite_topfloat)
qed auto

lemma float_val_le_largest:
  "valof a \<le> largest TYPE(('e, 'f)float)"
  if "is_finite a" "LENGTH('e) > 1"
  for a::"('e, 'f)float"
  by (metis that finite_topfloat float_le float_le_topfloat valof_topfloat)

lemma float_val_lt_threshold:
  "valof a < threshold TYPE(('e, 'f)float)"
  if "is_finite a" "LENGTH('e) > 1"
  for a::"('e, 'f)float"
proof -
  have "valof a \<le> largest TYPE(('e, 'f)float)"
    by (rule float_val_le_largest [OF that])
  also have "\<dots> < threshold TYPE(('e, 'f)float)"
    by (auto simp: largest_def threshold_def divide_simps)
  finally show ?thesis .
qed

subsection \<open>Algebraic properties about basic arithmetic\<close>

text \<open>Commutativity of addition.\<close>
lemma
  assumes "is_finite a" "is_finite b"
  shows float_plus_comm_eq: "a + b = b + a"
    and float_plus_comm: "is_finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
proof -
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  then show "a + b = b + a"
    by (simp add: float_defs fadd_def plus_float_def add.commute)
  then show "is_finite (a + b) \<Longrightarrow> (a + b) \<doteq> (b + a)"
    by (metis float_eq)
qed

text \<open>The floating-point number a falls into the same category as the negation of \<open>a\<close>.\<close>
lemma is_zero_uminus[simp]: "is_zero (- a) \<longleftrightarrow> is_zero a"
  by (simp add: is_zero_def)

lemma is_infinity_uminus [simp]: "is_infinity (- a) = is_infinity a"
  by (simp add: is_infinity_def)

lemma is_finite_uminus[simp]: "is_finite (- a) \<longleftrightarrow> is_finite a"
  by (simp add: is_finite_def)

lemma is_nan_uminus[simp]: "is_nan (- a) \<longleftrightarrow> is_nan a"
  by (simp add: is_nan_def)

text \<open>The sign of a and the sign of a's negation is different.\<close>
lemma float_neg_sign: "(sign a) \<noteq> (sign (- a))"
  by (cases a rule: sign_cases) (auto simp: sign_minus_float)

lemma valof_uminus:
  assumes "is_finite a"
  shows "valof (- a) = - valof a" (is "?L = ?R")
  by (cases a rule: sign_cases)  (auto simp: valof_eq sign_minus_float)

text \<open>Showing \<open>a + (- b) = a - b\<close>.\<close>
lemma float_neg_add:
  "is_finite a \<Longrightarrow> is_finite b \<Longrightarrow> is_finite (a - b) \<Longrightarrow> valof a + valof (- b) = valof a - valof b"
  by (simp add: valof_uminus)

lemma float_plus_minus:
  assumes "is_finite a" "is_finite b" "is_finite (a - b)"
  shows "(a + - b) \<doteq> (a - b)"
proof -
  have nab: "\<not> is_nan a" "\<not> is_nan (- b)" "\<not> is_infinity a" "\<not> is_infinity (-  b)"
    using assms by (auto simp: finite_nan finite_infinity)
  have "a - b = (zerosign
        (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then (sign a) else 0)
        (round To_nearest (valof a - valof b)))"
    using nab
    by (auto simp: minus_float_def fsub_def)
  also have "\<dots> =
    (zerosign
        (if is_zero a \<and> is_zero (- b) \<and> sign a = sign (- b) then sign a else 0)
        (round To_nearest (valof a + valof (- b))))"
    using assms
    by (simp add: float_neg_sign1 float_neg_add)
  also have "\<dots> = a + - b"
    using nab by (auto simp: float_defs fadd_def plus_float_def)
  finally show ?thesis
    using assms by (metis float_eq)
qed

lemma finite_bottomfloat: "is_finite bottomfloat"
  by (simp add: finite_topfloat)

lemma bottomfloat_eq_m_largest: "valof (bottomfloat::('e, 'f)float) = - largest TYPE(('e, 'f)float)"
  if "LENGTH('e) > 1"
  using that
  by (auto simp: valof_topfloat valof_uminus finite_topfloat)

lemma float_val_ge_bottomfloat: "valof a \<ge> valof (bottomfloat::('e, 'f)float)"
  if "LENGTH('e) > 1" "is_finite a"
  for a::"('e,'f)float"
proof -
  have "- a \<le> topfloat"
    using that
    by (auto intro: float_le_topfloat)
  then show ?thesis
    using that
    by (auto simp: valof_uminus finite_topfloat)
qed

lemma float_ge_bottomfloat: "is_finite a \<Longrightarrow> a \<ge> bottomfloat"
  if "LENGTH('e) > 1" "is_finite a"
  for a::"('e,'f)float"
  by (metis finite_bottomfloat float_le float_val_ge_bottomfloat that)

lemma float_val_ge_largest:
  fixes a::"('e,'f)float"
  assumes "LENGTH('e) > 1" "is_finite a"
  shows "valof a \<ge> - largest TYPE(('e,'f)float)"
proof -
  have "- largest TYPE(('e,'f)float) = valof (bottomfloat::('e,'f)float)"
    using assms
    by (simp add: bottomfloat_eq_m_largest)
  also have "\<dots> \<le> valof a"
    using assms by (simp add: float_val_ge_bottomfloat)
  finally show ?thesis .
qed

lemma float_val_gt_threshold:
  fixes a::"('e,'f)float"
  assumes "LENGTH('e) > 1" "is_finite a"
  shows "valof a > - threshold TYPE(('e,'f)float)"
proof -
  have largest: "valof a \<ge> -largest TYPE(('e,'f)float)"
    using assms by (metis float_val_ge_largest)
  then have "-largest TYPE(('e,'f)float) > - threshold TYPE(('e,'f)float)"
    by (auto simp: bias_def threshold_def largest_def divide_simps)
  then show ?thesis
    by (metis largest less_le_trans)
qed

text \<open>Showing \<open>abs (- a) = abs a\<close>.\<close>
lemma float_abs [simp]: "\<not> is_nan a \<Longrightarrow> abs (- a) = abs a"
  by (metis IEEE.abs_float_def float_neg_sign1 minus_minus_float zero_simps(1))

lemma neg_zerosign: "- (zerosign s a) = zerosign (1 - s) (- a)"
  by (auto simp: zerosign_def)

subsection \<open>Properties about Rounding Errors\<close>

definition error :: "('e, 'f)float itself \<Rightarrow> real \<Rightarrow> real"
  where "error _ x = valof (round To_nearest x::('e, 'f)float) - x"

lemma bound_at_worst_lemma:
  fixes a::"('e, 'f)float"
  assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
  assumes finite: "is_finite a"
  shows "\<bar>valof (round To_nearest x::('e, 'f)float) - x\<bar> \<le> \<bar>valof a - x\<bar>"
proof -
  have *: "(round To_nearest x::('e,'f)float) =
      closest valof (\<lambda>a. even (fraction a)) {a. is_finite a} x"
    using threshold finite
    by auto
  have "is_closest (valof) {a. is_finite a} x (round To_nearest x::('e,'f)float)"
    using is_finite_nonempty
    unfolding *
    by (intro closest_is_closest) auto
  then show ?thesis
    using finite is_closest_def by (metis mem_Collect_eq)
qed

lemma error_at_worst_lemma:
  fixes a::"('e, 'f)float"
  assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
    and "is_finite a"
  shows "\<bar>error TYPE(('e, 'f)float) x\<bar> \<le> \<bar>valof a - x\<bar> "
  unfolding error_def
  by (rule bound_at_worst_lemma; fact)

lemma error_is_zero [simp]:
  fixes a::"('e, 'f)float"
  assumes "is_finite a" "1 < LENGTH('e)"
  shows "error TYPE(('e, 'f)float) (valof a) = 0"
proof -
  have "\<bar>valof a\<bar> < threshold TYPE(('e, 'f)float)"
    by (metis abs_less_iff minus_less_iff float_val_gt_threshold float_val_lt_threshold assms)
  then show ?thesis
    by (metis abs_le_zero_iff abs_zero diff_self error_at_worst_lemma assms(1))
qed

lemma is_finite_zerosign[simp]: "is_finite (zerosign s a) \<longleftrightarrow> is_finite a"
  by (auto simp: zerosign_def is_finite_def)

lemma is_finite_closest: "is_finite (closest (v::_\<Rightarrow>real) p {a. is_finite a} x)"
  using closest_is_closest[OF is_finite_nonempty, of v x p]
  by (auto simp: is_closest_def)

lemma defloat_float_zerosign_round_finite:
  assumes threshold: "\<bar>x\<bar> < threshold TYPE(('e, 'f)float)"
  shows "is_finite (zerosign s (round To_nearest x::('e, 'f)float))"
proof -
  have "(round To_nearest x::('e, 'f)float) =
      (closest valof (\<lambda>a. even (fraction a)) {a. is_finite a} x)"
    using threshold by (metis (full_types) abs_less_iff leD le_minus_iff round.simps(1))
  then have "is_finite (round To_nearest x::('e, 'f)float)"
    by (metis is_finite_closest)
  then show ?thesis
    using is_finite_zerosign by auto
qed

lemma valof_zero[simp]: "valof 0 = 0" "valof minus_zero = 0"
  by (auto simp add: zerosign_def valof_eq zero_simps)

lemma signzero_zero:
  "is_zero a \<Longrightarrow> valof (zerosign s a) = 0"
  by (auto simp add: zerosign_def)

lemma val_zero: "is_zero a \<Longrightarrow> valof a = 0"
  by (cases a rule: is_zero_cases) auto

lemma float_add:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and threshold: "\<bar>valof a + valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_add: "is_finite (a + b)"
    and error_float_add:  "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)"
proof -
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  then have ab: "(a + b) =
    (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a = sign b then (sign a) else 0)
      (round To_nearest (valof a + valof b)))"
    using assms by (auto simp add: float_defs fadd_def plus_float_def)
  then show "is_finite ((a + b))"
    by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a + b) =
    valof (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a = sign b then (sign a) else 0)
      (round To_nearest (valof a + valof b)::('e, 'f)float))"
    by (auto simp: ab is_infinity_def is_nan_def valof_def)
  show "valof (a + b) = valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b)"
  proof (cases "is_zero (round To_nearest (valof a + valof b)::('e, 'f)float)")
    case True
    have "valof a + valof b + error TYPE(('e, 'f)float) (valof a + valof b) =
        valof (round To_nearest (valof a + valof b)::('e, 'f)float)"
      unfolding error_def
      by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False
    then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_sub:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and threshold: "\<bar>valof a - valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_sub: "is_finite (a - b)"
    and error_float_sub: "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)"
proof -
  have "\<not> is_nan a" and "\<not> is_nan b" and "\<not> is_infinity a" and "\<not> is_infinity b"
    using assms by (auto simp: finite_nan finite_infinity)
  then have ab: "a - b =
    (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then sign a else 0)
      (round To_nearest (valof a - valof b)))"
    using assms by (auto simp add: float_defs fsub_def minus_float_def)
  then show "is_finite (a - b)"
   by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a - b) =
    valof (zerosign
      (if is_zero a \<and> is_zero b \<and> sign a \<noteq> sign b then sign a else 0)
      (round To_nearest (valof a - valof b)::('e, 'f)float))"
    by (auto simp: ab is_infinity_def is_nan_def valof_def)
  show "valof (a - b) = valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b)"
  proof (cases "is_zero (round To_nearest (valof a - valof b)::('e, 'f)float)")
    case True
    have "valof a - valof b + error TYPE(('e, 'f)float) (valof a - valof b) =
        valof (round To_nearest (valof a - valof b)::('e, 'f)float)"
      unfolding error_def by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False
    then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_mul:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and threshold: "\<bar>valof a * valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_mul: "is_finite (a * b)"
    and error_float_mul: "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)"
proof -
  have non: "\<not> is_nan a" "\<not> is_nan b" "\<not> is_infinity a" "\<not> is_infinity b"
    using assms float_distinct_finite by auto
  then have ab: "a * b =
    (zerosign (of_bool (sign a \<noteq> sign b))
      (round To_nearest (valof a * valof b)::('e, 'f)float))"
    using assms by (auto simp: float_defs fmul_def times_float_def)
  then show "is_finite (a * b)"
    by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a * b) =
      valof (zerosign (of_bool (sign a \<noteq> sign b))
        (round To_nearest (valof a * valof b)::('e, 'f)float))"
    by (auto simp: ab float_defs of_bool_def)
  show "valof (a * b) = valof a * valof b + error TYPE(('e, 'f)float) (valof a * valof b)"
  proof (cases "is_zero (round To_nearest (valof a * valof b)::('e, 'f)float)")
    case True
    have "valof a * valof b + error TYPE(('e, 'f)float)  (valof a * valof b) =
        valof (round To_nearest (valof a * valof b)::('e, 'f)float)"
      unfolding error_def
      by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_div:
  fixes a b::"('e, 'f)float"
  assumes "is_finite a"
    and "is_finite b"
    and not_zero: "\<not> is_zero b"
    and threshold: "\<bar>valof a / valof b\<bar> < threshold TYPE(('e, 'f)float)"
  shows finite_float_div: "is_finite (a / b)"
    and error_float_div: "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b)"
proof -
  have ab: "a / b =
    (zerosign (of_bool (sign a \<noteq> sign b))
      (round To_nearest (valof a / valof b)))"
     using assms
     by (simp add: divide_float_def fdiv_def finite_infinity finite_nan not_zero float_defs [symmetric])
  then show "is_finite (a / b)"
    by (metis threshold defloat_float_zerosign_round_finite)
  have val_ab: "valof (a / b) =
      valof (zerosign (of_bool (sign a \<noteq> sign b))
        (round To_nearest (valof a / valof b))::('e, 'f)float)"
    by (auto simp: ab float_defs of_bool_def)
  show "valof (a / b) = valof a / valof b + error TYPE(('e, 'f)float)  (valof a / valof b)"
  proof (cases "is_zero (round To_nearest (valof a / valof b)::('e, 'f)float)")
    case True
    have "valof a / valof b + error TYPE(('e, 'f)float) (valof a / valof b) =
        valof (round To_nearest (valof a / valof b)::('e, 'f)float)"
      unfolding error_def
      by simp
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma valof_one[simp]: "valof (1::('e, 'f)float) = (if LENGTH('e) \<le> 1 then 0 else 1)"
  by transfer (auto simp: bias_def unat_sub word_1_le_power p2_eq_1)

end


(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory System_L0 imports System_L1 begin

inductive L0 (\<open>\<LL>\<^sub>0\<close>) where
  \<open>\<LL>\<^sub>0 q\<close> if \<open>\<LL>\<^sub>0 p\<close> and \<open>\<LL>\<^sub>0 (p \<rightarrow> q)\<close> |
  \<open>\<LL>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close> |
  \<open>\<LL>\<^sub>0 (((\<sim> p) \<rightarrow> q) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> p))\<close> |
  \<open>\<LL>\<^sub>0 (p \<rightarrow> ((\<sim> p) \<rightarrow> q))\<close>

lemma L0_lemma: \<open>\<LL>\<^sub>0 (((\<sim> p) \<rightarrow> p) \<rightarrow> p)\<close>
  by (metis L0.intros)

theorem L0_soundness: \<open>\<LL>\<^sub>0 p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: L0.induct) (simp, simp, metis semantics.simps(2,3), simp)

theorem L0_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<LL>\<^sub>0 p\<close>
  by (metis (full_types) L0_lemma L1_completeness L0.simps Axiomatics.inducts)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<LL>\<^sub>0 p\<close>
  unfolding valid_def using L0_soundness L0_completeness by blast

lemmas L0 = L0.intros main

end


(*  Title:      HOL/Probability/Discrete_Topology.thy
    Author:     Fabian Immler, TU München
*)

theory Discrete_Topology
imports "~~/src/HOL/Analysis/Analysis"
begin

text \<open>Copy of discrete types with discrete topology. This space is polish.\<close>

typedef 'a discrete = "UNIV::'a set"
morphisms of_discrete discrete
..

instantiation discrete :: (type) metric_space
begin

definition dist_discrete :: "'a discrete \<Rightarrow> 'a discrete \<Rightarrow> real"
  where "dist_discrete n m = (if n = m then 0 else 1)"

definition uniformity_discrete :: "('a discrete \<times> 'a discrete) filter" where
  "(uniformity::('a discrete \<times> 'a discrete) filter) = (INF e:{0 <..}. principal {(x, y). dist x y < e})"

definition "open_discrete" :: "'a discrete set \<Rightarrow> bool" where
  "(open::'a discrete set \<Rightarrow> bool) U \<longleftrightarrow> (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"

instance proof qed (auto simp: uniformity_discrete_def open_discrete_def dist_discrete_def intro: exI[where x=1])
end

lemma open_discrete: "open (S :: 'a discrete set)"
  unfolding open_dist dist_discrete_def by (auto intro!: exI[of _ "1 / 2"])

instance discrete :: (type) complete_space
proof
  fix X::"nat\<Rightarrow>'a discrete" assume "Cauchy X"
  hence "\<exists>n. \<forall>m\<ge>n. X n = X m"
    by (force simp: dist_discrete_def Cauchy_def split: if_split_asm dest:spec[where x=1])
  then guess n ..
  thus "convergent X"
    by (intro convergentI[where L="X n"] tendstoI eventually_sequentiallyI[of n])
       (simp add: dist_discrete_def)
qed

instance discrete :: (countable) countable
proof
  have "inj (\<lambda>c::'a discrete. to_nat (of_discrete c))"
    by (simp add: inj_on_def of_discrete_inject)
  thus "\<exists>f::'a discrete \<Rightarrow> nat. inj f" by blast
qed

instance discrete :: (countable) second_countable_topology
proof
  let ?B = "range (\<lambda>n::'a discrete. {n})"
  have "\<And>S. generate_topology ?B (\<Union>x\<in>S. {x})"
    by (intro generate_topology_Union) (auto intro: generate_topology.intros)
  then have "open = generate_topology ?B"
    by (auto intro!: ext simp: open_discrete)
  moreover have "countable ?B" by simp
  ultimately show "\<exists>B::'a discrete set set. countable B \<and> open = generate_topology B" by blast
qed

instance discrete :: (countable) polish_space ..

end


theory Confluence
  imports Semantics
begin

lemma beta_same[simp]: "\<lbrakk> e1 \<longrightarrow>* e1' ; beta_nf e1 \<rbrakk> \<Longrightarrow> e1 = e1'"
  by (induction e1 e1' rule: Steps.induct) (auto simp: beta_nf_def)

fun path :: "term \<Rightarrow> term list \<Rightarrow> term \<Rightarrow> bool" where
  "path a [] b \<longleftrightarrow> a = b \<or> Step a b"
| "path a (x#xs) b \<longleftrightarrow> Step a x \<and> path x xs b"

lemma path_snoc: "\<lbrakk> path a xs b ; Step b c \<rbrakk> \<Longrightarrow> path a (xs@[b]) c \<or> path a xs c"
  by (induction a xs b arbitrary: c rule: path.induct) auto

lemma Steps_concat: "\<lbrakk> e2 \<longrightarrow>* e3 ; e1 \<longrightarrow>* e2 \<rbrakk> \<Longrightarrow> e1 \<longrightarrow>* e3"
  apply (induction e2 e3 arbitrary: e1 rule: Steps.induct)
  using Steps.simps by blast+

lemma Steps_path: "a \<longrightarrow>* b \<longleftrightarrow> (\<exists>p. path a p b)"
proof
  assume "a \<longrightarrow>* b"
  then show "\<exists>p. path a p b"
  proof (induction a b rule: Steps.induct)
    case (refl e)
    then have "path e [] e" by simp
    then show ?case by blast
  next
    case (trans e1 e2 e3)
    then obtain xs where "path e1 xs e2" by blast
    then have "path e1 (xs@[e2]) e3 \<or> path e1 xs e3" using trans(2) path_snoc by simp
    then show ?case by blast
  qed
next
  assume "\<exists>p. path a p b"
  then obtain p where "path a p b" by blast
  then show "a \<longrightarrow>* b"
  proof (induction a p b rule: path.induct)
    case (1 a b)
    then show ?case using Steps.intros by auto
  next
    case (2 a x xs b)
    then have a: "a \<longrightarrow>* x" using Steps.intros by auto
    from 2 have b: "x \<longrightarrow>* b" by simp
    show ?case using Steps_concat[OF b a] .
  qed
qed

lemma Steps_fwd_induct[consumes 1, case_names refl trans]:
  assumes "a \<longrightarrow>* b"
    and "\<And>x. P x x" "\<And>x y z. y \<longrightarrow>* z \<Longrightarrow> P y z \<Longrightarrow> Step x y \<Longrightarrow> P x z"
  shows "P a b"
proof -
  from assms(1) obtain p where P: "path a p b" using Steps_path by blast
  then show ?thesis
  proof (induction a p b rule: path.induct)
    case (1 a b)
    then show ?case
    proof (cases "a = b")
      case True
      then show ?thesis using assms(2) by simp
    next
      case False
      then have 1: "Step a b" using 1 by simp
      have 2: "b \<longrightarrow>* b" using Steps.refl by simp
      show ?thesis using assms(3)[OF 2 assms(2) 1] .
    qed
  next
    case (2 a x xs b)
    then have 1: "P x b" by simp
    from 2 have 3: "x \<longrightarrow>* b" using Steps_path by auto
    from 2 have 4: "Step a x" by simp
    show ?case using assms(3)[OF 3 1 4] .
  qed
qed

lemma confluence: "\<lbrakk> a \<longrightarrow>* b ; a \<longrightarrow>* c \<rbrakk> \<Longrightarrow> \<exists>d. b \<longrightarrow>* d \<and> c \<longrightarrow>* d"
  apply (induction a b arbitrary: c rule: Steps_fwd_induct)
  using Steps.refl apply blast
  by (metis Step_deterministic Steps.trans Steps_concat Steps_path path.elims(2))

corollary beta_equivalence: "\<lbrakk> e1 \<longrightarrow>* e1' ; e2 \<longrightarrow>* e2' ; e1 = e2 ; beta_nf e1' ; beta_nf e2' \<rbrakk> \<Longrightarrow> e1' = e2'"
  using beta_same confluence by blast

end


theory FiniteListGraph_Impl
imports
  FiniteListGraph
  "../../Collections/ICF/impl/RBTSetImpl" (*red black trees*)
  (*maybe import the following only at the end*)
  "Efficient_Distinct"
  "~~/src/HOL/Library/Code_Char"
  "~~/src/HOL/Library/Code_Target_Nat"
begin

text {* A graph's validity can be tested with an executable function. *}
  fun valid_list_graph_impl::"'v list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> bool" where
    "valid_list_graph_impl V [] = True" |
    "valid_list_graph_impl V ((v1,v2)#Es) = (v1 \<in> set V \<and> v2 \<in> set V \<and> valid_list_graph_impl V Es)"

  lemma valid_list_graph_impl_axioms_locale_props:
    "valid_list_graph_impl V E \<longleftrightarrow> fst` set E \<subseteq> set V \<and> snd` set E \<subseteq> set V"
  by (induction E) auto

  (*making the \<in> more efficient*)
  fun valid_list_graph_impl_rs::"('v::linorder) rs \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> bool" where
    "valid_list_graph_impl_rs V [] = True" |
    "valid_list_graph_impl_rs V ((v1,v2)#Es) = (rs.memb v1 V \<and> rs.memb v2 V \<and> valid_list_graph_impl_rs V Es)"

  lemma[code]: "valid_list_graph_impl V E = valid_list_graph_impl_rs (rs.from_list V) E"
   apply(induction E)
    apply(simp add: rs.correct)
   apply(rename_tac e Es)
   apply(case_tac e)
   by(simp add: rs.correct)

  lemma[code]: "FiniteListGraph.valid_list_graph_axioms G = valid_list_graph_impl (nodesL G) (edgesL G)"
    by(simp add: FiniteListGraph.valid_list_graph_axioms_def valid_list_graph_impl_axioms_locale_props)

  text{*The list implementation matches the @{term "valid_graph"} definition*}
  theorem valid_list_graph_iff_valid_graph:
    "valid_graph (list_graph_to_graph G) \<longleftrightarrow> valid_list_graph_axioms G"
  apply(unfold list_graph_to_graph_def valid_graph_def valid_list_graph_axioms_def valid_list_graph_impl_axioms_locale_props)
    by simp
  corollary valid_list_graph_iff_valid_graph_simplified:
  "valid_graph \<lparr>nodes = set (nodesL G), edges = set (edgesL G)\<rparr> \<longleftrightarrow> valid_list_graph_axioms G"
  apply(simp add: valid_list_graph_iff_valid_graph[unfolded list_graph_to_graph_def, simplified])
  done

text {* Code examples. *}
  definition valid_graph_example where
  "valid_graph_example \<equiv> \<lparr> nodesL = [1::nat,4,6], edgesL = [(1,4), (1,6), (6,4)] \<rparr>"

  value "valid_list_graph valid_graph_example"

  definition valid_graph_impl_example where
  "valid_graph_impl_example \<equiv> valid_list_graph valid_graph_example"

  export_code valid_list_graph empty add_node delete_node add_edge delete_edge in Scala

end


theory Exercise8
  imports Main
begin

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse x Nil = Nil"
  | "intersperse x [y] = [y]"
  | "intersperse x (y # (z # xs)) = y # (x # (intersperse x (z # xs)))"

theorem itnersperse_map_distributivity [simp]: "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs rule: intersperse.induct)
  apply auto
done

end