(*  Title:       An Efficient Generalization of Counting Sort for Large, possibly Infinite Key Ranges
    Author:      Pasquale Noce
                 Software Engineer at HID Global, Italy
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at hidglobal dot com
*)

section "Proof of objects' sorting"

theory Sorting
  imports Conservation
begin

text \<open>
\null

In this section, it is formally proven that GCsort actually sorts objects.

Here below, steps 5, 6, and 7 of the proof method are accomplished. Predicate @{text sort_inv} is
satisfied just in case, for any bucket delimited by the input counters' list $ns$, the keys of the
corresponding objects within the input objects' list $xs$ are not larger than those of the objects,
if any, to the right of that bucket. The underlying idea is that this predicate:

\begin{itemize}

\item
is trivially satisfied by the output of function @{const gcsort_in}, which places all objects into a
single bucket, and

\item
implies that $xs$ is sorted if every bucket delimited by $ns$ has size one, as happens when function
@{const gcsort_aux} terminates.

\end{itemize}

\null
\<close>

fun sort_inv :: "('a \<Rightarrow> 'b::linorder) \<Rightarrow> nat \<times> nat list \<times> 'a list \<Rightarrow> bool" where
"sort_inv key (u, ns, xs) =
  (\<forall>i < length ns. \<forall>j < offs ns 0 ! i. \<forall>k \<in> {offs ns 0 ! i..<length xs}.
    key (xs ! j) \<le> key (xs ! k))"

lemma gcsort_sort_input:
 "sort_inv key (0, [length xs], xs)"
by simp

lemma offs_nth:
  assumes
    A: "find (\<lambda>n. Suc 0 < n) ns = None" and
    B: "foldl (+) 0 ns = n" and
    C: "k < n"
  shows "\<exists>i < length ns. offs ns 0 ! i = k"
proof (cases ns, insert B C, simp, cases "k = 0", rule exI [of _ 0], simp,
 rule ccontr, simp (no_asm_use))
  fix m ms
  assume
    D: "ns = m # ms" and
    E: "0 < k" and
    F: "\<forall>i < length ns. offs ns 0 ! i \<noteq> k"
  have G: "\<forall>n \<in> set ns. n \<le> Suc 0"
    using A by (auto simp add: find_None_iff)
  let ?A = "{i. i < length ns \<and> offs ns 0 ! i < k}"
  have H: "Max ?A \<in> ?A"
    using D and E by (rule_tac Max_in, simp_all, rule_tac exI [of _ 0], simp)
  hence I: "Max ?A < length ns"
    by simp
  hence J: "offs ns 0 ! Max ?A = foldl (+) 0 (take (Max ?A) ns)"
    by (rule offs_add)
  have "Max ?A < length ns - Suc 0 \<or> Max ?A = length ns - Suc 0"
    (is "?P \<or> ?Q")
    using H by (simp, arith)
  moreover {
    assume ?P
    hence K: "Suc (Max ?A) < length ns" by simp
    hence "offs ns 0 ! Suc (Max ?A) = foldl (+) 0 (take (Suc (Max ?A)) ns)"
      by (rule offs_add)
    moreover have "take (Suc (Max ?A)) ns = take (Max ?A) ns @ [ns ! Max ?A]"
      using I by (rule take_Suc_conv_app_nth)
    ultimately have "offs ns 0 ! Suc (Max ?A) =
      offs ns 0 ! Max ?A + ns ! Max ?A"
      using J by simp
    moreover have "offs ns 0 ! Max ?A < k"
      using H by simp
    moreover have "ns ! Max ?A \<in> set ns"
      using I by (rule nth_mem)
    with G have "ns ! Max ?A \<le> Suc 0" ..
    ultimately have "offs ns 0 ! Suc (Max ?A) \<le> k" by simp
    moreover have "offs ns 0 ! Suc (Max ?A) \<noteq> k"
      using F and K by simp
    ultimately have "offs ns 0 ! Suc (Max ?A) < k" by simp
    hence "Suc (Max ?A) \<in> ?A"
      using K by simp
    hence "Suc (Max ?A) \<le> Max ?A"
      by (rule_tac Max_ge, simp)
    hence False by simp
  }
  moreover {
    assume ?Q
    hence "offs ns 0 ! Max ?A = foldl (+) 0 (take (length ns - Suc 0) ns)"
      using J by simp
    moreover have K: "length ns - Suc 0 < length ns"
      using D by simp
    hence "take (Suc (length ns - Suc 0)) ns =
      take (length ns - Suc 0) ns @ [ns ! (length ns - Suc 0)]"
      by (rule take_Suc_conv_app_nth)
    hence "foldl (+) 0 ns =
      foldl (+) 0 (take (length ns - Suc 0) ns @ [ns ! (length ns - Suc 0)])"
      by simp
    ultimately have "n = offs ns 0 ! Max ?A + ns ! (length ns - Suc 0)"
      using B by simp
    moreover have "offs ns 0 ! Max ?A < k"
      using H by simp
    moreover have "ns ! (length ns - Suc 0) \<in> set ns"
      using K by (rule nth_mem)
    with G have "ns ! (length ns - Suc 0) \<le> Suc 0" ..
    ultimately have "n \<le> k" by simp
    with C have False by simp
  }
  ultimately show False ..
qed

lemma gcsort_sort_intro:
 "\<lbrakk>sort_inv key t; add_inv n t; find (\<lambda>n. Suc 0 < n) (fst (snd t)) = None\<rbrakk> \<Longrightarrow>
    sorted (map key (gcsort_out t))"
proof (cases t, simp add: sorted_iff_nth_mono_less gcsort_out_def,
 erule conjE, (rule allI)+, (rule impI)+)
  fix ns xs j k
  assume "find (\<lambda>n. Suc 0 < n) ns = None" and "foldl (+) 0 ns = n"
  moreover assume A: "k < n"
  ultimately have "\<exists>i < length ns. offs ns 0 ! i = k"
    by (rule offs_nth)
  then obtain i where "i < length ns \<and> offs ns 0 ! i = k" ..
  moreover assume "\<forall>i < length ns. \<forall>j < offs ns 0 ! i. \<forall>k \<in> {offs ns 0 ! i..<n}.
    key (xs ! j) \<le> key (xs ! k)"
  hence "i < length ns \<longrightarrow> j < offs ns 0 ! i \<longrightarrow> k \<in> {offs ns 0 ! i..<n} \<longrightarrow>
    key (xs ! j) \<le> key (xs ! k)"
    by simp
  ultimately have "j < k \<longrightarrow> k < n \<longrightarrow> key (xs ! j) \<le> key (xs ! k)"
    by simp
  moreover assume "j < k"
  ultimately show "key (xs ! j) \<le> key (xs ! k)"
    using A by simp
qed

text \<open>
\null

As lemma @{thm [source] gcsort_sort_intro} comprises an additional assumption concerning the form of
the fixed points of function @{const gcsort_aux}, step 8 of the proof method is necessary this time
to prove that such assumption is satisfied.

\null
\<close>

lemma gcsort_sort_form:
 "find (\<lambda>n. Suc 0 < n) (fst (snd (gcsort_aux index key p t))) = None"
by (induction index key p t rule: gcsort_aux.induct, simp)

text \<open>
\null

Here below, step 9 of the proof method is accomplished.

In the most significant case of the proof by recursion induction of lemma @{text round_sort_inv},
namely that of a bucket $B$ with size larger than two and distinct minimum and maximum keys, the
following line of reasoning is adopted. Let $x$ be an object contained in a finer-grained bucket
$B'$ resulting from $B$'s partition, and $y$ an object to the right of $B'$. Then:

\begin{itemize}

\item
If $y$ is contained in some other finer-grained bucket resulting from $B$'s partition, inequality
@{term "key x \<le> key y"} holds because predicate @{const sort_inv} is satisfied by a counters' list
generated by function @{const enum} and an objects' list generated by function @{const fill} in case
@{const fill}'s input offsets' list is computed via the composition of functions @{const offs} and
@{const enum}, as happens within function @{const round}.
\\This is proven beforehand in lemma @{text fill_sort_inv}.

\item
Otherwise, inequality @{term "key x \<le> key y"} holds as well because object $x$ was contained in $B$
by lemma @{thm [source] fill_offs_enum_count_item}, object $y$ occurred to the right of $B$ by lemma
@{thm [source] round_count_inv}, and by hypothesis, the key of any object in $B$ was not larger than
that of any object to the right of $B$.

\end{itemize}

Using lemma @{text round_sort_inv}, the invariance of predicate @{const sort_inv} over inductive set
@{const gcsort_set} is then proven in lemma @{text gcsort_sort_inv}.

\null
\<close>

lemma mini_maxi_keys_le:
 "x \<in> set xs \<Longrightarrow> key (xs ! mini xs key) \<le> key (xs ! maxi xs key)"
by (frule mini_lb, drule maxi_ub, erule order_trans)

lemma mini_maxi_keys_eq [rule_format]:
 "key (xs ! mini xs key) = key (xs ! maxi xs key) \<longrightarrow> x \<in> set xs \<longrightarrow>
    key x = key (xs ! maxi xs key)"
by (induction xs, simp_all add: Let_def, (rule_tac [!] impI, (rule_tac [!] conjI)?)+,
 rule_tac [2-4] impI, frule_tac [1-3] mini_maxi_keys_le [where key = key], simp_all)

lemma offs_suc:
 "i < length ns \<Longrightarrow> offs ns (Suc k) ! i = Suc (offs ns k ! i)"
by (simp add: offs_add add_suc)

lemma offs_base_zero:
 "i < length ns \<Longrightarrow> offs ns k ! i = offs ns 0 ! i + k"
by (simp add: offs_add, subst add_base_zero, simp)

lemma offs_append:
 "offs (ms @ ns) k = offs ms k @ offs ns (foldl (+) k ms)"
by (induction ms arbitrary: k, simp_all)

lemma offs_enum_next_le [rule_format]:
  assumes
    A: "index_less index key" and
    B: "i < j" and
    C: "j < n" and
    D: "\<forall>x \<in> set xs. key x \<in> {mi..ma}"
  shows "offs_next (offs (enum xs index key n mi ma) k) (length xs + k)
    xs index key mi ma i \<le> offs (enum xs index key n mi ma) k ! j"
  (is "_ \<le> offs ?ns _ ! _")
proof (rule ccontr, simp add: not_le)
  assume E: "offs ?ns k ! j <
    offs_next (offs ?ns k) (length xs + k) xs index key mi ma i"
  from B have "offs_set_next (offs ?ns k) xs index key mi ma i =
    offs_set_next (offs ?ns k) xs index key mi ma j"
  proof (rule_tac set_eqI, rule_tac iffI, simp_all, rule_tac ccontr, simp add: not_less)
    fix m
    assume "m < length (offs ?ns k) \<and> i < m \<and>
      0 < offs_num (length (offs ?ns k)) xs index key mi ma m"
    hence F: "m \<in> offs_set_next (offs ?ns k) xs index key mi ma i"
      (is "_ \<in> ?A")
      by simp
    hence "Min ?A \<le> m"
      by (rule_tac Min_le, simp)
    moreover assume "m \<le> j"
    ultimately have "offs ?ns k ! Min ?A \<le> offs ?ns k ! j"
      using C by (rule_tac offs_mono, simp_all add: enum_length)
    hence "offs_next (offs ?ns k) (length xs + k) xs index key mi ma i \<le>
      offs ?ns k ! j"
      using F by (simp only: offs_next_def split: if_split, rule_tac conjI,
       blast, simp)
    thus False
      using E by simp
  qed
  hence "offs ?ns k ! j <
    offs_next (offs ?ns k) (length xs + k) xs index key mi ma j"
    using E by (simp only: offs_next_def)
  moreover have "offs_num n xs index key mi ma j = 0"
  proof (rule ccontr, simp)
    assume "0 < offs_num n xs index key mi ma j"
    hence "j \<in> offs_set_next (offs ?ns k) xs index key mi ma i"
      (is "_ \<in> ?A")
      using B and C by (simp add: offs_length enum_length)
    moreover from this have "Min ?A \<le> j"
      by (rule_tac Min_le, simp)
    hence "offs ?ns k ! Min ?A \<le> offs ?ns k ! j"
      using C by (erule_tac offs_mono, simp add: enum_length)
    ultimately have "offs_next (offs ?ns k) (length xs + k) xs index key mi ma i \<le>
      offs ?ns k ! j"
      by (simp only: offs_next_def split: if_split, rule_tac conjI, blast, simp)
    thus False
      using E by simp
  qed
  hence "offs ?ns k ! j =
    offs_next (offs ?ns k) (length xs + k) xs index key mi ma j"
    using A and C and D by (rule_tac offs_enum_zero, simp_all)
  ultimately show False by simp
qed

lemma offs_pred_ub_less:
 "\<lbrakk>offs_pred ns ub xs index key mi ma; i < length ns;
   0 < offs_num (length ns) xs index key mi ma i\<rbrakk> \<Longrightarrow>
     ns ! i < ub"
by (drule offs_pred_ub, assumption+, simp)

lemma fill_count_none [rule_format]:
  assumes A: "index_less index key"
  shows
   "(\<forall>x \<in> set xs. key x \<in> {mi..ma}) \<longrightarrow>
    ns \<noteq> [] \<longrightarrow>
    offs_pred ns ub xs index key mi ma \<longrightarrow>
    length xs \<le> ub \<longrightarrow>
      count (mset (fill xs ns index key ub mi ma)) None = ub - length xs"
  using A
proof (induction xs arbitrary: ns, simp_all add: replicate_count Let_def,
 (rule_tac impI)+, (erule_tac conjE)+, subst mset_update, simp add: fill_length,
 erule_tac offs_pred_ub_less, simp_all add: index_less_def offs_num_cons del:
 not_None_eq, subst conj_commute, rule_tac conjI, rule_tac [!] impI, rotate_tac,
 rotate_tac, erule_tac contrapos_np, rule_tac fill_index_none, simp_all)
  fix x xs and ns :: "nat list"
  let ?i = "index key x (length ns) mi ma"
  let ?ns' = "ns[?i := Suc (ns ! ?i)]"
  assume "\<And>ns. ns \<noteq> [] \<longrightarrow> offs_pred ns ub xs index key mi ma \<longrightarrow>
    count (mset (fill xs ns index key ub mi ma)) None = ub - length xs"
  moreover assume B: "ns \<noteq> []"
  moreover assume
   "offs_pred ns ub (x # xs) index key mi ma" and
   "mi \<le> key x" and
   "key x \<le> ma"
  hence "offs_pred ?ns' ub xs index key mi ma"
    using A and B by (rule_tac offs_pred_cons, simp_all add: index_less_def)
  ultimately show "count (mset (fill xs ?ns' index key ub mi ma)) None -
    Suc 0 = ub - Suc (length xs)"
    by simp
qed

lemma fill_offs_enum_count_none [rule_format]:
 "\<lbrakk>index_less index key; \<forall>x \<in> set xs. key x \<in> {mi..ma}; 0 < n\<rbrakk> \<Longrightarrow>
    count (mset (fill xs (offs (enum xs index key n mi ma) 0)
      index key (length xs) mi ma)) None = 0"
by (subst fill_count_none, simp_all, simp only: length_greater_0_conv [symmetric]
 offs_length enum_length, insert offs_enum_pred [of index key xs mi ma n 0], simp)

lemma fill_index [rule_format]:
  assumes A: "index_less index key"
  shows
   "(\<forall>x \<in> set xs. key x \<in> {mi..ma}) \<longrightarrow>
    offs_pred ns ub xs index key mi ma \<longrightarrow>
    i < length ns \<longrightarrow>
    0 < offs_num (length ns) xs index key mi ma i \<longrightarrow>
    j \<in> {ns ! i..<offs_next ns ub xs index key mi ma i} \<longrightarrow>
    fill xs ns index key ub mi ma ! j = Some x \<longrightarrow>
      index key x (length ns) mi ma = i"
proof (induction xs arbitrary: ns, simp add: offs_num_def, simp add: Let_def,
 (rule impI)+, (erule conjE)+, simp)
  fix y xs and ns :: "nat list"
  let ?i = "index key x (length ns) mi ma"
  let ?i' = "index key y (length ns) mi ma"
  let ?ns' = "ns[?i' := Suc (ns ! ?i')]"
  let ?P = "\<lambda>ns.
    offs_pred ns ub xs index key mi ma \<longrightarrow>
    i < length ns \<longrightarrow>
    0 < offs_num (length ns) xs index key mi ma i \<longrightarrow>
    ns ! i \<le> j \<and> j < offs_next ns ub xs index key mi ma i \<longrightarrow>
    fill xs ns index key ub mi ma ! j = Some x \<longrightarrow>
      index key x (length ns) mi ma = i"
  assume
    B: "\<forall>x \<in> set xs. mi \<le> key x \<and> key x \<le> ma" and
    C: "mi \<le> key y" and
    D: "key y \<le> ma" and
    E: "offs_pred ns ub (y # xs) index key mi ma" and
    F: "i < length ns" and
    G: "0 < offs_num (length ns) (y # xs) index key mi ma i" and
    H: "ns ! i \<le> j" and
    I: "j < offs_next ns ub (y # xs) index key mi ma i" and
    J: "\<And>ns. ?P ns" and
    K: "(fill xs ?ns' index key ub mi ma)[ns ! ?i' := Some y] ! j = Some x"
  have "0 < length ns"
    using F by arith
  hence L: "?i' < length ns"
    using A and C and D by (simp add: index_less_def)
  hence "ns ! ?i' + offs_num (length ns) (y # xs) index key mi ma ?i' \<le> ub"
    by (rule_tac offs_pred_ub [OF E], simp_all add: offs_num_cons)
  hence "ns ! ?i' < ub"
    by (simp add: offs_num_cons)
  with K show "?i = i"
  proof (cases "j = ns ! ?i'", simp, subst (asm) nth_list_update_eq, simp_all
   add: fill_length)
    assume
      M: "j = ns ! ?i" and
      N: "y = x"
    show ?thesis
    proof (rule ccontr, erule neqE)
      assume "?i < i"
      hence "ns ! ?i + offs_num (length ns) (y # xs) index key mi ma ?i \<le> ns ! i"
        using F and G and N by (rule_tac offs_pred_asc [OF E], simp_all
         add: offs_num_cons)
      hence "j < ns ! i"
        using M and N by (simp add: offs_num_cons)
      thus False
        using H by simp
    next
      let ?A = "offs_set_next ns (y # xs) index key mi ma i"
      assume "i < ?i"
      hence O: "?i \<in> ?A"
        using N and L by (simp add: offs_num_cons)
      hence P: "Min ?A \<in> ?A"
        by (rule_tac Min_in, simp, blast)
      have "Min ?A \<le> ?i"
        using O by (rule_tac Min_le, simp)
      moreover have "?A \<noteq> {}"
        using O by blast
      ultimately have "offs_next ns ub (y # xs) index key mi ma i \<le> j"
      using M proof (simp only: offs_next_def, simp, subst (asm) le_less,
       erule_tac disjE, simp_all)
        assume "Min ?A < ?i"
        hence "ns ! Min ?A + offs_num (length ns) (y # xs) index key mi ma
          (Min ?A) \<le> ns ! ?i"
          using O and P by (rule_tac offs_pred_asc [OF E], simp_all)
        thus "ns ! Min ?A \<le> ns ! ?i" by simp
      qed
      thus False
        using I by simp
    qed
  next
    assume
      M: "j \<noteq> ns ! ?i'" and
      N: "fill xs ?ns' index key ub mi ma ! j = Some x"
    have "?P ?ns'" using J .
    moreover from D and F have "offs_pred ?ns' ub xs index key mi ma"
      using L by (rule_tac offs_pred_cons [OF E], simp)
    moreover have "i < length ?ns'"
      using F by simp
    moreover have "0 < offs_num (length ?ns') xs index key mi ma i"
    proof (rule ccontr, simp)
      assume O: "offs_num (length ns) xs index key mi ma i = 0"
      hence P: "offs_num (length ns) (y # xs) index key mi ma i = Suc 0"
        using G by (simp add: offs_num_cons split: if_split_asm)
      hence "i = ?i'"
        using O by (simp add: offs_num_cons split: if_split_asm)
      hence "ns ! i < j"
        using H and M by simp
      hence "ns ! i + offs_num (length ns) (y # xs) index key mi ma i \<le> j"
        using P by simp
      with F and G and I have "offs_none ns ub (y # xs) index key mi ma j"
        by (simp add: offs_none_def, rule_tac disjI1, rule_tac exI
         [where x = i], simp)
      with B and C and D and E and F have
       "fill (y # xs) ns index key ub mi ma ! j = None"
        by (rule_tac fill_none [OF A], simp_all, erule_tac disjE, simp_all, auto)
      thus False
        using K by (simp add: Let_def)
    qed
    moreover have "?ns' ! i \<le> j"
      using F and H and M by (cases "?i' = i", simp_all)
    moreover have "offs_next ns ub (y # xs) index key mi ma i \<le>
      offs_next ?ns' ub xs index key mi ma i"
      using G and L by (rule_tac offs_pred_next_cons [OF E], simp)
    hence "j < offs_next ?ns' ub xs index key mi ma i"
      using I by simp
    ultimately show ?thesis
      using N by simp
  qed
qed

lemma fill_offs_enum_index [rule_format]:
 "index_less index key \<Longrightarrow>
  \<forall>x \<in> set xs. key x \<in> {mi..ma} \<Longrightarrow>
  i < n \<Longrightarrow>
  0 < offs_num n xs index key mi ma i \<Longrightarrow>
  j \<in> {offs (enum xs index key n mi ma) 0 ! i..<
    offs_next (offs (enum xs index key n mi ma) 0) (length xs)
      xs index key mi ma i} \<Longrightarrow>
  fill xs (offs (enum xs index key n mi ma) 0) index key (length xs)
    mi ma ! j = Some x \<Longrightarrow>
    index key x n mi ma = i"
by (insert fill_index [of index key xs mi ma "offs (enum xs index key n mi ma) 0"
 "length xs" i j x], insert offs_enum_pred [of index key xs mi ma n 0],
 simp add: offs_length enum_length)

lemma fill_sort_inv [rule_format]:
  assumes
    A: "index_less index key" and
    B: "index_mono index key" and
    C: "\<forall>x \<in> set xs. key x \<in> {mi..ma}"
  shows "sort_inv key (u, enum xs index key n mi ma,
    map the (fill xs (offs (enum xs index key n mi ma) 0)
      index key (length xs) mi ma))"
  (is "sort_inv _ (_, ?ns, _)")
proof (simp, (rule allI, rule impI)+, rule ballI, simp add: enum_length fill_length,
 erule conjE)
  fix i j k
  let ?A = "{i. i < n \<and> 0 < ?ns ! i}"
  let ?B = "{i. i < n \<and> offs ?ns 0 ! i \<le> j \<and> 0 < offs_num n xs index key mi ma i}"
  let ?C = "{i. i < n \<and> offs ?ns 0 ! i \<le> k \<and> 0 < offs_num n xs index key mi ma i}"
  assume
    D: "i < n" and
    E: "j < offs ?ns 0 ! i" and
    F: "offs ?ns 0 ! i \<le> k" and
    G: "k < length xs"
  have H: "\<forall>i < length xs.
    \<exists>x. fill xs (offs ?ns 0) index key (length xs) mi ma ! i = Some x"
  proof (rule allI, rule impI, rule ccontr, simp)
    fix m
    assume "fill xs (offs ?ns 0) index key (length xs) mi ma ! m = None"
    moreover assume "m < length xs"
    hence "fill xs (offs ?ns 0) index key (length xs) mi ma ! m
      \<in> set (fill xs (offs ?ns 0) index key (length xs) mi ma)"
      by (rule_tac nth_mem, simp add: fill_length)
    ultimately have "None \<in> set (fill xs (offs ?ns 0) index key (length xs) mi ma)"
      by simp
    moreover have
     "count (mset (fill xs (offs ?ns 0) index key (length xs) mi ma)) None = 0"
      using C and D by (rule_tac fill_offs_enum_count_none [OF A], simp_all)
    ultimately show False by simp
  qed
  have "\<exists>y ys. xs = y # ys"
    using G by (rule_tac list.exhaust [of xs], simp_all)
  then obtain z and zs where I: "xs = z # zs" by blast
  hence "index key z n mi ma < n"
    using A and C and D by (simp add: index_less_def)
  moreover from this have "0 < ?ns ! index key z n mi ma"
    using I by (simp add: Let_def, subst nth_list_update_eq, simp_all add:
     enum_length)
  ultimately have "index key z n mi ma \<in> ?A" by simp
  hence J: "Min ?A \<in> ?A"
    by (rule_tac Min_in, simp, blast)
  hence "offs ?ns 0 ! 0 = offs ?ns 0 ! Min ?A"
  proof (cases "Min ?A = 0", simp_all, erule_tac offs_equal, simp_all add:
   enum_length, rule_tac ccontr, erule_tac conjE, simp)
    fix m
    assume "m < Min ?A" and "Min ?A < n" and "0 < ?ns ! m"
    moreover from this have "Min ?A \<le> m"
      by (rule_tac Min_le, simp_all)
    ultimately show False by simp
  qed
  moreover have "\<exists>m ms. ?ns = m # ms"
    using D by (rule_tac list.exhaust [of ?ns], simp_all,
     simp only: length_0_conv [symmetric] enum_length)
  then obtain m and ms where "?ns = m # ms" by blast
  ultimately have "offs ?ns 0 ! Min ?A = 0" by simp
  hence "Min ?A \<in> ?B"
    using J by (simp, subst enum_offs_num [symmetric], simp_all)
  hence K: "Max ?B \<in> ?B"
    by (rule_tac Max_in, simp, blast)
  moreover have "j < offs_next (offs ?ns 0) (length xs)
    xs index key mi ma (Max ?B)"
  proof (simp only: offs_next_def split: if_split, rule conjI, rule_tac [!] impI,
   rule_tac [2] ccontr, simp_all only: not_less)
    show "j < length xs"
      using E and F and G by simp
  next
    assume "offs_set_next (offs ?ns 0) xs index key mi ma (Max ?B) \<noteq> {}"
      (is "?Z \<noteq> _")
    hence L: "Min ?Z \<in> ?Z"
      by (rule_tac Min_in, simp)
    moreover assume "offs ?ns 0 ! Min ?Z \<le> j"
    ultimately have "Min ?Z \<in> ?B"
      by (simp add: offs_length enum_length)
    hence "Min ?Z \<le> Max ?B"
      by (rule_tac Max_ge, simp)
    thus False
      using L by simp
  qed
  moreover have
   "\<exists>x. fill xs (offs ?ns 0) index key (length xs) mi ma ! j = Some x"
    using E and F and G and H by simp
  then obtain x where
    L: "fill xs (offs ?ns 0) index key (length xs) mi ma ! j = Some x" ..
  ultimately have M: "index key x n mi ma = Max ?B"
    using C by (rule_tac fill_offs_enum_index [OF A], simp_all)
  have N: "Max ?B \<in> ?C"
    using E and F and K by simp
  hence "Max ?C \<in> ?C"
    by (rule_tac Max_in, simp, blast)
  moreover have O: "k < offs_next (offs ?ns 0) (length xs)
    xs index key mi ma (Max ?C)"
  proof (simp only: offs_next_def split: if_split, rule conjI, rule_tac [!] impI,
   rule_tac [2] ccontr, simp_all only: not_less)
    show "k < length xs" using G .
  next
    assume "offs_set_next (offs ?ns 0) xs index key mi ma (Max ?C) \<noteq> {}"
      (is "?Z \<noteq> _")
    hence P: "Min ?Z \<in> ?Z"
      by (rule_tac Min_in, simp)
    moreover assume "offs ?ns 0 ! Min ?Z \<le> k"
    ultimately have "Min ?Z \<in> ?C"
      by (simp add: offs_length enum_length)
    hence "Min ?Z \<le> Max ?C"
      by (rule_tac Max_ge, simp)
    thus False
      using P by simp
  qed
  moreover have
   "\<exists>x. fill xs (offs ?ns 0) index key (length xs) mi ma ! k = Some x"
    using G and H by simp
  then obtain y where
    P: "fill xs (offs ?ns 0) index key (length xs) mi ma ! k = Some y" ..
  ultimately have Q: "index key y n mi ma = Max ?C"
    using C by (rule_tac fill_offs_enum_index [OF A], simp_all)
  have "Max ?B \<le> Max ?C"
    using N by (rule_tac Max_ge, simp)
  hence "Max ?B < Max ?C"
  proof (rule_tac ccontr, simp)
    assume "Max ?B = Max ?C"
    hence "offs ?ns 0 ! i < offs_next (offs ?ns 0) (length xs)
      xs index key mi ma (Max ?B)"
      using F and O by simp
    moreover have "offs ?ns 0 ! Max ?B < offs ?ns 0 ! i"
      using E and K by simp
    with K have "Max ?B < i"
      by (erule_tac contrapos_pp, subst not_less, subst (asm) not_less,
       erule_tac offs_mono, simp add: enum_length)
    hence "offs_next (offs ?ns 0) (length xs + 0) xs index key mi ma (Max ?B) \<le>
      offs ?ns 0 ! i"
      using C and D by (rule_tac offs_enum_next_le [OF A], simp_all)
    ultimately show False by simp
  qed
  hence R: "index key x n mi ma < index key y n mi ma"
    using M and Q by simp
  have "count (mset (map the (fill xs (offs ?ns 0) index key
    (length xs) mi ma))) x = count (mset xs) x"
    using C and D by (rule_tac fill_offs_enum_count_item [OF A], simp_all)
  moreover have S: "j < length (map the (fill xs (offs ?ns 0) index key
    (length xs) mi ma))"
    using E and F and G by (simp add: fill_length)
  hence "map the (fill xs (offs ?ns 0) index key (length xs) mi ma) ! j
    \<in> set (map the (fill xs (offs ?ns 0) index key (length xs) mi ma))"
    by (rule nth_mem)
  hence "0 < count (mset (map the (fill xs (offs ?ns 0) index key
    (length xs) mi ma))) x"
    using L and S by simp
  ultimately have T: "x \<in> set xs" by simp
  have "count (mset (map the (fill xs (offs ?ns 0) index key
    (length xs) mi ma))) y = count (mset xs) y"
    using C and D by (rule_tac fill_offs_enum_count_item [OF A], simp_all)
  moreover have U: "k < length (map the (fill xs (offs ?ns 0) index key
    (length xs) mi ma))"
    using G by (simp add: fill_length)
  hence "map the (fill xs (offs ?ns 0) index key (length xs) mi ma) ! k
    \<in> set (map the (fill xs (offs ?ns 0) index key (length xs) mi ma))"
    by (rule nth_mem)
  hence "0 < count (mset (map the (fill xs (offs ?ns 0) index key
    (length xs) mi ma))) y"
    using P and U by simp
  ultimately have V: "y \<in> set xs" by simp
  have "key y \<le> key x \<longrightarrow> index key y n mi ma \<le> index key x n mi ma"
    using B and C and T and V by (simp add: index_mono_def)
  hence "key x < key y"
    by (rule_tac contrapos_pp [OF R], simp add: not_less)
  thus "key (the (fill xs (offs ?ns 0) index key (length xs) mi ma ! j)) \<le>
    key (the (fill xs (offs ?ns 0) index key (length xs) mi ma ! k))"
    using L and P by simp
qed

lemma round_sort_inv [rule_format]:
 "index_less index key \<longrightarrow> index_mono index key \<longrightarrow> bn_inv p q t \<longrightarrow>
    add_inv n t \<longrightarrow> sort_inv key t \<longrightarrow> sort_inv key (round index key p q r t)"
proof (induction index key p q r t arbitrary: n rule: round.induct,
 (rule_tac [!] impI)+, simp, simp_all only: simp_thms)
  fix index p q r u ns xs n and key :: "'a \<Rightarrow> 'b"
  let ?t = "round index key p q r (u, ns, xs)"
  assume "\<And>n. bn_inv p q (u, ns, xs) \<longrightarrow> add_inv n (u, ns, xs) \<longrightarrow>
    sort_inv key (u, ns, xs) \<longrightarrow> sort_inv key ?t"
  hence "bn_inv p q (u, ns, xs) \<longrightarrow> add_inv n (u, ns, xs) \<longrightarrow>
    sort_inv key (u, ns, xs) \<longrightarrow> sort_inv key ?t" .
  moreover assume
   "bn_inv p q (u, 0 # ns, xs)"
   "add_inv n (u, 0 # ns, xs)" and
   "sort_inv key (u, 0 # ns, xs)"
  ultimately show "sort_inv key (round index key p q r (u, 0 # ns, xs))"
    by auto
next
  fix index p q r u ns xs n and key :: "'a \<Rightarrow> 'b"
  let ?t = "round index key p q r (u, ns, tl xs)"
  assume
    A: "index_less index key" and
    B: "bn_inv p q (u, Suc 0 # ns, xs)"
  moreover assume
   "\<And>n. bn_inv p q (u, ns, tl xs) \<longrightarrow> add_inv n (u, ns, tl xs) \<longrightarrow>
      sort_inv key (u, ns, tl xs) \<longrightarrow> sort_inv key ?t" and
   "add_inv n (u, Suc 0 # ns, xs)" and
   "sort_inv key (u, Suc 0 # ns, xs)"
  ultimately show "sort_inv key (round index key p q r (u, Suc 0 # ns, xs))"
  proof (cases ?t, cases xs, simp_all add: add_suc, (rule_tac allI, rule_tac impI)+,
   rule_tac ballI, simp, (erule_tac conjE)+, simp)
    fix i j k y ys u' ns' xs'
    assume
      C: "round index key p q r (u, ns, ys) = (u', ns', xs')" and
      D: "Suc (foldl (+) 0 ns) = n" and
      E: "Suc (length ys) = n" and
      F: "\<forall>i < Suc (length ns).
        \<forall>j < (0 # offs ns (Suc 0)) ! i. \<forall>k \<in> {(0 # offs ns (Suc 0)) ! i..<n}.
          key ((y # ys) ! j) \<le> key (ys ! (k - Suc 0))"
    assume A': "j < (0 # offs ns' (Suc 0)) ! i"
    hence "\<exists>i'. i = Suc i'"
      by (rule_tac nat.exhaust [of i], simp_all)
    then obtain i' where B': "i = Suc i'" ..
    assume "i < Suc (length ns')"
    hence G: "i' < length ns'"
      using B' by simp
    hence H: "j < Suc (offs ns' 0 ! i')"
      using A' and B' by (simp add: offs_suc)
    assume "(0 # offs ns' (Suc 0)) ! i \<le> k"
    hence "Suc (offs ns' 0 ! i') \<le> k"
      using B' and G by (simp add: offs_suc)
    moreover from this have "\<exists>k'. k = Suc k'"
      by (rule_tac nat.exhaust [of k], simp_all)
    then obtain k' where I: "k = Suc k'" ..
    ultimately have J: "offs ns' 0 ! i' \<le> k'" by simp
    assume "k < Suc (length xs')"
    hence K: "k' < length xs'"
      using I by simp
    let ?P = "\<lambda>n. foldl (+) 0 ns = n \<and> length ys = n"
    let ?Q = "\<lambda>n. \<forall>i < length ns.
      \<forall>j < offs ns 0 ! i. \<forall>k \<in> {offs ns 0 ! i..<n}.
        key (ys ! j) \<le> key (ys ! k)"
    let ?R = "\<forall>i < length ns'.
      \<forall>j < offs ns' 0 ! i. \<forall>k \<in> {offs ns' 0 ! i..<length xs'}.
        key (xs' ! j) \<le> key (xs' ! k)"
    assume "\<And>n. ?P n \<longrightarrow> ?Q n \<longrightarrow> ?R"
    hence "?P (n - Suc 0) \<longrightarrow> ?Q (n - Suc 0) \<longrightarrow> ?R" .
    hence "?Q (n - Suc 0) \<longrightarrow> ?R"
      using D and E by auto
    moreover have "?Q (n - Suc 0)"
    proof ((rule allI, rule impI)+, rule ballI, simp, erule conjE)
      fix i j k
      have "Suc i < Suc (length ns) \<longrightarrow> (\<forall>j < (0 # offs ns (Suc 0)) ! Suc i.
        \<forall>k \<in> {(0 # offs ns (Suc 0)) ! Suc i..<n}.
          key ((y # ys) ! j) \<le> key (ys ! (k - Suc 0)))"
        using F ..
      moreover assume "i < length ns"
      ultimately have "Suc j < Suc (offs ns 0 ! i) \<longrightarrow>
        (\<forall>k \<in> {Suc (offs ns 0 ! i)..<n}.
          key ((y # ys) ! Suc j) \<le> key (ys ! (k - Suc 0)))"
        by (auto simp add: offs_suc)
      moreover assume "j < offs ns 0 ! i"
      ultimately have "\<forall>k \<in> {Suc (offs ns 0 ! i)..<n}.
        key (ys ! j) \<le> key (ys ! (k - Suc 0))"
        by simp
      moreover assume "offs ns 0 ! i \<le> k" and "k < n - Suc 0"
      hence "Suc k \<in> {Suc (offs ns 0 ! i)..<n}" by simp
      ultimately have "key (ys ! j) \<le> key (ys ! (Suc k - Suc 0))" ..
      thus "key (ys ! j) \<le> key (ys ! k)" by simp
    qed
    ultimately have ?R ..
    from I show "key ((y # xs') ! j) \<le> key (xs' ! (k - Suc 0))"
    proof (cases j, simp_all)
      have "bn_inv p q (u, ns, ys)"
        using B by simp
      moreover have "add_inv (n - Suc 0) (u, ns, ys)"
        using D and E by auto
      moreover have "count_inv (\<lambda>x. count (mset ys) x) (u, ns, ys)" by simp
      ultimately have "count_inv (\<lambda>x. count (mset ys) x)
        (round index key p q r (u, ns, ys))"
        by (rule round_count_inv [OF A])
      hence "count (mset xs') (xs' ! k') = count (mset ys) (xs' ! k')"
        using C by simp
      moreover have "0 < count (mset xs') (xs' ! k')"
        using K by simp
      ultimately have "xs' ! k' \<in> set ys" by simp
      hence "\<exists>m < length ys. ys ! m = xs' ! k'"
        by (simp add: in_set_conv_nth)
      then obtain m where L: "m < length ys \<and> ys ! m = xs' ! k'" ..
      have "Suc 0 < Suc (length ns) \<longrightarrow> (\<forall>j < (0 # offs ns (Suc 0)) ! Suc 0.
        \<forall>k \<in> {(0 # offs ns (Suc 0)) ! Suc 0..<n}.
          key ((y # ys) ! j) \<le> key (ys ! (k - Suc 0)))"
        using F ..
      moreover have M: "0 < length ns"
        using D [symmetric] and E and L by (rule_tac ccontr, simp)
      ultimately have "\<forall>k \<in> {Suc (offs ns 0 ! 0)..<n}.
        key y \<le> key (ys ! (k - Suc 0))"
        by (auto simp add: offs_suc)
      hence "\<forall>k \<in> {Suc 0..<n}. key y \<le> key (ys ! (k - Suc 0))"
        using M by (cases ns, simp_all)
      moreover have "Suc m \<in> {Suc 0..<n}"
        using E and L by simp
      ultimately have "key y \<le> key (ys ! (Suc m - Suc 0))" ..
      thus "key y \<le> key (xs' ! k')"
        using L by simp
    next
      case (Suc j')
      moreover have "i' < length ns' \<longrightarrow> (\<forall>j < offs ns' 0 ! i'.
        \<forall>k \<in> {offs ns' 0 ! i'..<length xs'}. key (xs' ! j) \<le> key (xs' ! k))"
        using `?R` ..
      hence "j' < offs ns' 0 ! i' \<longrightarrow>
        (\<forall>k \<in> {offs ns' 0 ! i'..<length xs'}. key (xs' ! j') \<le> key (xs' ! k))"
        using G by simp
      ultimately have "\<forall>k \<in> {offs ns' 0 ! i'..<length xs'}.
        key (xs' ! j') \<le> key (xs' ! k)"
        using H by simp
      moreover have "k' \<in> {offs ns' 0 ! i'..<length xs'}"
        using J and K by simp
      ultimately show "key (xs' ! j') \<le> key (xs' ! k')" ..
    qed
  qed
next
  fix index p q r u m ns n and key :: "'a \<Rightarrow> 'b" and xs :: "'a list"
  let ?ws = "take (Suc (Suc m)) xs"
  let ?ys = "drop (Suc (Suc m)) xs"
  let ?r = "\<lambda>m'. round_suc_suc index key ?ws m m' u"
  let ?t = "\<lambda>r' v. round index key p q r' (v, ns, ?ys)"
  assume
    A: "index_less index key" and
    B: "index_mono index key" and
    C: "bn_inv p q (u, Suc (Suc m) # ns, xs)"
  assume
   "\<And>ws a b c d e f g h n.
      ws = ?ws \<Longrightarrow> a = bn_comp m p q r \<Longrightarrow> (b, c) = bn_comp m p q r \<Longrightarrow>
      d = ?r b \<Longrightarrow> (e, f) = ?r b \<Longrightarrow> (g, h) = f \<Longrightarrow>
        bn_inv p q (e, ns, ?ys) \<longrightarrow> add_inv n (e, ns, ?ys) \<longrightarrow>
          sort_inv key (e, ns, ?ys) \<longrightarrow> sort_inv key (?t c e)" and
   "add_inv n (u, Suc (Suc m) # ns, xs)" and
   "sort_inv key (u, Suc (Suc m) # ns, xs)"
  with C show "sort_inv key (round index key p q r (u, Suc (Suc m) # ns, xs))"
  proof (simp split: prod.split, ((rule_tac allI)+, (rule_tac impI)+)+,
   rule_tac ballI, simp, (erule_tac conjE)+, subst (asm) (2) add_base_zero, simp)
    fix m' r' v ms' ws' u' ns' xs' i j k
    let ?nmi = "mini ?ws key"
    let ?nma = "maxi ?ws key"
    let ?xmi = "?ws ! ?nmi"
    let ?xma = "?ws ! ?nma"
    let ?mi = "key ?xmi"
    let ?ma = "key ?xma"
    let ?k = "case m of 0 \<Rightarrow> m | Suc 0 \<Rightarrow> m | Suc (Suc i) \<Rightarrow> u + m'"
    let ?zs = "nths ?ws (- {?nmi, ?nma})"
    let ?ms = "enum ?zs index key ?k ?mi ?ma"
    let ?P = "\<lambda>n'. foldl (+) 0 ns = n' \<and> n - Suc (Suc m) = n'"
    let ?Q = "\<lambda>n'. \<forall>i < length ns.
      \<forall>j < offs ns 0 ! i. \<forall>k \<in> {offs ns 0 ! i..<n'}.
        key (xs ! Suc (Suc (m + j))) \<le> key (xs ! Suc (Suc (m + k)))"
    let ?R = "\<forall>i < length ns'.
      \<forall>j < offs ns' 0 ! i. \<forall>k \<in> {offs ns' 0 ! i..<length xs'}.
        key (xs' ! j) \<le> key (xs' ! k)"
    assume
      D: "?r m' = (v, ms', ws')" and
      E: "?t r' v = (u', ns', xs')" and
      F: "bn_comp m p q r = (m', r')" and
      G: "bn_valid m p q" and
      H: "Suc (Suc (foldl (+) 0 ns + m)) = n" and
      I: "length xs = n" and
      J: "\<forall>i < Suc (length ns). \<forall>j < (0 # offs ns (Suc (Suc m))) ! i.
        \<forall>k \<in> {(0 # offs ns (Suc (Suc m))) ! i..<n}.
          key (xs ! j) \<le> key (xs ! k)" and
      K: "i < length ms' + length ns'" and
      L: "j < offs (ms' @ ns') 0 ! i" and
      M: "offs (ms' @ ns') 0 ! i \<le> k" and
      N: "k < length ws' + length xs'"
    have O: "length ?ws = Suc (Suc m)"
      using H and I by simp
    with D [symmetric] have P: "length ws' = Suc (Suc m)"
      by (simp add: round_suc_suc_def Let_def fill_length split: if_split_asm)
    have Q: "\<And>i. i < m \<Longrightarrow>
      the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! i) \<in> set ?ws"
    proof -
      fix i
      let ?x = "the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! i)"
      assume R: "i < m"
      hence "0 < m" by simp
      hence "0 < ?k"
        by (drule_tac bn_comp_fst_nonzero [OF G], subst (asm) F,
         simp split: nat.split)
      hence "count (mset (map the (fill ?zs (offs ?ms 0)
        index key (length ?zs) ?mi ?ma))) ?x = count (mset ?zs) ?x"
        by (rule_tac fill_offs_enum_count_item [OF A], simp, rule_tac conjI,
         ((rule_tac mini_lb | rule_tac maxi_ub), erule_tac in_set_nthsD)+)
      hence "count (mset (map the (fill ?zs (offs ?ms 0)
        index key m ?mi ?ma))) ?x = count (mset ?zs) ?x"
        using O by (simp add: mini_maxi_nths)
      moreover have "0 < count (mset (map the (fill ?zs (offs ?ms 0)
        index key m ?mi ?ma))) ?x"
        using R by (simp add: fill_length)
      ultimately have "?x \<in> set ?zs" by simp
      thus "?x \<in> set ?ws"
        by (rule in_set_nthsD)
    qed
    have R: "\<And>i. i < Suc (Suc m) \<Longrightarrow> Suc (Suc m) \<le> k \<Longrightarrow>
      key (?ws ! i) \<le> key (xs' ! (k - Suc (Suc m)))"
    proof -
      fix i
      have "bn_inv p q (v, ns, ?ys)"
        using C by simp
      moreover have "add_inv (n - Suc (Suc m)) (v, ns, ?ys)"
        using H and I by simp
      moreover have "count_inv (\<lambda>x. count (mset ?ys) x) (v, ns, ?ys)"
        by simp
      ultimately have "count_inv (\<lambda>x. count (mset ?ys) x) (?t r' v)"
        by (rule round_count_inv [OF A])
      hence S: "count (mset xs') (xs' ! (k - Suc (Suc m))) =
        count (mset ?ys) (xs' ! (k - Suc (Suc m)))"
        using E by simp
      have "k < Suc (Suc (m + length xs'))"
        using N and P by simp
      moreover assume "Suc (Suc m) \<le> k"
      ultimately have "0 < count (mset xs') (xs' ! (k - Suc (Suc m)))"
        by simp
      hence "xs' ! (k - Suc (Suc m)) \<in> set ?ys"
        using S by simp
      hence "\<exists>p < length ?ys. ?ys ! p = xs' ! (k - Suc (Suc m))"
        by (simp add: in_set_conv_nth)
      then obtain p where
        T: "p < length ?ys \<and> ?ys ! p = xs' ! (k - Suc (Suc m))" ..
      have "Suc 0 < Suc (length ns) \<longrightarrow>
        (\<forall>j < (0 # offs ns (Suc (Suc m))) ! Suc 0.
         \<forall>k \<in> {(0 # offs ns (Suc (Suc m))) ! Suc 0..<n}.
           key (xs ! j) \<le> key (xs ! k))"
        using J ..
      moreover have U: "0 < length ns"
        using H [symmetric] and I and T by (rule_tac ccontr, simp)
      ultimately have "\<forall>j < offs ns (Suc (Suc m)) ! 0.
        \<forall>k \<in> {offs ns (Suc (Suc m)) ! 0..<n}. key (xs ! j) \<le> key (xs ! k)"
        by simp
      moreover assume "i < Suc (Suc m)"
      moreover have "offs ns (Suc (Suc m)) ! 0 = Suc (Suc m)"
        using U by (subst offs_base_zero, simp, cases ns, simp_all)
      ultimately have "\<forall>k \<in> {Suc (Suc m)..<n}. key (?ws ! i) \<le> key (xs ! k)"
        by simp
      moreover have "Suc (Suc m) + p \<in> {Suc (Suc m)..<n}"
        using I and T by (simp, arith)
      ultimately have "key (?ws ! i) \<le> key (xs ! (Suc (Suc m) + p))" ..
      thus "key (?ws ! i) \<le> key (xs' ! (k - Suc (Suc m)))"
        using O and T by simp
    qed
    assume "\<And>ws a b c d e f g h n'.
      ws = ?ws \<Longrightarrow> a = (m', r') \<Longrightarrow> b = m' \<and> c = r' \<Longrightarrow>
      d = (v, ms', ws') \<Longrightarrow> e = v \<and> f = (ms', ws') \<Longrightarrow> g = ms' \<and> h = ws' \<Longrightarrow>
        ?P n' \<longrightarrow> ?Q n' \<longrightarrow> ?R"
    hence "?P (n - Suc (Suc m)) \<longrightarrow> ?Q (n - Suc (Suc m)) \<longrightarrow> ?R"
      by simp
    hence "?Q (n - Suc (Suc m)) \<longrightarrow> ?R"
      using H by simp
    moreover have "?Q (n - Suc (Suc m))"
    proof ((rule allI, rule impI)+, rule ballI, simp, erule conjE,
     subst (1 2) append_take_drop_id [of "Suc (Suc m)", symmetric],
     simp only: nth_append O, simp)
      fix i j k
      have "Suc i < Suc (length ns) \<longrightarrow>
        (\<forall>j < (0 # offs ns (Suc (Suc m))) ! Suc i.
         \<forall>k \<in> {(0 # offs ns (Suc (Suc m))) ! Suc i..<n}.
           key ((xs) ! j) \<le> key (xs ! k))"
        using J ..
      moreover assume "i < length ns"
      ultimately have "j < offs ns 0 ! i \<longrightarrow>
        (\<forall>k \<in> {offs ns 0 ! i + Suc (Suc m)..<n}.
          key (xs ! (Suc (Suc m) + j)) \<le> key (xs ! k))"
        by (simp, subst (asm) offs_base_zero, simp,
         subst (asm) (2) offs_base_zero, simp_all)
      moreover assume "j < offs ns 0 ! i"
      ultimately have "\<forall>k \<in> {offs ns 0 ! i + Suc (Suc m)..<n}.
        key (?ys ! j) \<le> key (xs ! k)"
        using O by simp
      moreover assume "offs ns 0 ! i \<le> k" and "k < n - Suc (Suc m)"
      hence "Suc (Suc m) + k \<in> {offs ns 0 ! i + Suc (Suc m)..<n}"
        by simp
      ultimately have "key (?ys ! j) \<le> key (xs ! (Suc (Suc m) + k))" ..
      thus "key (?ys ! j) \<le> key (?ys ! k)"
        using O by simp
    qed
    ultimately have ?R ..
    show "key ((ws' @ xs') ! j) \<le> key ((ws' @ xs') ! k)"
    proof (simp add: nth_append not_less P, (rule_tac [!] conjI,
     rule_tac [!] impI)+, rule_tac [3] FalseE)
      assume
        S: "j < Suc (Suc m)" and
        T: "k < Suc (Suc m)"
      from D [symmetric] show "key (ws' ! j) \<le> key (ws' ! k)"
      proof (simp add: round_suc_suc_def Let_def split: if_split_asm,
       (erule_tac [2] conjE)+, simp_all)
        assume U: "?mi = ?ma"
        have "j < length ?ws"
          using S and O by simp
        hence "?ws ! j \<in> set ?ws"
          by (rule nth_mem)
        with U have "key (?ws ! j) = ?ma"
          by (rule mini_maxi_keys_eq)
        moreover have "k < length ?ws"
          using T and O by simp
        hence "?ws ! k \<in> set ?ws"
          by (rule nth_mem)
        with U have "key (?ws ! k) = ?ma"
          by (rule mini_maxi_keys_eq)
        ultimately show "key (?ws ! j) \<le> key (?ws ! k)" by simp
      next
        assume U: "ms' = Suc 0 # ?ms @ [Suc 0]"
        hence V: "j < (0 # offs (?ms @ Suc 0 # ns') (Suc 0)) ! i"
          using L by simp
        hence "\<exists>i'. i = Suc i'"
          by (rule_tac nat.exhaust [of i], simp_all)
        then obtain i' where W: "i = Suc i'" ..
        have "i < Suc (Suc (?k + length ns'))"
          using K and U by (simp add: enum_length)
        hence X: "i' < Suc (?k + length ns')"
          using W by simp
        hence Y: "j < Suc (offs (?ms @ Suc 0 # ns') 0 ! i')"
          using V and W by (simp add: enum_length offs_suc)
        have "(0 # offs (?ms @ Suc 0 # ns') (Suc 0)) ! i \<le> k"
          using M and U by simp
        hence "Suc (offs (?ms @ Suc 0 # ns') 0 ! i') \<le> k"
          using W and X by (simp add: enum_length offs_suc)
        moreover from this have "\<exists>k'. k = Suc k'"
          by (rule_tac nat.exhaust [of k], simp_all)
        then obtain k' where Z: "k = Suc k'" ..
        ultimately have AA: "offs (?ms @ Suc 0 # ns') 0 ! i' \<le> k'"
          by simp
        have AB: "j \<le> k'"
          using Y and AA by simp
        with Z show
         "key ((?xmi # map the (fill ?zs (offs ?ms 0) index key m ?mi ?ma) @
            [?xma]) ! j) \<le>
          key ((?xmi # map the (fill ?zs (offs ?ms 0) index key m ?mi ?ma) @
            [?xma]) ! k)"
        proof (cases j, case_tac [2] "j < Suc m", simp_all add: nth_append
         not_less fill_length, rule_tac [1-2] conjI, rule_tac [1-4] impI,
         rule_tac [5] FalseE, simp_all)
          assume "k' < m"
          hence "the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! k') \<in> set ?ws"
            by (rule Q)
          thus "?mi \<le> key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! k'))"
            by (rule mini_lb)
        next
          assume "m \<le> k'"
          hence "k' = m"
            using T and Z by simp
          thus "?mi \<le> key ([?xma] ! (k' - m))"
            by (simp, rule_tac mini_maxi_keys_le, rule_tac nth_mem [of 0],
             subst O, simp)
        next
          fix j'
          have "sort_inv key (0, ?ms, map the (fill ?zs (offs ?ms 0) index key
            (length ?zs) ?mi ?ma))"
            by (rule fill_sort_inv [OF A B], simp, rule conjI,
             ((rule mini_lb | rule maxi_ub), erule in_set_nthsD)+)
          hence "sort_inv key (0, ?ms, map the (fill ?zs (offs ?ms 0) index key
            m ?mi ?ma))"
            using O by (simp add: mini_maxi_nths)
          hence "\<forall>i < ?k. \<forall>j < offs ?ms 0 ! i. \<forall>k \<in> {offs ?ms 0 ! i..<m}.
            key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j)) \<le>
            key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! k))"
            by (simp add: enum_length fill_length)
          moreover assume AC: "k' < m"
          hence AD: "offs (?ms @ Suc 0 # ns') 0 ! i' < m"
            using AA by simp
          have AE: "i' < ?k"
          proof (rule contrapos_pp [OF AD], simp add: not_less offs_append
           nth_append offs_length enum_length)
            have "0 < m"
              using AC by simp
            hence "0 < ?k"
              by (drule_tac bn_comp_fst_nonzero [OF G], subst (asm) F,
               simp split: nat.split)
            with A have "foldl (+) 0 ?ms = length ?zs"
              by (rule enum_add, simp, rule_tac conjI,
               ((rule_tac mini_lb | rule_tac maxi_ub), erule_tac in_set_nthsD)+)
            hence "foldl (+) 0 ?ms = m"
              using O by (simp add: mini_maxi_nths)
            with X show "m \<le> (foldl (+) 0 ?ms #
              offs ns' (Suc (foldl (+) 0 ?ms))) ! (i' - ?k)"
              by (cases "i' - ?k", simp_all, subst offs_base_zero, simp_all)
          qed
          ultimately have "\<forall>j < offs ?ms 0 ! i'. \<forall>k \<in> {offs ?ms 0 ! i'..<m}.
            key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j)) \<le>
            key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! k))"
            by simp
          moreover assume "j = Suc j'"
          with Y and AE have "j' < offs ?ms 0 ! i'"
            by (simp add: offs_append nth_append offs_length enum_length)
          ultimately have "\<forall>k \<in> {offs ?ms 0 ! i'..<m}.
            key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j')) \<le>
            key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! k))"
            by simp
          moreover from AA and AE have "offs ?ms 0 ! i' \<le> k'"
            by (simp add: offs_append nth_append offs_length enum_length)
          hence "k' \<in> {offs ?ms 0 ! i'..<m}"
            using AC by simp
          ultimately show
           "key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j')) \<le>
            key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! k'))" ..
        next
          fix j'
          assume "j' < m"
          hence "the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j') \<in> set ?ws"
            (is "?x \<in> _")
            by (rule Q)
          moreover assume "m \<le> k'"
          hence "k' = m"
            using T and Z by simp
          ultimately show "key ?x \<le> key ([?xma] ! (k' - m))"
            by (simp, rule_tac maxi_ub)
        next
          fix j'
          assume "j = Suc j'" and "m \<le> j'"
          hence "Suc m \<le> j" by simp
          hence "Suc (Suc m) \<le> k"
            using Z and AB by simp
          thus False
            using T by simp
        qed
      qed
    next
      assume
        S: "j < Suc (Suc m)" and
        T: "Suc (Suc m) \<le> k"
      from D [symmetric] show "key (ws' ! j) \<le> key (xs' ! (k - Suc (Suc m)))"
      proof (simp add: round_suc_suc_def Let_def split: if_split_asm,
       rule_tac R [OF S T], cases j, case_tac [2] "j < Suc m",
       simp_all add: nth_append not_less fill_length)
        have "?nmi < length ?ws"
          using O by (rule_tac mini_less, simp)
        hence "?nmi < Suc (Suc m)"
          using O by simp
        thus "?mi \<le> key (xs' ! (k - Suc (Suc m)))"
          using T by (rule R)
      next
        fix j'
        assume "j' < m"
        hence U: "the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j') \<in> set ?ws"
          by (rule Q)
        have "\<exists>p < Suc (Suc m). ?ws ! p =
          the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j')"
          using O and U by (simp add: in_set_conv_nth)
        then obtain p where V: "p < Suc (Suc m) \<and> ?ws ! p =
          the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j')" ..
        hence "key (?ws ! p) \<le> key (xs' ! (k - Suc (Suc m)))"
          using T by (rule_tac R, simp)
        thus "key (the (fill ?zs (offs ?ms 0) index key m ?mi ?ma ! j')) \<le>
          key (xs' ! (k - Suc (Suc m)))"
          using V by simp
      next
        fix j'
        assume "j = Suc j'" and "m \<le> j'"
        moreover from this have "Suc m \<le> j" by simp
        hence "j = Suc m"
          using S by simp
        ultimately have "j' = m" by simp
        thus "key ([?xma] ! (j' - m)) \<le> key (xs' ! (k - Suc (Suc m)))"
        proof simp
          have "?nma < length ?ws"
            using O by (rule_tac maxi_less, simp)
          hence "?nma < Suc (Suc m)"
            using O by simp
          thus "?ma \<le> key (xs' ! (k - Suc (Suc m)))"
            using T by (rule R)
        qed
      qed
    next
      assume "k < Suc (Suc m)" and "Suc (Suc m) \<le> j"
      hence "k < j" by simp
      moreover have "j < k"
        using L and M by simp
      ultimately show False by simp
    next
      assume
        S: "Suc (Suc m) \<le> j" and
        T: "Suc (Suc m) \<le> k"
      have U: "0 < length ns' \<and> 0 < length xs'"
      proof (rule ccontr, simp, erule disjE)
        have "bn_inv p q (v, ns, ?ys)"
          using C by simp
        moreover have "add_inv (n - Suc (Suc m)) (v, ns, ?ys)"
          using H and I by simp
        ultimately have "add_inv (n - Suc (Suc m)) (?t r' v)"
          by (rule round_add_inv [OF A])
        hence "length xs' = foldl (+) 0 ns'"
          using E by simp
        moreover assume "ns' = []"
        ultimately have "length xs' = 0" by simp
        hence "k < Suc (Suc m)"
          using N and P by simp
        thus False
          using T by simp
      next
        assume "xs' = []"
        hence "k < Suc (Suc m)"
          using N and P by simp
        thus False
          using T by simp
      qed
      hence V: "i - length ms' < length ns'"
        using K by arith
      hence W: "\<forall>j < offs ns' 0 ! (i - length ms').
        \<forall>k \<in> {offs ns' 0 ! (i - length ms')..<length xs'}.
          key (xs' ! j) \<le> key (xs' ! k)"
        using `?R` by simp
      from D [symmetric] have X: "foldl (+) 0 ms' = Suc (Suc m)"
      proof (simp add: round_suc_suc_def Let_def add_replicate add_suc
       split: if_split_asm, cases "m = 0")
        case True
        hence "?k = 0" by simp
        hence "length ?ms = 0"
          by (simp add: enum_length)
        thus "foldl (+) 0 ?ms = m"
          using True by simp
      next
        case False
        hence "0 < ?k"
          by (simp, drule_tac bn_comp_fst_nonzero [OF G], subst (asm) F,
           simp split: nat.split)
        with A have "foldl (+) 0 ?ms = length ?zs"
          by (rule enum_add, simp, rule_tac conjI,
           ((rule_tac mini_lb | rule_tac maxi_ub), erule_tac in_set_nthsD)+)
        thus "foldl (+) 0 ?ms = m"
          using O by (simp add: mini_maxi_nths)
      qed
      have "length ms' < i"
      proof (rule ccontr, simp add: not_less)
        assume "i \<le> length ms'"
        moreover have "length ms' < length (ms' @ ns')"
          using U by simp
        ultimately have "offs (ms' @ ns') 0 ! i \<le>
          offs (ms' @ ns') 0 ! (length ms')"
          by (rule offs_mono)
        also have "\<dots> = Suc (Suc m)"
          using U and X by (simp add: offs_append nth_append offs_length,
           cases ns', simp_all)
        finally have "offs (ms' @ ns') 0 ! i \<le> Suc (Suc m)" .
        hence "j < Suc (Suc m)"
          using L by simp
        thus False
          using S by simp
      qed
      hence Y: "offs (ms' @ ns') 0 ! i =
        Suc (Suc m) + offs ns' 0 ! (i - length ms')"
        using X by (simp add: offs_append nth_append offs_length,
         subst offs_base_zero [OF V], simp)
      hence "j < Suc (Suc m) + offs ns' 0 ! (i - length ms')"
        using L by simp
      moreover from this have "0 < offs ns' 0 ! (i - length ms')"
        using S by (rule_tac ccontr, simp)
      ultimately have "j - Suc (Suc m) < offs ns' 0 ! (i - length ms')"
        by simp
      hence Z: "\<forall>k \<in> {offs ns' 0 ! (i - length ms')..<length xs'}.
        key (xs' ! (j - Suc (Suc m))) \<le> key (xs' ! k)"
        using W by simp
      have "offs ns' 0 ! (i - length ms') \<le> k - Suc (Suc m)"
        using M and Y by simp
      moreover have "k - Suc (Suc m) < length xs'"
        using N and P and U by arith
      ultimately have "k - Suc (Suc m) \<in>
        {offs ns' 0 ! (i - length ms')..<length xs'}"
        by simp
      with Z show "key (xs' ! (j - Suc (Suc m))) \<le>
        key (xs' ! (k - Suc (Suc m)))" ..
    qed
  qed
qed

lemma gcsort_sort_inv:
  assumes
    A: "index_less index key" and
    B: "index_mono index key" and
    C: "add_inv n t" and
    D: "n \<le> p"
  shows "\<lbrakk>t' \<in> gcsort_set index key p t; sort_inv key t\<rbrakk> \<Longrightarrow>
    sort_inv key t'"
by (erule gcsort_set.induct, simp, drule gcsort_add_inv [OF A _ C D],
 rule round_sort_inv [OF A B], simp_all del: bn_inv.simps, erule conjE,
 frule sym, erule subst, rule bn_inv_intro, insert D, simp)

text \<open>
\null

The only remaining task is to address step 10 of the proof method, which is done by proving theorem
@{text gcsort_sorted}. It holds under the conditions that the objects' number is not larger than the
counters' upper bound and function @{text index} satisfies both predicates @{const index_less} and
@{const index_mono}, and states that function @{const gcsort} is successful in sorting the input
objects' list.

\null
\<close>

theorem gcsort_sorted:
  assumes
    A: "index_less index key" and
    B: "index_mono index key" and
    C: "length xs \<le> p"
  shows "sorted (map key (gcsort index key p xs))"
proof -
  let ?t = "(0, [length xs], xs)"
  have "sort_inv key (gcsort_aux index key p ?t)"
    by (rule gcsort_sort_inv [OF A B _ C], rule gcsort_add_input,
     rule gcsort_aux_set, rule gcsort_sort_input)
  moreover have "add_inv (length xs) (gcsort_aux index key p ?t)"
    by (rule gcsort_add_inv [OF A _ _ C],
     rule gcsort_aux_set, rule gcsort_add_input)
  ultimately have "sorted (map key (gcsort_out (gcsort_aux index key p ?t)))"
    by (rule gcsort_sort_intro, simp add: gcsort_sort_form)
  moreover have "?t = gcsort_in xs"
    by (simp add: gcsort_in_def)
  ultimately show ?thesis
    by (simp add: gcsort_def)
qed

end


(* Author: Tobias Nipkow, Florian Haftmann, TU Muenchen *)

section \<open>Character and string types\<close>

theory String
imports Enum
begin

subsection \<open>Strings as list of bytes\<close>

text \<open>
  When modelling strings, we follow the approach given
  in \<^url>\<open>https://utf8everywhere.org/\<close>:

  \<^item> Strings are a list of bytes (8 bit).

  \<^item> Byte values from 0 to 127 are US-ASCII.

  \<^item> Byte values from 128 to 255 are uninterpreted blobs.
\<close>

subsubsection \<open>Bytes as datatype\<close>

datatype char =
  Char (digit0: bool) (digit1: bool) (digit2: bool) (digit3: bool)
       (digit4: bool) (digit5: bool) (digit6: bool) (digit7: bool)

context comm_semiring_1
begin

definition of_char :: \<open>char \<Rightarrow> 'a\<close>
  where \<open>of_char c = horner_sum of_bool 2 [digit0 c, digit1 c, digit2 c, digit3 c, digit4 c, digit5 c, digit6 c, digit7 c]\<close>

lemma of_char_Char [simp]:
  \<open>of_char (Char b0 b1 b2 b3 b4 b5 b6 b7) =
    horner_sum of_bool 2 [b0, b1, b2, b3, b4, b5, b6, b7]\<close>
  by (simp add: of_char_def)

end

context unique_euclidean_semiring_with_bit_shifts
begin

definition char_of :: \<open>'a \<Rightarrow> char\<close>
  where \<open>char_of n = Char (odd n) (bit n 1) (bit n 2) (bit n 3) (bit n 4) (bit n 5) (bit n 6) (bit n 7)\<close>

lemma char_of_take_bit_eq:
  \<open>char_of (take_bit n m) = char_of m\<close> if \<open>n \<ge> 8\<close>
  using that by (simp add: char_of_def bit_take_bit_iff)

lemma char_of_char [simp]:
  \<open>char_of (of_char c) = c\<close>
  by (simp only: of_char_def char_of_def bit_horner_sum_bit_iff) simp

lemma char_of_comp_of_char [simp]:
  "char_of \<circ> of_char = id"
  by (simp add: fun_eq_iff)

lemma inj_of_char:
  \<open>inj of_char\<close>
proof (rule injI)
  fix c d
  assume "of_char c = of_char d"
  then have "char_of (of_char c) = char_of (of_char d)"
    by simp
  then show "c = d"
    by simp
qed

lemma of_char_eqI:
  \<open>c = d\<close> if \<open>of_char c = of_char d\<close>
  using that inj_of_char by (simp add: inj_eq)

lemma of_char_eq_iff [simp]:
  \<open>of_char c = of_char d \<longleftrightarrow> c = d\<close>
  by (auto intro: of_char_eqI)

lemma of_char_of [simp]:
  \<open>of_char (char_of a) = a mod 256\<close>
proof -
  have \<open>[0..<8] = [0, Suc 0, 2, 3, 4, 5, 6, 7 :: nat]\<close>
    by (simp add: upt_eq_Cons_conv)
  then have \<open>[odd a, bit a 1, bit a 2, bit a 3, bit a 4, bit a 5, bit a 6, bit a 7] = map (bit a) [0..<8]\<close>
    by simp
  then have \<open>of_char (char_of a) = take_bit 8 a\<close>
    by (simp only: char_of_def of_char_def char.sel horner_sum_bit_eq_take_bit)
  then show ?thesis
    by (simp add: take_bit_eq_mod)
qed

lemma char_of_mod_256 [simp]:
  \<open>char_of (n mod 256) = char_of n\<close>
  by (rule of_char_eqI) simp

lemma of_char_mod_256 [simp]:
  \<open>of_char c mod 256 = of_char c\<close>
proof -
  have \<open>of_char (char_of (of_char c)) mod 256 = of_char (char_of (of_char c))\<close>
    by (simp only: of_char_of) simp
  then show ?thesis
    by simp
qed

lemma char_of_quasi_inj [simp]:
  \<open>char_of m = char_of n \<longleftrightarrow> m mod 256 = n mod 256\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume ?Q
  then show ?P
    by (auto intro: of_char_eqI)
next
  assume ?P
  then have \<open>of_char (char_of m) = of_char (char_of n)\<close>
    by simp
  then show ?Q
    by simp
qed

lemma char_of_eq_iff:
  \<open>char_of n = c \<longleftrightarrow> take_bit 8 n = of_char c\<close>
  by (auto intro: of_char_eqI simp add: take_bit_eq_mod)

lemma char_of_nat [simp]:
  \<open>char_of (of_nat n) = char_of n\<close>
  by (simp add: char_of_def String.char_of_def drop_bit_of_nat bit_simps)

end

lemma inj_on_char_of_nat [simp]:
  "inj_on char_of {0::nat..<256}"
  by (rule inj_onI) simp

lemma nat_of_char_less_256 [simp]:
  "of_char c < (256 :: nat)"
proof -
  have "of_char c mod (256 :: nat) < 256"
    by arith
  then show ?thesis by simp
qed

lemma range_nat_of_char:
  "range of_char = {0::nat..<256}"
proof (rule; rule)
  fix n :: nat
  assume "n \<in> range of_char"
  then show "n \<in> {0..<256}"
    by auto
next
  fix n :: nat
  assume "n \<in> {0..<256}"
  then have "n = of_char (char_of n)"
    by simp
  then show "n \<in> range of_char"
    by (rule range_eqI)
qed

lemma UNIV_char_of_nat:
  "UNIV = char_of ` {0::nat..<256}"
proof -
  have "range (of_char :: char \<Rightarrow> nat) = of_char ` char_of ` {0::nat..<256}"
    by (auto simp add: range_nat_of_char intro!: image_eqI)
  with inj_of_char [where ?'a = nat] show ?thesis
    by (simp add: inj_image_eq_iff)
qed

lemma card_UNIV_char:
  "card (UNIV :: char set) = 256"
  by (auto simp add: UNIV_char_of_nat card_image)

context
  includes lifting_syntax integer.lifting natural.lifting
begin

lemma [transfer_rule]:
  \<open>((=) ===> pcr_integer) of_char of_char\<close>
  by (unfold of_char_def) transfer_prover

lemma [transfer_rule]:
  \<open>(pcr_natural ===> (=)) char_of char_of\<close>
  by (unfold char_of_def) transfer_prover

lemma [transfer_rule]:
  \<open>((=) ===> pcr_natural) of_char of_char\<close>
  by (unfold of_char_def) transfer_prover

end

lifting_update integer.lifting
lifting_forget integer.lifting

lifting_update natural.lifting
lifting_forget natural.lifting

syntax
  "_Char" :: "str_position \<Rightarrow> char"    ("CHR _")
  "_Char_ord" :: "num_const \<Rightarrow> char"   ("CHR _")

type_synonym string = "char list"

syntax
  "_String" :: "str_position \<Rightarrow> string"    ("_")

ML_file \<open>Tools/string_syntax.ML\<close>

instantiation char :: enum
begin

definition
  "Enum.enum = [
    CHR 0x00, CHR 0x01, CHR 0x02, CHR 0x03,
    CHR 0x04, CHR 0x05, CHR 0x06, CHR 0x07,
    CHR 0x08, CHR 0x09, CHR ''\<newline>'', CHR 0x0B,
    CHR 0x0C, CHR 0x0D, CHR 0x0E, CHR 0x0F,
    CHR 0x10, CHR 0x11, CHR 0x12, CHR 0x13,
    CHR 0x14, CHR 0x15, CHR 0x16, CHR 0x17,
    CHR 0x18, CHR 0x19, CHR 0x1A, CHR 0x1B,
    CHR 0x1C, CHR 0x1D, CHR 0x1E, CHR 0x1F,
    CHR '' '', CHR ''!'', CHR 0x22, CHR ''#'',
    CHR ''$'', CHR ''%'', CHR ''&'', CHR 0x27,
    CHR ''('', CHR '')'', CHR ''*'', CHR ''+'',
    CHR '','', CHR ''-'', CHR ''.'', CHR ''/'',
    CHR ''0'', CHR ''1'', CHR ''2'', CHR ''3'',
    CHR ''4'', CHR ''5'', CHR ''6'', CHR ''7'',
    CHR ''8'', CHR ''9'', CHR '':'', CHR '';'',
    CHR ''<'', CHR ''='', CHR ''>'', CHR ''?'',
    CHR ''@'', CHR ''A'', CHR ''B'', CHR ''C'',
    CHR ''D'', CHR ''E'', CHR ''F'', CHR ''G'',
    CHR ''H'', CHR ''I'', CHR ''J'', CHR ''K'',
    CHR ''L'', CHR ''M'', CHR ''N'', CHR ''O'',
    CHR ''P'', CHR ''Q'', CHR ''R'', CHR ''S'',
    CHR ''T'', CHR ''U'', CHR ''V'', CHR ''W'',
    CHR ''X'', CHR ''Y'', CHR ''Z'', CHR ''['',
    CHR 0x5C, CHR '']'', CHR ''^'', CHR ''_'',
    CHR 0x60, CHR ''a'', CHR ''b'', CHR ''c'',
    CHR ''d'', CHR ''e'', CHR ''f'', CHR ''g'',
    CHR ''h'', CHR ''i'', CHR ''j'', CHR ''k'',
    CHR ''l'', CHR ''m'', CHR ''n'', CHR ''o'',
    CHR ''p'', CHR ''q'', CHR ''r'', CHR ''s'',
    CHR ''t'', CHR ''u'', CHR ''v'', CHR ''w'',
    CHR ''x'', CHR ''y'', CHR ''z'', CHR ''{'',
    CHR ''|'', CHR ''}'', CHR ''~'', CHR 0x7F,
    CHR 0x80, CHR 0x81, CHR 0x82, CHR 0x83,
    CHR 0x84, CHR 0x85, CHR 0x86, CHR 0x87,
    CHR 0x88, CHR 0x89, CHR 0x8A, CHR 0x8B,
    CHR 0x8C, CHR 0x8D, CHR 0x8E, CHR 0x8F,
    CHR 0x90, CHR 0x91, CHR 0x92, CHR 0x93,
    CHR 0x94, CHR 0x95, CHR 0x96, CHR 0x97,
    CHR 0x98, CHR 0x99, CHR 0x9A, CHR 0x9B,
    CHR 0x9C, CHR 0x9D, CHR 0x9E, CHR 0x9F,
    CHR 0xA0, CHR 0xA1, CHR 0xA2, CHR 0xA3,
    CHR 0xA4, CHR 0xA5, CHR 0xA6, CHR 0xA7,
    CHR 0xA8, CHR 0xA9, CHR 0xAA, CHR 0xAB,
    CHR 0xAC, CHR 0xAD, CHR 0xAE, CHR 0xAF,
    CHR 0xB0, CHR 0xB1, CHR 0xB2, CHR 0xB3,
    CHR 0xB4, CHR 0xB5, CHR 0xB6, CHR 0xB7,
    CHR 0xB8, CHR 0xB9, CHR 0xBA, CHR 0xBB,
    CHR 0xBC, CHR 0xBD, CHR 0xBE, CHR 0xBF,
    CHR 0xC0, CHR 0xC1, CHR 0xC2, CHR 0xC3,
    CHR 0xC4, CHR 0xC5, CHR 0xC6, CHR 0xC7,
    CHR 0xC8, CHR 0xC9, CHR 0xCA, CHR 0xCB,
    CHR 0xCC, CHR 0xCD, CHR 0xCE, CHR 0xCF,
    CHR 0xD0, CHR 0xD1, CHR 0xD2, CHR 0xD3,
    CHR 0xD4, CHR 0xD5, CHR 0xD6, CHR 0xD7,
    CHR 0xD8, CHR 0xD9, CHR 0xDA, CHR 0xDB,
    CHR 0xDC, CHR 0xDD, CHR 0xDE, CHR 0xDF,
    CHR 0xE0, CHR 0xE1, CHR 0xE2, CHR 0xE3,
    CHR 0xE4, CHR 0xE5, CHR 0xE6, CHR 0xE7,
    CHR 0xE8, CHR 0xE9, CHR 0xEA, CHR 0xEB,
    CHR 0xEC, CHR 0xED, CHR 0xEE, CHR 0xEF,
    CHR 0xF0, CHR 0xF1, CHR 0xF2, CHR 0xF3,
    CHR 0xF4, CHR 0xF5, CHR 0xF6, CHR 0xF7,
    CHR 0xF8, CHR 0xF9, CHR 0xFA, CHR 0xFB,
    CHR 0xFC, CHR 0xFD, CHR 0xFE, CHR 0xFF]"

definition
  "Enum.enum_all P \<longleftrightarrow> list_all P (Enum.enum :: char list)"

definition
  "Enum.enum_ex P \<longleftrightarrow> list_ex P (Enum.enum :: char list)"

lemma enum_char_unfold:
  "Enum.enum = map char_of [0..<256]"
proof -
  have "map (of_char :: char \<Rightarrow> nat) Enum.enum = [0..<256]"
    by (simp add: enum_char_def of_char_def upt_conv_Cons_Cons numeral_2_eq_2 [symmetric])
  then have "map char_of (map (of_char :: char \<Rightarrow> nat) Enum.enum) =
    map char_of [0..<256]"
    by simp
  then show ?thesis
    by simp
qed

instance proof
  show UNIV: "UNIV = set (Enum.enum :: char list)"
    by (simp add: enum_char_unfold UNIV_char_of_nat atLeast0LessThan)
  show "distinct (Enum.enum :: char list)"
    by (auto simp add: enum_char_unfold distinct_map intro: inj_onI)
  show "\<And>P. Enum.enum_all P \<longleftrightarrow> Ball (UNIV :: char set) P"
    by (simp add: UNIV enum_all_char_def list_all_iff)
  show "\<And>P. Enum.enum_ex P \<longleftrightarrow> Bex (UNIV :: char set) P"
    by (simp add: UNIV enum_ex_char_def list_ex_iff)
qed

end

lemma linorder_char:
  "class.linorder (\<lambda>c d. of_char c \<le> (of_char d :: nat)) (\<lambda>c d. of_char c < (of_char d :: nat))"
  by standard auto

text \<open>Optimized version for execution\<close>

definition char_of_integer :: "integer \<Rightarrow> char"
  where [code_abbrev]: "char_of_integer = char_of"

definition integer_of_char :: "char \<Rightarrow> integer"
  where [code_abbrev]: "integer_of_char = of_char"

lemma char_of_integer_code [code]:
  "char_of_integer k = (let
     (q0, b0) = bit_cut_integer k;
     (q1, b1) = bit_cut_integer q0;
     (q2, b2) = bit_cut_integer q1;
     (q3, b3) = bit_cut_integer q2;
     (q4, b4) = bit_cut_integer q3;
     (q5, b5) = bit_cut_integer q4;
     (q6, b6) = bit_cut_integer q5;
     (_, b7) = bit_cut_integer q6
    in Char b0 b1 b2 b3 b4 b5 b6 b7)"
  by (simp add: bit_cut_integer_def char_of_integer_def char_of_def div_mult2_numeral_eq bit_iff_odd_drop_bit drop_bit_eq_div)

lemma integer_of_char_code [code]:
  "integer_of_char (Char b0 b1 b2 b3 b4 b5 b6 b7) =
    ((((((of_bool b7 * 2 + of_bool b6) * 2 +
      of_bool b5) * 2 + of_bool b4) * 2 +
        of_bool b3) * 2 + of_bool b2) * 2 +
          of_bool b1) * 2 + of_bool b0"
  by (simp add: integer_of_char_def of_char_def)

subsection \<open>Strings as dedicated type for target language code generation\<close>

subsubsection \<open>Logical specification\<close>

context
begin

qualified definition ascii_of :: "char \<Rightarrow> char"
  where "ascii_of c = Char (digit0 c) (digit1 c) (digit2 c) (digit3 c) (digit4 c) (digit5 c) (digit6 c) False"

qualified lemma ascii_of_Char [simp]:
  "ascii_of (Char b0 b1 b2 b3 b4 b5 b6 b7) = Char b0 b1 b2 b3 b4 b5 b6 False"
  by (simp add: ascii_of_def)

qualified lemma not_digit7_ascii_of [simp]:
  "\<not> digit7 (ascii_of c)"
  by (simp add: ascii_of_def)

qualified lemma ascii_of_idem:
  "ascii_of c = c" if "\<not> digit7 c"
  using that by (cases c) simp

qualified lemma char_of_ascii_of [simp]:
  "of_char (ascii_of c) = take_bit 7 (of_char c :: nat)"
  by (cases c) (simp only: ascii_of_Char of_char_Char take_bit_horner_sum_bit_eq, simp)

qualified typedef literal = "{cs. \<forall>c\<in>set cs. \<not> digit7 c}"
  morphisms explode Abs_literal
proof
  show "[] \<in> {cs. \<forall>c\<in>set cs. \<not> digit7 c}"
    by simp
qed

qualified setup_lifting type_definition_literal

qualified lift_definition implode :: "string \<Rightarrow> literal"
  is "map ascii_of"
  by auto

qualified lemma implode_explode_eq [simp]:
  "String.implode (String.explode s) = s"
proof transfer
  fix cs
  show "map ascii_of cs = cs" if "\<forall>c\<in>set cs. \<not> digit7 c"
    using that
      by (induction cs) (simp_all add: ascii_of_idem)
qed

qualified lemma explode_implode_eq [simp]:
  "String.explode (String.implode cs) = map ascii_of cs"
  by transfer rule

end

subsubsection \<open>Syntactic representation\<close>

text \<open>
  Logical ground representations for literals are:

  \<^enum> \<open>0\<close> for the empty literal;

  \<^enum> \<open>Literal b0 \<dots> b6 s\<close> for a literal starting with one
    character and continued by another literal.

  Syntactic representations for literals are:

  \<^enum> Printable text as string prefixed with \<open>STR\<close>;

  \<^enum> A single ascii value as numerical hexadecimal value prefixed with \<open>STR\<close>.
\<close>

instantiation String.literal :: zero
begin

context
begin

qualified lift_definition zero_literal :: String.literal
  is Nil
  by simp

instance ..

end

end

context
begin

qualified abbreviation (output) empty_literal :: String.literal
  where "empty_literal \<equiv> 0"

qualified lift_definition Literal :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> String.literal \<Rightarrow> String.literal"
  is "\<lambda>b0 b1 b2 b3 b4 b5 b6 cs. Char b0 b1 b2 b3 b4 b5 b6 False # cs"
  by auto

qualified lemma Literal_eq_iff [simp]:
  "Literal b0 b1 b2 b3 b4 b5 b6 s = Literal c0 c1 c2 c3 c4 c5 c6 t
     \<longleftrightarrow> (b0 \<longleftrightarrow> c0) \<and> (b1 \<longleftrightarrow> c1) \<and> (b2 \<longleftrightarrow> c2) \<and> (b3 \<longleftrightarrow> c3)
         \<and> (b4 \<longleftrightarrow> c4) \<and> (b5 \<longleftrightarrow> c5) \<and> (b6 \<longleftrightarrow> c6) \<and> s = t"
  by transfer simp

qualified lemma empty_neq_Literal [simp]:
  "empty_literal \<noteq> Literal b0 b1 b2 b3 b4 b5 b6 s"
  by transfer simp

qualified lemma Literal_neq_empty [simp]:
  "Literal b0 b1 b2 b3 b4 b5 b6 s \<noteq> empty_literal"
  by transfer simp

end

code_datatype "0 :: String.literal" String.Literal

syntax
  "_Literal" :: "str_position \<Rightarrow> String.literal"   ("STR _")
  "_Ascii" :: "num_const \<Rightarrow> String.literal"        ("STR _")

ML_file \<open>Tools/literal.ML\<close>

subsubsection \<open>Operations\<close>

instantiation String.literal :: plus
begin

context
begin

qualified lift_definition plus_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> String.literal"
  is "(@)"
  by auto

instance ..

end

end

instance String.literal :: monoid_add
  by (standard; transfer) simp_all

instantiation String.literal :: size
begin

context
  includes literal.lifting
begin

lift_definition size_literal :: "String.literal \<Rightarrow> nat"
  is length .

end

instance ..

end

instantiation String.literal :: equal
begin

context
begin

qualified lift_definition equal_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is HOL.equal .

instance
  by (standard; transfer) (simp add: equal)

end

end

instantiation String.literal :: linorder
begin

context
begin

qualified lift_definition less_eq_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp_eq (\<lambda>c d. of_char c < (of_char d :: nat))"
  .

qualified lift_definition less_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp (\<lambda>c d. of_char c < (of_char d :: nat))"
  .

instance proof -
  from linorder_char interpret linorder "ord.lexordp_eq (\<lambda>c d. of_char c < (of_char d :: nat))"
    "ord.lexordp (\<lambda>c d. of_char c < (of_char d :: nat)) :: string \<Rightarrow> string \<Rightarrow> bool"
    by (rule linorder.lexordp_linorder)
  show "PROP ?thesis"
    by (standard; transfer) (simp_all add: less_le_not_le linear)
qed

end

end

lemma infinite_literal:
  "infinite (UNIV :: String.literal set)"
proof -
  define S where "S = range (\<lambda>n. replicate n CHR ''A'')"
  have "inj_on String.implode S"
  proof (rule inj_onI)
    fix cs ds
    assume "String.implode cs = String.implode ds"
    then have "String.explode (String.implode cs) = String.explode (String.implode ds)"
      by simp
    moreover assume "cs \<in> S" and "ds \<in> S"
    ultimately show "cs = ds"
      by (auto simp add: S_def)
  qed
  moreover have "infinite S"
    by (auto simp add: S_def dest: finite_range_imageI [of _ length])
  ultimately have "infinite (String.implode ` S)"
    by (simp add: finite_image_iff)
  then show ?thesis
    by (auto intro: finite_subset)
qed

subsubsection \<open>Executable conversions\<close>

context
begin

qualified lift_definition asciis_of_literal :: "String.literal \<Rightarrow> integer list"
  is "map of_char"
  .

qualified lemma asciis_of_zero [simp, code]:
  "asciis_of_literal 0 = []"
  by transfer simp

qualified lemma asciis_of_Literal [simp, code]:
  "asciis_of_literal (String.Literal b0 b1 b2 b3 b4 b5 b6 s) =
    of_char (Char b0 b1 b2 b3 b4 b5 b6 False) # asciis_of_literal s "
  by transfer simp

qualified lift_definition literal_of_asciis :: "integer list \<Rightarrow> String.literal"
  is "map (String.ascii_of \<circ> char_of)"
  by auto

qualified lemma literal_of_asciis_Nil [simp, code]:
  "literal_of_asciis [] = 0"
  by transfer simp

qualified lemma literal_of_asciis_Cons [simp, code]:
  "literal_of_asciis (k # ks) = (case char_of k
    of Char b0 b1 b2 b3 b4 b5 b6 b7 \<Rightarrow> String.Literal b0 b1 b2 b3 b4 b5 b6 (literal_of_asciis ks))"
  by (simp add: char_of_def) (transfer, simp add: char_of_def)

qualified lemma literal_of_asciis_of_literal [simp]:
  "literal_of_asciis (asciis_of_literal s) = s"
proof transfer
  fix cs
  assume "\<forall>c\<in>set cs. \<not> digit7 c"
  then show "map (String.ascii_of \<circ> char_of) (map of_char cs) = cs"
    by (induction cs) (simp_all add: String.ascii_of_idem)
qed

qualified lemma explode_code [code]:
  "String.explode s = map char_of (asciis_of_literal s)"
  by transfer simp

qualified lemma implode_code [code]:
  "String.implode cs = literal_of_asciis (map of_char cs)"
  by transfer simp

qualified lemma equal_literal [code]:
  "HOL.equal (String.Literal b0 b1 b2 b3 b4 b5 b6 s)
    (String.Literal a0 a1 a2 a3 a4 a5 a6 r)
    \<longleftrightarrow> (b0 \<longleftrightarrow> a0) \<and> (b1 \<longleftrightarrow> a1) \<and> (b2 \<longleftrightarrow> a2) \<and> (b3 \<longleftrightarrow> a3)
      \<and> (b4 \<longleftrightarrow> a4) \<and> (b5 \<longleftrightarrow> a5) \<and> (b6 \<longleftrightarrow> a6) \<and> (s = r)"
  by (simp add: equal)

end

subsubsection \<open>Technical code generation setup\<close>

text \<open>Alternative constructor for generated computations\<close>

context
begin

qualified definition Literal' :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> String.literal \<Rightarrow> String.literal"
  where [simp]: "Literal' = String.Literal"

lemma [code_computation_unfold]:
  "String.Literal = Literal'"
  by simp

end

code_reserved SML string String Char List
code_reserved OCaml string String Char List
code_reserved Haskell Prelude
code_reserved Scala string

code_printing
  type_constructor String.literal \<rightharpoonup>
    (SML) "string"
    and (OCaml) "string"
    and (Haskell) "String"
    and (Scala) "String"
| constant "STR ''''" \<rightharpoonup>
    (SML) "\"\""
    and (OCaml) "\"\""
    and (Haskell) "\"\""
    and (Scala) "\"\""

setup \<open>
  fold Literal.add_code ["SML", "OCaml", "Haskell", "Scala"]
\<close>

code_printing
  constant "(+) :: String.literal \<Rightarrow> String.literal \<Rightarrow> String.literal" \<rightharpoonup>
    (SML) infixl 18 "^"
    and (OCaml) infixr 6 "^"
    and (Haskell) infixr 5 "++"
    and (Scala) infixl 7 "+"
| constant String.literal_of_asciis \<rightharpoonup>
    (SML) "!(String.implode/ o List.map (fn k => if 0 <= k andalso k < 128 then (Char.chr o IntInf.toInt) k else raise Fail \"Non-ASCII character in literal\"))"
    and (OCaml) "!(let xs = _
      and chr k =
        let l = Z.to'_int k
          in if 0 <= l && l < 128
          then Char.chr l
          else failwith \"Non-ASCII character in literal\"
      in String.init (List.length xs) (List.nth (List.map chr xs)))"
    and (Haskell) "map/ (let chr k | (0 <= k && k < 128) = Prelude.toEnum k :: Prelude.Char in chr . Prelude.fromInteger)"
    and (Scala) "\"\"/ ++/ _.map((k: BigInt) => if (BigInt(0) <= k && k < BigInt(128)) k.charValue else sys.error(\"Non-ASCII character in literal\"))"
| constant String.asciis_of_literal \<rightharpoonup>
    (SML) "!(List.map (fn c => let val k = Char.ord c in if k < 128 then IntInf.fromInt k else raise Fail \"Non-ASCII character in literal\" end) /o String.explode)"
    and (OCaml) "!(let s = _ in let rec exp i l = if i < 0 then l else exp (i - 1) (let k = Char.code (String.get s i) in
      if k < 128 then Z.of'_int k :: l else failwith \"Non-ASCII character in literal\") in exp (String.length s - 1) [])"
    and (Haskell) "map/ (let ord k | (k < 128) = Prelude.toInteger k in ord . (Prelude.fromEnum :: Prelude.Char -> Prelude.Int))"
    and (Scala) "!(_.toList.map(c => { val k: Int = c.toInt; if (k < 128) BigInt(k) else sys.error(\"Non-ASCII character in literal\") }))"
| class_instance String.literal :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) = _)"
    and (OCaml) "!((_ : string) = _)"
    and (Haskell) infix 4 "=="
    and (Scala) infixl 5 "=="
| constant "(\<le>) :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) <= _)"
    and (OCaml) "!((_ : string) <= _)"
    and (Haskell) infix 4 "<="
    \<comment> \<open>Order operations for \<^typ>\<open>String.literal\<close> work in Haskell only
          if no type class instance needs to be generated, because String = [Char] in Haskell
          and \<^typ>\<open>char list\<close> need not have the same order as \<^typ>\<open>String.literal\<close>.\<close>
    and (Scala) infixl 4 "<="
    and (Eval) infixl 6 "<="
| constant "(<) :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) < _)"
    and (OCaml) "!((_ : string) < _)"
    and (Haskell) infix 4 "<"
    and (Scala) infixl 4 "<"
    and (Eval) infixl 6 "<"

subsubsection \<open>Code generation utility\<close>

setup \<open>Sign.map_naming (Name_Space.mandatory_path "Code")\<close>

definition abort :: "String.literal \<Rightarrow> (unit \<Rightarrow> 'a) \<Rightarrow> 'a"
  where [simp]: "abort _ f = f ()"

declare [[code drop: Code.abort]]

lemma abort_cong:
  "msg = msg' \<Longrightarrow> Code.abort msg f = Code.abort msg' f"
  by simp

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm Code.abort_cong})\<close>

code_printing
  constant Code.abort \<rightharpoonup>
    (SML) "!(raise/ Fail/ _)"
    and (OCaml) "failwith"
    and (Haskell) "!(error/ ::/ forall a./ String -> (() -> a) -> a)"
    and (Scala) "!{/ sys.error((_));/ ((_)).apply(())/ }"

subsubsection \<open>Finally\<close>

lifting_update literal.lifting
lifting_forget literal.lifting

end


theory Diff_Arr_Rel
  imports Cell
begin

(* TODO: Is precedence okay? + How to make subscript not just single char? *)
fun diff_arr_rel' ("(_ \<turnstile> _ \<sim>\<^sub>_ _)" [51, 51, 51, 51] 50)  where
  "diff_arr_rel' t xs 0 a \<longleftrightarrow> (a, Array' xs) \<in>\<^sub>L t"
| "diff_arr_rel' t xs (Suc n) a \<longleftrightarrow> (\<exists>i x a' xs'.
      (a, Upd' i x a') \<in>\<^sub>L t
    \<and> diff_arr_rel' t xs' n a'
    \<and> xs = xs'[i:=x]
    \<and> i < length xs'
)"

(* TODO: Is precedence okay? *)
definition diff_arr_rel ("(_ \<turnstile> _ \<sim> _)" [51, 51, 51] 50) where
  "diff_arr_rel t xs a \<equiv> \<exists>n. t \<turnstile> xs \<sim>\<^sub>n a"

lemma diff_arr_rel'_cons: "t \<turnstile> xs \<sim>\<^sub>n diff_arr \<Longrightarrow> x # t \<turnstile> xs \<sim>\<^sub>n diff_arr"
proof(induction t xs n diff_arr rule: diff_arr_rel'.induct)
  case 1
  then show ?case by auto
next
  case (2 t xs n a)
  then show ?case
    apply auto
    subgoal for i v a' xs'
      apply(rule exI[where x = "i"])
      apply(rule exI[where x = "v"])
      apply(rule exI[where x = "a'"])
      by auto
    done
qed

lemma diff_arr_rel'_cons': "t \<turnstile> xs \<sim>\<^sub>n diff_arr \<Longrightarrow> \<exists>n. x # t \<turnstile> xs \<sim>\<^sub>n diff_arr"
  using diff_arr_rel'_cons
  by blast

lemma diff_arr_rel_cons: "t \<turnstile> xs \<sim> diff_arr \<Longrightarrow> x # t \<turnstile> xs \<sim> diff_arr"
  unfolding diff_arr_rel_def
  using diff_arr_rel'_cons by blast

end


header {* Shallow embedding of HyperCTL* *}

(*<*)
theory Shallow
imports Prelim
begin
(*>*)

text{* We define a notion of ``shallow'' HyperCTL* formula (sfmla) that captures
HyperCTL* binders as meta-level HOL binders. We also define a proof system for this
shallow embedding.   *}

subsection{* Kripke structures and paths *}

type_synonym ('state,'aprop) path = "('state \<times> 'aprop set) stream"

abbreviation stateOf where "stateOf \<pi> \<equiv> fst (shd \<pi>)"
abbreviation apropsOf where "apropsOf \<pi> \<equiv> snd (shd \<pi>)"

locale Kripke =
  fixes S :: "'state set" and s0 :: 'state and \<delta> :: "'state \<Rightarrow> 'state set"
  and AP :: "'aprop set" and L :: "'state \<Rightarrow> 'aprop set"
  assumes s0: "s0 \<in> S" and \<delta>: "\<And> s. s \<in> S \<Longrightarrow> \<delta> s \<subseteq> S"
  and L : "\<And> s. s \<in> S \<Longrightarrow> L s \<subseteq> AP"
begin

text{* Well-formed paths *}

coinductive wfp :: "'aprop set \<Rightarrow> ('state,'aprop) path \<Rightarrow> bool"
for AP' :: "'aprop set"
where
intro:
"\<lbrakk>s \<in> S; A \<subseteq> AP'; A \<inter> AP = L s; stateOf \<pi> \<in> \<delta> s; wfp AP' \<pi>\<rbrakk>
 \<Longrightarrow>
 wfp AP' ((s,A) ## \<pi>)"

lemma wfp:
"wfp AP' \<pi> \<longleftrightarrow>
 (\<forall> i. fst (\<pi> !! i) \<in> S \<and> snd (\<pi> !! i) \<subseteq> AP' \<and>
       snd (\<pi> !! i) \<inter> AP = L (fst (\<pi> !! i)) \<and>
       fst (\<pi> !! (Suc i)) \<in> \<delta> (fst (\<pi> !! i))
 )"
(is "?L \<longleftrightarrow> (\<forall> i. ?R i)")
proof (intro iffI allI)
  fix i assume ?L thus "?R i"
  apply(induction i arbitrary: \<pi>)
  by (metis snth.simps fst_conv snd_conv stream.sel wfp.cases)+
next
  assume R: "\<forall> i. ?R i"  thus ?L
  apply (coinduct)
  using s0 fst_conv snd_conv snth.simps stream.sel
  by (metis inf_commute stream.collapse surj_pair)
qed

lemma wfp_sdrop[simp]:
"wfp AP' \<pi> \<Longrightarrow> wfp AP' (sdrop i \<pi>)"
unfolding wfp by simp (metis sdrop_add sdrop_simps(1))

(*<*)
end (* context Kripke *)
(*>*)

text{* end-of-context Kripke *}

subsection{* Shallow representations of formulas *}

text{* A shallow (representation of a) HyperCTL* formula will be a predicate on lists of paths.
The atomic formulas (operator $\textit{atom}$) are parameterized by atomic propositions (as customary in temporal logic),
and additionally by a number indicating the position, in the list of paths, of the path to which the atomic proposition
refers -- for example, $\textit{atom}\;a\;i$ holds for the list of paths $\pi l$ just in case proposition $a$ holds
at the first state of $\pi l!i$, the $i$'th path in $\pi l$.  The temporal operators $\textit{next}$ and $\textit{until}$ act on all the paths of the argument
list $\pi l$ synchronously.  Finally, the existential quantifier refers to the existence of a path whose origin state is that of
the last path in $\pi l$.

As an example: $\textit{exi}\; (\textit{exi}\; (\textit{until}\; (\textit{atom}\;a\;0)\;(\textit{atom}\;b\;1)))$ holds for the empty list
iff there exist two paths $\rho_0$ and $\rho_1$ such that, synchronously,
$a$ holds on $\rho_0$ until $b$ holds on $\rho_1$.  Another example will be the formula encoding Goguen-Meseguer noninterference.
 *}

text{* Shallow HyperCTL* formulas: *}

type_synonym ('state,'aprop) sfmla = "('state,'aprop) path list \<Rightarrow> bool"

locale Shallow = Kripke S "s0" \<delta> AP L
  for S :: "'state set" and s0 :: 'state and \<delta> :: "'state \<Rightarrow> 'state set"
  and AP :: "'aprop set" and L :: "'state \<Rightarrow> 'aprop set"
+
  fixes AP' assumes AP_AP': "AP \<subseteq> AP'"
begin

text{* Primitive operators *}

(* I include false as a primitive since otherwise I would have to assume nonemptyness of
  the atomic propositions *)
definition fls :: "('state,'aprop) sfmla" where
"fls \<pi>l \<equiv> False"

definition atom :: "'aprop \<Rightarrow> nat \<Rightarrow> ('state,'aprop) sfmla" where
"atom a i \<pi>l \<equiv> a \<in> apropsOf (\<pi>l!i)"

definition neg :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"neg \<phi> \<pi>l \<equiv> \<not> \<phi> \<pi>l"

definition dis :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"dis \<phi> \<psi> \<pi>l \<equiv> \<phi> \<pi>l \<or> \<psi> \<pi>l"

definition "next" :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"next \<phi> \<pi>l \<equiv> \<phi> (map stl \<pi>l)"

definition until :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"until \<phi> \<psi> \<pi>l \<equiv>
 \<exists> i. \<psi> (map (sdrop i) \<pi>l) \<and> (\<forall> j \<in>{0..<i}. \<phi> (map (sdrop j) \<pi>l))"

definition exii :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"exii \<phi> \<pi>l \<equiv>
 \<exists> \<pi>. wfp AP' \<pi> \<and> stateOf \<pi> = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0)
      \<and> \<phi> (\<pi>l @ [\<pi>])"

definition exi :: "(('state,'aprop) path \<Rightarrow> ('state,'aprop) sfmla) \<Rightarrow> ('state,'aprop) sfmla" where
"exi F \<pi>l \<equiv>
 \<exists> \<pi>. wfp AP' \<pi> \<and> stateOf \<pi> = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0)
      \<and> F \<pi> \<pi>l"

text{* Derived operators *}

definition "tr \<equiv> neg fls"
definition "con \<phi> \<psi> \<equiv> neg (dis (neg \<phi>) (neg \<psi>))"
definition "imp \<phi> \<psi> \<equiv> dis (neg \<phi>) \<psi>"
definition "eq \<phi> \<psi> \<equiv> con (imp \<phi> \<psi>) (imp \<psi> \<phi>) "
definition "fall F \<equiv> neg (exi (\<lambda> \<pi>. neg (F \<pi>)))"
definition "ev \<phi> \<equiv> until tr \<phi>"
definition "alw \<phi> \<equiv> neg (ev (neg \<phi>))"
definition "wuntil \<phi> \<psi> \<equiv> dis (until \<phi> \<psi>) (alw \<phi>)"

lemmas main_op_defs =
fls_def atom_def neg_def dis_def next_def until_def exi_def

lemmas der_op_defs =
tr_def con_def imp_def eq_def ev_def alw_def wuntil_def fall_def

lemmas op_defs = main_op_defs der_op_defs

subsection{* Reasoning rules *}

text{* We provide introduction, elimination, unfolding and (co)induction rules
for the connectives and quantifiers.   *}

text{* Boolean operators *}

lemma fls_elim[elim!]:
assumes "fls \<pi>l" shows \<phi>
using assms unfolding op_defs by auto

lemma tr_intro[intro!, simp]: "tr \<pi>l"
unfolding op_defs by auto

lemma dis_introL[intro]:
assumes "\<phi> \<pi>l" shows "dis \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma dis_introR[intro]:
assumes "\<psi> \<pi>l" shows "dis \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma dis_elim[elim]:
assumes "dis \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l \<Longrightarrow> \<chi>" and "\<psi> \<pi>l \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding op_defs by auto

lemma con_intro[intro!]:
assumes "\<phi> \<pi>l" and "\<psi> \<pi>l" shows "con \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma con_elim[elim]:
assumes "con \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l \<Longrightarrow> \<psi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma neg_intro[intro!]:
assumes "\<phi> \<pi>l \<Longrightarrow> False"  shows "neg \<phi> \<pi>l"
using assms unfolding op_defs by auto

lemma neg_elim[elim]:
assumes "neg \<phi> \<pi>l" and "\<phi> \<pi>l"  shows \<chi>
using assms unfolding op_defs by auto

lemma imp_intro[intro!]:
assumes "\<phi> \<pi>l \<Longrightarrow> \<psi> \<pi>l"  shows "imp \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma imp_elim[elim]:
assumes "imp \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l" and "\<psi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma imp_mp[elim]:
assumes "imp \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l" shows "\<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma eq_intro[intro!]:
assumes "\<phi> \<pi>l \<Longrightarrow> \<psi> \<pi>l" and "\<psi> \<pi>l \<Longrightarrow> \<phi> \<pi>l" shows "eq \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma eq_elimL[elim]:
assumes "eq \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l" and "\<psi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma eq_elimR[elim]:
assumes "eq \<phi> \<psi> \<pi>l" and "\<psi> \<pi>l" and "\<phi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma eq_equals: "eq \<phi> \<psi> \<pi>l \<longleftrightarrow> \<phi> \<pi>l = \<psi> \<pi>l"
by (metis eq_elimL eq_elimR eq_intro)

text{* Quantifiers *}

lemma exi_intro[intro]:
assumes "wfp AP' \<pi>"
and "\<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l)"
and "\<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0"
and "F \<pi> \<pi>l"
shows "exi F \<pi>l"
using assms unfolding exi_def by auto

lemma exi_elim[elim]:
assumes "exi F \<pi>l"
and
"\<And> \<pi>. \<lbrakk>wfp AP' \<pi>; \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l); \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0; F \<pi> \<pi>l\<rbrakk> \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding exi_def by auto

lemma fall_intro[intro]:
assumes
"\<And> \<pi>. \<lbrakk>wfp AP' \<pi>; \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l) ; \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0\<rbrakk>
       \<Longrightarrow>  F \<pi> \<pi>l"
shows "fall F \<pi>l"
using assms unfolding fall_def by (metis exi_def neg_def)

lemma fall_elim[elim]:
assumes "fall F \<pi>l"
and
"(\<And>\<pi>. \<lbrakk>wfp AP' \<pi>; \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l); \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0\<rbrakk>
        \<Longrightarrow> F \<pi> \<pi>l)
  \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding fall_def
by (metis exi_def neg_elim neg_intro)

text{* Temporal connectives *}

lemma next_intro[intro]:
assumes "\<phi> (map stl \<pi>l)"  shows "next \<phi> \<pi>l"
using assms unfolding op_defs by auto

lemma next_elim[elim]:
assumes "next \<phi> \<pi>l" and "\<phi> (map stl \<pi>l) \<Longrightarrow> \<chi>"  shows \<chi>
using assms unfolding op_defs by auto

lemma until_introR[intro]:
assumes "\<psi> \<pi>l" shows "until \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by (auto intro: exI[of _ 0])

lemma until_introL[intro]:
assumes \<phi>: "\<phi> \<pi>l" and u: "until \<phi> \<psi> (map stl \<pi>l)"
shows "until \<phi> \<psi> \<pi>l"
proof-
  obtain i where \<psi>: "\<psi> (map (sdrop (Suc i)) \<pi>l)" and 1: "\<forall>j\<in>{0..<i}. \<phi> (map (sdrop (Suc j)) \<pi>l)"
  using u unfolding op_defs by auto
  {fix j assume "j \<in> {0..<Suc i}"
   hence "\<phi> (map (sdrop j) \<pi>l)" using 1 \<phi> by (cases j) auto
  }
  thus ?thesis using \<psi> unfolding op_defs by auto
qed

text{* The elimination rules for until and eventually are induction rules. *}

lemma until_induct[induct pred: until, consumes 1, case_names Base Step]:
assumes u: "until \<phi> \<psi> \<pi>l"
and b: "\<And> \<pi>l. \<psi> \<pi>l \<Longrightarrow> \<chi> \<pi>l"
and i: "\<And> \<pi>l. \<lbrakk>\<phi> \<pi>l; until \<phi> \<psi> (map stl \<pi>l); \<chi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi> \<pi>l"
shows "\<chi> \<pi>l"
proof-
  obtain i where \<psi>: "\<psi> (map (sdrop i) \<pi>l)" and 1:  "\<forall>j\<in>{0..<i}. \<phi> (map (sdrop j) \<pi>l)"
  using u unfolding until_def next_def by auto
  {fix k assume k: "k \<le> i"
   hence "until \<phi> \<psi> (map (sdrop k) \<pi>l) \<and> \<chi> (map (sdrop k) \<pi>l)"
   proof (induction "i-k" arbitrary: k)
     case 0 hence "k=i" by auto
     with b[OF \<psi>] u \<psi> show ?case by (auto intro: until_introR)
   next
     case (Suc ii)  let ?\<pi>l' = "map (sdrop k) \<pi>l"
     have "until \<phi> \<psi>  (map stl ?\<pi>l') \<and> \<chi> (map stl ?\<pi>l')" using Suc by auto
     moreover have "\<phi> ?\<pi>l'" using 1 Suc by auto
     ultimately show ?case using i by auto
   qed
  }
  from this[of 0] show ?thesis by simp
qed

lemma until_unfold:
"until \<phi> \<psi> \<pi>l = (\<psi> \<pi>l \<or> \<phi> \<pi>l \<and> until \<phi> \<psi> (map stl \<pi>l))" (is "?L = ?R")
proof
  assume ?L thus ?R by induct auto
qed auto

lemma ev_introR[intro]:
assumes "\<phi> \<pi>l" shows "ev \<phi> \<pi>l"
using assms unfolding ev_def by (auto intro: until_introR)

lemma ev_introL[intro]:
assumes "ev \<phi> (map stl \<pi>l)"  shows "ev \<phi> \<pi>l"
using assms unfolding ev_def by (auto intro: until_introL)

lemma ev_induct[induct pred: ev, consumes 1, case_names Base Step]:
assumes "ev \<phi> \<pi>l" and "\<And> \<pi>l. \<phi> \<pi>l \<Longrightarrow> \<chi> \<pi>l"
and "\<And> \<pi>l. \<lbrakk>ev \<phi> (map stl \<pi>l); \<chi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi> \<pi>l"
shows "\<chi> \<pi>l"
using assms unfolding ev_def by induct (auto simp: assms)

lemma ev_unfold:
"ev \<phi> \<pi>l = (\<phi> \<pi>l \<or> ev \<phi> (map stl \<pi>l))"
unfolding ev_def by (metis tr_intro until_unfold)

lemma ev: "ev \<phi> \<pi>l \<longleftrightarrow> (\<exists> i. \<phi> (map (sdrop i) \<pi>l))"
unfolding ev_def until_def by auto

text{* The introduction rules for always and weak until are coinduction rules. *}

lemma alw_coinduct[coinduct pred: alw, consumes 1, case_names Hyp]:
assumes "\<chi> \<pi>l"
and "\<And> \<pi>l. \<chi> \<pi>l \<Longrightarrow> alw \<phi> \<pi>l \<or> (\<phi> \<pi>l \<and> \<chi> (map stl \<pi>l))"
shows "alw \<phi> \<pi>l"
proof-
  {assume "ev (neg \<phi>) \<pi>l"
   hence "\<not> \<chi> \<pi>l"
   apply induct
   using assms unfolding op_defs by auto (metis assms alw_def ev_def neg_def until_introR)
  }
  thus ?thesis using assms unfolding op_defs by auto
qed

lemma alw_elim[elim]:
assumes "alw \<phi> \<pi>l"
and "\<lbrakk>\<phi> \<pi>l; alw \<phi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi>"
shows "\<chi>"
using assms unfolding alw_def by(auto elim: ev_introR simp: neg_def)

lemma alw_destL: "alw \<phi> \<pi>l \<Longrightarrow> \<phi> \<pi>l" by auto
lemma alw_destR: "alw \<phi> \<pi>l \<Longrightarrow> alw \<phi> (map stl \<pi>l)" by auto

lemma alw_unfold:
"alw \<phi> \<pi>l = (\<phi> \<pi>l \<and> alw \<phi> (map stl \<pi>l))"
by (metis alw_def ev_unfold neg_elim neg_intro)

lemma alw: "alw \<phi> \<pi>l \<longleftrightarrow> (\<forall> i. \<phi> (map (sdrop i) \<pi>l))"
unfolding alw_def ev neg_def by simp

lemma sdrop_imp_alw:
assumes "\<And> i. (\<And>j. j \<le> i \<Longrightarrow> \<phi> [sdrop j \<pi>, sdrop j \<pi>']) \<Longrightarrow> \<psi> [sdrop i \<pi>, sdrop i \<pi>']"
shows "imp (alw \<phi>) (alw \<psi>) [\<pi>, \<pi>']"
using assms by(auto simp: alw)

lemma wuntil_coinduct[coinduct pred: wuntil, consumes 1, case_names Hyp]:
assumes \<chi>: "\<chi> \<pi>l"
and 0: "\<And> \<pi>l. \<chi> \<pi>l \<Longrightarrow> \<psi> \<pi>l \<or> (\<phi> \<pi>l \<and> \<chi> (map stl \<pi>l))"
shows "wuntil \<phi> \<psi> \<pi>l"
proof-
  {assume "\<not> until \<phi> \<psi> \<pi>l \<and> \<chi> \<pi>l"
   hence "alw \<phi> \<pi>l"
   apply coinduct using 0 by (auto intro: until_introL until_introR)
  }
  thus ?thesis using \<chi> unfolding wuntil_def dis_def by auto
qed

lemma wuntil_elim[elim]:
assumes w: "wuntil \<phi> \<psi> \<pi>l"
and 1: "\<psi> \<pi>l \<Longrightarrow> \<chi>"
and 2: "\<lbrakk>\<phi> \<pi>l; wuntil \<phi> \<psi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi>"
shows \<chi>
proof(cases "alw \<phi> \<pi>l")
  case True
  thus ?thesis apply default using 2 unfolding wuntil_def by auto
next
  case False
  hence "until \<phi> \<psi> \<pi>l" using w unfolding wuntil_def dis_def by auto
  thus ?thesis by (metis assms dis_introL until_unfold wuntil_def)
qed

lemma wuntil_unfold:
"wuntil \<phi> \<psi> \<pi>l = (\<psi> \<pi>l \<or> \<phi> \<pi>l \<and> wuntil \<phi> \<psi> (map stl \<pi>l))"
by (metis alw_unfold dis_def until_unfold wuntil_def)

subsection{* More derived operators *}

text{* The conjunction of an arbitrary set of formulas: *}

definition scon ::
"('state,'aprop) sfmla set \<Rightarrow> ('state,'aprop) sfmla" where
"scon \<phi>s \<pi>l \<equiv> \<forall> \<phi> \<in> \<phi>s. \<phi> \<pi>l"

lemma mcon_intro[intro!]:
assumes "\<And> \<phi>. \<phi> \<in> \<phi>s \<Longrightarrow> \<phi> \<pi>l" shows "scon \<phi>s \<pi>l"
using assms unfolding scon_def by auto

lemma scon_elim[elim]:
assumes "scon \<phi>s \<pi>l" and "(\<And> \<phi>. \<phi> \<in> \<phi>s \<Longrightarrow> \<phi> \<pi>l) \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding scon_def by auto

text{* Double-binding forall: *}

definition "fall2 F \<equiv> fall (\<lambda> \<pi>. fall (F \<pi>))"

lemma fall2_intro[intro]:
assumes
"\<And> \<pi> \<pi>'. \<lbrakk>wfp AP' \<pi>; wfp AP' \<pi>';
           \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l);
           \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0;
           stateOf \<pi>' = stateOf \<pi>
          \<rbrakk>
       \<Longrightarrow>  F \<pi> \<pi>' \<pi>l"
shows "fall2 F \<pi>l"
using assms unfolding fall2_def by (auto intro!: fall_intro)

lemma fall2_elim[elim]:
assumes "fall2 F \<pi>l"
and
"(\<And>\<pi> \<pi>'. \<lbrakk>wfp AP' \<pi>; wfp AP' \<pi>';
           \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l); \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0;
           stateOf \<pi>' = stateOf \<pi>
          \<rbrakk>
          \<Longrightarrow> F \<pi> \<pi>' \<pi>l)
  \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding fall2_def by (auto elim!: fall_elim) (metis fall_elim)

(*<*)
end (* context Shallow *)
(*>*)

text{* end-of-context Shallow *}

(*<*)
end
(*>*)