(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
 * Verifying quicksort implementation using AutoCorres!
 *)
theory Quicksort
imports
  "../../AutoCorres"
  "~~/src/HOL/Library/Multiset"
begin

declare validNF_whileLoop_inv_measure_twosteps [wp]
declare validNF_whileLoopE_inv_measure_twosteps [wp]

declare creturn_def [vcg_simp]

install_C_file "quicksort.c"
autocorres "quicksort.c"

context quicksort begin

thm partition_body_def
thm quicksort_body_def

thm partition'_def
thm quicksort'.simps

(* Some rules for pointer addition *)

(* FIXME: move *)
lemma ptr_add_assoc [simp]:
  "p +\<^sub>p (i + j) = p +\<^sub>p i +\<^sub>p j"
  by (simp add: CTypesDefs.ptr_add_def distrib_right)

(* FIXME: move *)
lemma ptr_add_commute [simp]:
  "p +\<^sub>p i +\<^sub>p j = p +\<^sub>p j +\<^sub>p i"
  by (metis ptr_add_assoc add.commute)

(*
 * Array validity definitions
 *)

definition
  array_loc_valid :: "word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "array_loc_valid a n \<equiv>
   (unat (ptr_val a) + size_of TYPE(word32) * n \<le> 2 ^ len_of TYPE(32))"

fun
  array_elems_valid :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "array_elems_valid s a 0 = True" |
  "array_elems_valid s a (Suc n) = (is_valid_w32 s a \<and> array_elems_valid s (a +\<^sub>p 1) n)"

lemma array_all_elems_valid:
  (* equivalent characterisation of array validity *)
  "array_elems_valid s a n = (\<forall>m. m < n \<longrightarrow> is_valid_w32 s (a +\<^sub>p int m))"
  apply (induct n arbitrary: a)
   apply simp
  apply (case_tac "n = 0")
   apply simp
  apply (rule iffI)
   apply clarsimp
   apply (case_tac "m = 0")
    apply simp
   apply (case_tac "m = n")
    apply clarsimp
    apply (drule_tac x = "n - 1" in spec)
    apply (simp add: CTypesDefs.ptr_add_def)
   apply (drule_tac x = "m - 1" in spec)
   apply (simp add: CTypesDefs.ptr_add_def)
  apply simp
  apply (frule_tac x = "0" in spec)
  apply clarsimp
  apply (frule_tac x = "m + 1" in spec)
  apply simp
  done

definition
  is_array :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "is_array s a n \<equiv> (array_loc_valid a n \<and> array_elems_valid s a n)"

(* Necessary condition for many pointer comparison lemmas *)
definition array_not_at_mem_end :: "word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "array_not_at_mem_end a n \<equiv>
   (unat (ptr_val a) + size_of TYPE(word32) * n < 2 ^ len_of TYPE(32))"
  (* same as "array_loc_valid a n" but excluding equality *)

(* Some obvious but useful corollaries *)

lemma array_valid_elem:
  "\<lbrakk> is_array s a n; m < n \<rbrakk> \<Longrightarrow> is_valid_w32 s (a +\<^sub>p int m)"
  by (metis is_array_def array_all_elems_valid)

lemma array_valid_elem2:
  "\<lbrakk> is_array s a (unat n); m < n \<rbrakk> \<Longrightarrow> is_valid_w32 s (a +\<^sub>p uint m)"
  by (metis array_valid_elem uint_nat word_less_nat_alt)

lemma empty_array_is_array:
  "is_array s a 0"
  apply (insert unat_lt2p[of "ptr_val a"])
  apply (simp add: is_array_def array_loc_valid_def)
  done

lemma empty_array_not_at_mem_end:
  "array_not_at_mem_end a 0"
  apply (insert unat_lt2p[of "ptr_val a"])
  apply (simp add: array_not_at_mem_end_def)
  done

lemma subarray_not_at_mem_end1:
  "\<lbrakk> array_loc_valid a n; m < n \<rbrakk> \<Longrightarrow> array_not_at_mem_end a m"
  by (simp add: array_loc_valid_def array_not_at_mem_end_def)

lemma subarray_not_at_mem_end2:
  "\<lbrakk> is_array s a n; m < n \<rbrakk> \<Longrightarrow> array_not_at_mem_end a m"
  by (clarsimp simp: is_array_def subarray_not_at_mem_end1)

lemma updated_array_elems_valid [simp]:
  "array_elems_valid (heap_w32_update f s) a n = array_elems_valid s a n"
  by (induct n arbitrary: a, auto)

lemma updated_array_is_array [simp]:
  "is_array (heap_w32_update f s) a n = is_array s a n"
  by (simp add: is_array_def)

(* Some word arithmetic *)

(* FIXME: move *)
lemma unat_plus_weak:
  "(x::word32) \<le> x + y \<Longrightarrow> unat (x + y) = unat x + unat y"
  by (simp add: unat_plus_simple)

(* FIXME: move *)
lemma unat_mult_weak:
  "unat (x::word32) * unat y < 2 ^ len_of TYPE(32) \<Longrightarrow>
   unat (x * y) = unat x * unat y"
  by (simp add: unat_mult_lem[symmetric])

lemma unat_linear_over_array_loc:
  "array_not_at_mem_end a n \<Longrightarrow>
   unat (ptr_val a + of_nat (size_of TYPE(word32)) * (of_nat n)) =
   unat (ptr_val a) + size_of TYPE(word32) * n"
  apply (simp add: array_not_at_mem_end_def)
  apply (subgoal_tac "unat (4 * (of_nat n)) = 4 * n")
   apply (subst unat_plus_weak)
    apply (subst no_olen_add_nat)
    apply (rule_tac s = "4 * n" and t = "unat (4 * of_nat n)" in subst)
     apply (erule sym)
    apply simp+
  apply (simp add: unat_mult_weak unat_of_nat_eq)
  done

lemma unat_linear_over_array_loc2:
  "array_not_at_mem_end a n \<Longrightarrow>
   unat (ptr_val a + 4 * (of_nat n)) = unat (ptr_val a) + 4 * n"
  by (frule unat_linear_over_array_loc, simp)

(* Pointer inequalities *)

lemma array_no_wrap:
  "\<lbrakk> array_loc_valid a n; m < n \<rbrakk> \<Longrightarrow> a \<le> a +\<^sub>p int m"
  apply (clarsimp simp: array_loc_valid_def CTypesDefs.ptr_add_def
                        ptr_le_def' ptr_le_def)
  apply (subst no_olen_add_nat)
  apply (subst unat_mult_weak)
   apply (subst unat_of_nat_eq, simp+)+
  done

lemma array_no_wrap2:
  "\<lbrakk> array_loc_valid a (unat n); m < n \<rbrakk> \<Longrightarrow> a \<le> a +\<^sub>p uint m"
  by (metis array_no_wrap uint_nat word_less_nat_alt)

lemma array_loc_mono:
  "\<lbrakk> array_not_at_mem_end a n; m \<le> n \<rbrakk> \<Longrightarrow> a +\<^sub>p int m \<le> a +\<^sub>p int n"
  apply (clarsimp simp: array_not_at_mem_end_def CTypesDefs.ptr_add_def
                        ptr_le_def' ptr_le_def)
  apply (rule word_plus_mono_right)
   apply (rule word_mult_le_mono1)
     apply (rule PackedTypes.of_nat_mono_maybe_le, simp+)
   apply (subst unat_of_nat_eq, simp+)
  apply (subst no_olen_add_nat)
  apply (subst unat_mult_weak)
   apply (subst unat_of_nat_eq, simp+)+
  done

lemma array_loc_mono2:
  "\<lbrakk> array_not_at_mem_end a (unat n); m \<le> n \<rbrakk> \<Longrightarrow> a +\<^sub>p uint m \<le> a +\<^sub>p uint n"
  by (metis array_loc_mono uint_nat word_le_nat_alt)

lemma array_loc_strict_mono:
  "\<lbrakk> array_not_at_mem_end a n; m < n \<rbrakk> \<Longrightarrow> a +\<^sub>p int m < a +\<^sub>p int n"
  apply (clarsimp simp: array_not_at_mem_end_def CTypesDefs.ptr_add_def
                        ptr_less_def' ptr_less_def)
  apply (rule word_plus_strict_mono_right)
   apply (rule word_mult_less_mono1)
     apply (subst of_nat_mono_maybe, simp+)
   apply (subst unat_of_nat_eq, simp+)
  apply (subst no_olen_add_nat)
  apply (subst unat_mult_weak)
   apply (subst unat_of_nat_eq, simp+)+
  done

lemma array_loc_strict_mono2:
  "\<lbrakk> array_not_at_mem_end a (unat n); m < n \<rbrakk> \<Longrightarrow> a +\<^sub>p uint m < a +\<^sub>p uint n"
  by (metis array_loc_strict_mono uint_nat word_less_nat_alt)

(* Concatenation lemmas *)

lemma array_concat_elems_valid:
  "array_elems_valid s a (n + m) =
   (array_elems_valid s a n \<and> array_elems_valid s (a +\<^sub>p int n) m)"
  apply (subst array_all_elems_valid)+
  apply (rule iffI)
   apply clarsimp
   apply (frule_tac x = "n + ma" in spec)
   apply simp
  apply clarsimp
  apply (case_tac "ma < n")
   apply simp
  apply (frule_tac x = "ma - n" and
                   P = "\<lambda>ma. (ma < m \<longrightarrow> is_valid_w32 s (a +\<^sub>p int ma +\<^sub>p int n))"
                   in spec)
  apply (subgoal_tac "ma - n < m")
   apply (simp add: CTypesDefs.ptr_add_def)
  apply simp
  done

lemma is_array_concat:
  "\<lbrakk> m = 0 \<or> array_not_at_mem_end a n \<rbrakk> \<Longrightarrow>
   is_array s a (n + m) = (is_array s a n \<and> is_array s (a +\<^sub>p int n) m)"
  apply (erule disjE)
   apply (simp add: empty_array_is_array)
  apply (frule unat_linear_over_array_loc)
  apply (subgoal_tac "array_loc_valid a n")
   apply (simp add: is_array_def array_loc_valid_def
                    array_concat_elems_valid add.assoc conj_commute)
  apply (simp add: array_loc_valid_def array_not_at_mem_end_def)
  done

lemma is_array_concat2:
  "\<lbrakk> m \<le> n; array_not_at_mem_end a m \<or> m = n \<rbrakk> \<Longrightarrow>
   is_array s a n = (is_array s a m \<and> is_array s (a +\<^sub>p int m) (n - m))"
  apply (subst diff_add_inverse[symmetric, where n = "m"])
  apply (subst diff_add_assoc, assumption)
  apply (rule is_array_concat, force)
  done

lemma subarray1_is_array:
  "\<lbrakk> is_array s a n; m \<le> n \<rbrakk> \<Longrightarrow> is_array s a m"
  apply (case_tac "m = n", simp)
  apply (frule_tac m = "m" in subarray_not_at_mem_end2, simp)
  apply (simp add: is_array_concat2)
  done

lemma subarray2_is_array:
  "\<lbrakk> is_array s a n; m \<le> n; array_not_at_mem_end a m \<or> m = n \<rbrakk> \<Longrightarrow>
   is_array s (a +\<^sub>p int m) (n - m)"
  by (simp add: is_array_concat2)

lemma concat_is_array:
  "\<lbrakk> is_array s a m; is_array s (a +\<^sub>p int m) (n - m);
     m \<le> n; array_not_at_mem_end a m \<or> m = n \<rbrakk> \<Longrightarrow>
   is_array s a n"
  by (subst is_array_concat2[where m = "m"], simp_all)

(* Array contents, definitions and lemmas *)

primrec
  the_array :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> word32 list"
where
  "the_array s a 0 = []" |
  "the_array s a (Suc n) = (heap_w32 s a) # (the_array s (a +\<^sub>p 1) n)"

lemma the_array_length [simp]:
  "length (the_array s a n) = n"
  by (induct n arbitrary: a, auto)

lemma the_array_elem:
  "m < n \<Longrightarrow> the_array s a n ! m = heap_w32 s (a +\<^sub>p int m)"
  apply (induct n arbitrary: a m)
   apply simp
  apply (case_tac "m = 0")
   apply (auto simp: CTypesDefs.ptr_add_def)
  done

lemma the_arrays_equal:
  "(the_array s a n = the_array s' a' n) =
   (\<forall>m < n. heap_w32 s (a +\<^sub>p int m) = heap_w32 s' (a' +\<^sub>p int m))"
  by (simp add: list_eq_iff_nth_eq the_array_elem)

lemma the_array_concat:
  "the_array s a (n + m) = the_array s a n @ the_array s (a +\<^sub>p int n) m"
  by (induct n arbitrary: a m, auto)

lemma the_array_concat2:
  "m \<le> n \<Longrightarrow>
   the_array s a n = the_array s a m @ the_array s (a +\<^sub>p int m) (n - m)"
  apply (subst diff_add_inverse[symmetric, where n = "m"])
  apply (subst diff_add_assoc)
  apply (simp_all only: the_array_concat)
  done

(* Pointer simplification rules *)

(* FIXME: move *)
lemma word32_mult_cancel_right:
  fixes a :: "word32" and b :: "word32" and c :: "word32"
  shows
  "\<lbrakk> unat a * unat c < 2 ^ len_of TYPE(32);
     unat b * unat c < 2 ^ len_of TYPE(32); c \<noteq> 0 \<rbrakk> \<Longrightarrow>
   (a * c = b * c) = (a = b)"
  apply (rule iffI)
   apply simp_all
  apply (subgoal_tac "a = a * c div c")
   apply simp
   apply (rule sym)
   apply (rule Word.word_div_mult[symmetric, where 'a = 32],
          unat_arith, simp)+
  done

lemma ptr_offsets_eq [simp]:
  fixes i :: "nat" and j :: "nat" and a :: "word32 ptr"
  shows
  "\<lbrakk> i * size_of TYPE(word32) < 2 ^ len_of TYPE(32);
     j * size_of TYPE(word32) < 2 ^ len_of TYPE(32) \<rbrakk> \<Longrightarrow>
   (a +\<^sub>p int i = a +\<^sub>p int j) = (i = j)"
  by (simp add: CTypesDefs.ptr_add_def word32_mult_cancel_right
                unat_of_nat_eq of_nat_inj)

lemma ptr_offsets_eq2 [simp]:
  fixes i :: "word32" and j :: "word32" and a :: "word32 ptr"
  shows
  "\<lbrakk> unat i * size_of TYPE(word32) < 2 ^ len_of TYPE(32);
     unat j * size_of TYPE(word32) < 2 ^ len_of TYPE(32) \<rbrakk> \<Longrightarrow>
   (a +\<^sub>p uint i = a +\<^sub>p uint j) = (i = j)"
  by (simp add: uint_nat)

(* Array update simplification *)

(* FIXME: move? *)
lemma trivial_heap_update [simp]:
  "heap_w32_update (\<lambda>x. x) s = s"
  by simp

lemma the_updated_array:
  "\<lbrakk> is_array s p n; m < n \<rbrakk> \<Longrightarrow>
   the_array (heap_w32_update (\<lambda>h q. if q = p +\<^sub>p int m then x else f h q) s) p n =
   (the_array (heap_w32_update f s) p n)[m := x]"
  by (auto simp: is_array_def array_loc_valid_def the_array_elem
           intro: nth_equalityI)

lemma multiset_of_cycle:
  (* Courtesy of Dave G *)
  "\<lbrakk> i < length ls; j < length ls; k < length ls; i = k \<Longrightarrow> ls ! i = ls ! j \<rbrakk> \<Longrightarrow>
   multiset_of (ls[i := (ls ! j), j := ls ! k, k := ls ! i]) = multiset_of ls"
  apply (subst (2) multiset_of_swap[symmetric, where i = j and j = i], assumption+)
  apply (subst (2) multiset_of_swap[symmetric, where i = j and j = k], simp+)
  apply (clarsimp simp: nth_list_update)
  apply (metis list_update_overwrite list_update_swap)
  done

(* Defining sanity of program, i.e. that only the array can change,
   and some related lemmas *)

definition unmodified_outside_range ::
             "lifted_globals \<Rightarrow> lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "unmodified_outside_range s s' a n \<equiv>
   (\<forall>p. (p < a \<or> (array_not_at_mem_end a n \<and> p \<ge> a +\<^sub>p int n)) \<longrightarrow>
        (is_valid_w32 s' p = is_valid_w32 s p \<and> heap_w32 s' p = heap_w32 s p))"

lemma unmodified_outside_range_refl [simp]:
  "unmodified_outside_range s s a n"
  by (simp add: unmodified_outside_range_def)

lemma unmodified_outside_range_trans:
  "\<lbrakk> unmodified_outside_range s1 s2 a n; unmodified_outside_range s2 s3 a n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s1 s3 a n"
  by (simp add: unmodified_outside_range_def)

lemma unmodified_outside_empty_range:
  "unmodified_outside_range s s' p 0
   \<Longrightarrow> \<forall>p. (is_valid_w32 s' p = is_valid_w32 s p \<and>
            heap_w32 s' p = heap_w32 s p)"
  apply (clarsimp simp: unmodified_outside_range_def empty_array_not_at_mem_end)
  apply (case_tac "pa < p", simp+)
  done

lemma unmodified_outside_empty_range2:
  "\<lbrakk> unmodified_outside_range s s' p 0; array_loc_valid a n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s s' a n"
  apply (clarsimp simp: unmodified_outside_range_def empty_array_not_at_mem_end)
  apply (case_tac "pa < p", simp+)
  done

lemma unmodified_outside_subrange1:
  "\<lbrakk> array_loc_valid a n; unmodified_outside_range s s' a m; m \<le> n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s s' a n"
  apply (unfold unmodified_outside_range_def)
  apply clarsimp
  apply (subgoal_tac "array_not_at_mem_end a m \<and> a +\<^sub>p int m \<le> p", simp)
  apply (simp add: array_not_at_mem_end_def)
  apply (rule_tac y = "a +\<^sub>p int n" in order_trans)
   apply (simp add: array_loc_mono array_not_at_mem_end_def)
  apply assumption
  done

lemma unmodified_outside_subrange2:
  "\<lbrakk> array_loc_valid a n;
     unmodified_outside_range s s' (a +\<^sub>p int m) (n - m); m \<le> n \<rbrakk>
   \<Longrightarrow> unmodified_outside_range s s' a n"
  apply (case_tac "m = n", simp)
   apply (rule_tac p = "a +\<^sub>p int n" in unmodified_outside_empty_range2, assumption+)
  apply (unfold unmodified_outside_range_def)
  apply clarsimp
  apply (simp add: ptr_add_assoc[symmetric])
  apply (rule conjI)
   apply clarsimp
   apply (frule_tac z = "a +\<^sub>p int m" in order_less_le_trans)
    apply (simp add: array_no_wrap)
   apply simp
  apply (auto simp: array_not_at_mem_end_def unat_linear_over_array_loc2)
  done

(* Sanity in terms of arrays not changing *)

lemma is_still_array:
  "\<lbrakk> unmodified_outside_range s s' a n;
     (array_not_at_mem_end a' n' \<and> a' +\<^sub>p int n' \<le> a) \<or>
     (array_not_at_mem_end a n \<and> a +\<^sub>p int n \<le> a') \<or> n = 0;
     is_array s a' n' \<rbrakk> \<Longrightarrow> is_array s' a' n'"
  apply (clarsimp simp: unmodified_outside_range_def is_array_def
                        array_all_elems_valid)
  apply (drule_tac x = "m" in spec, clarsimp)
  apply (drule_tac R = "is_valid_w32 s' (a' +\<^sub>p int m)" in disjE, simp_all)
   apply clarsimp
   apply (subgoal_tac "a' +\<^sub>p int m < a", simp)
   apply (rule_tac y = "a' +\<^sub>p int n'" in less_le_trans)
    apply (rule array_loc_strict_mono, assumption+)
  apply (drule_tac R = "is_valid_w32 s' (a' +\<^sub>p int m)" in disjE, simp_all)
   apply clarsimp
   apply (subgoal_tac "a +\<^sub>p int n \<le> a' +\<^sub>p int m", simp)
   apply (erule_tac y = "a'" in order_trans)
   apply (rule_tac n = "n'" in array_no_wrap, assumption+)
  apply (case_tac "a' +\<^sub>p int m < a", simp)
  apply (simp add: empty_array_not_at_mem_end)
  done

lemma the_same_array:
  "\<lbrakk> unmodified_outside_range s s' a n; array_loc_valid a' n';
     (array_not_at_mem_end a' n' \<and> a' +\<^sub>p int n' \<le> a) \<or>
     (array_not_at_mem_end a n \<and> a' \<ge> a +\<^sub>p int n) \<or> n = 0 \<rbrakk> \<Longrightarrow>
   the_array s' a' n' = the_array s a' n'"
  apply (clarsimp simp: unmodified_outside_range_def the_arrays_equal)
  apply (drule_tac R = "heap_w32 s' (a' +\<^sub>p int m) = heap_w32 s (a' +\<^sub>p int m)"
                in disjE)
    apply simp_all
   apply clarsimp
   apply (subgoal_tac "a' +\<^sub>p int m < a", simp)
   apply (rule_tac y = "a' +\<^sub>p int n'" in less_le_trans)
    apply (rule array_loc_strict_mono, assumption+)
  apply (drule_tac R = "heap_w32 s' (a' +\<^sub>p int m) = heap_w32 s (a' +\<^sub>p int m)"
                in disjE)
    apply simp_all
   apply (subgoal_tac "a +\<^sub>p int n \<le> a' +\<^sub>p int m", simp)
   apply clarsimp
   apply (erule_tac y = "a'" in order_trans)
   apply (rule_tac n = "n'" in array_no_wrap, assumption+)
  apply (case_tac "a' +\<^sub>p int m < a", simp)
  apply (simp add: empty_array_not_at_mem_end)
  done

(*
 * Proof of partition function!
 *)

definition partitioned
where
  "partitioned s a n pivot_idx \<equiv>
   (\<forall>i. i < n \<longrightarrow> (i < pivot_idx \<longleftrightarrow> heap_w32 s (a +\<^sub>p int i) < heap_w32 s (a +\<^sub>p int pivot_idx)))"

lemma partition_correct:
  "\<forall>s0. \<lbrace> \<lambda>s. is_array s a (unat n) \<and> n > 0 \<and> s = s0 \<rbrace>
   partition' a n
   \<lbrace> \<lambda>r s. is_array s a (unat n) \<and>
           multiset_of (the_array s a (unat n)) = multiset_of (the_array s0 a (unat n)) \<and>
           r < n \<and> partitioned s a (unat n) (unat r) \<and>
           unmodified_outside_range s0 s a (unat n) \<rbrace>!"
  apply clarsimp
  apply (unfold partition'_def)
  apply (subst whileLoop_add_inv [where
         I = "\<lambda>(i, pivot_idx) s. is_array s a (unat n) \<and>
                                 multiset_of (the_array s a (unat n)) =
                                 multiset_of (the_array s0 a (unat n)) \<and>
                                 i \<le> n \<and> pivot_idx < i \<and>
                                 partitioned s a (unat i) (unat pivot_idx) \<and>
                                 unmodified_outside_range s0 s a (unat n)" and
         M = "\<lambda>((i, pivot_idx), s). n - i"])

  apply wp
     apply clarsimp
     apply (intro conjI impI)
                 defer
                apply unat_arith
                apply unat_arith
               defer defer
              apply (erule_tac n = "n" in array_valid_elem2, unat_arith)
              apply (rule_tac n = "n" in array_valid_elem2, assumption+)
             apply (erule_tac n = "n" in array_valid_elem2, unat_arith)
            apply unat_arith
           apply unat_arith
          apply (unfold partitioned_def)
          apply clarsimp
          apply (case_tac "i = unat aa")
           apply (simp add: uint_nat, unat_arith)
          apply (subgoal_tac "i < unat aa", simp)
          apply unat_arith
         apply (rule_tac n = "n" in array_valid_elem2, assumption+)
        apply (erule_tac n = "n" in array_valid_elem2, unat_arith)
       apply wp
       apply clarsimp
       apply (intro conjI impI)
        apply unat_arith
       apply unat_arith
      apply clarsimp
     apply clarsimp
     apply unat_arith
    defer
    apply (clarsimp simp: is_array_def array_loc_valid_def uint_nat)
    apply (intro conjI impI allI)
              apply simp
             apply (simp add: CTypesDefs.ptr_add_def)
            apply (simp add: CTypesDefs.ptr_add_def)
           apply (simp add: CTypesDefs.ptr_add_def)
          apply unat_arith
         apply (simp add: CTypesDefs.ptr_add_def)
        apply (subst (asm) (2) ptr_offsets_eq)
          apply (simp, unat_arith)
         apply (simp, unat_arith)
        apply (simp, unat_arith)
       apply (subst (asm) ptr_offsets_eq, simp, unat_arith, simp, unat_arith)+
       apply simp
      apply (subst (asm) (3) ptr_offsets_eq)
        apply (simp, unat_arith)
       apply (simp, unat_arith)
      apply (subst (asm) ptr_offsets_eq, simp, unat_arith, simp, unat_arith)+
      apply clarsimp
      apply (drule_tac x = "unat (b + 1)" in spec)
      apply (subgoal_tac "unat (b + 1) < unat aa")
       apply clarsimp
       apply (subgoal_tac "\<not> unat (b + 1) < unat b")
        apply (subgoal_tac "\<not> unat aa < unat (b + 1)", simp)
        apply simp
       apply unat_arith
      apply unat_arith
     apply (subst (asm) (4) ptr_offsets_eq)
       apply (simp, unat_arith)
      apply (simp, unat_arith)
     apply simp
    apply (subst (asm) ptr_offsets_eq, simp, unat_arith, simp, unat_arith)+
    apply clarsimp
    apply (drule_tac x = "i" in spec)
 (* apply (metis (hide_lams, mono_tags) Suc_eq_plus1_left Suc_le_D inc_i le_iff_add
                 le_step less_eq_Suc_le less_le_trans olen_add_eqv unat_1 unat_mono
                 word_le_nat_alt) *)
    apply (subgoal_tac "i < unat aa")
     apply clarsimp
     apply (subgoal_tac "(i < unat b) = (i < unat (b + 1))", simp)
     apply unat_arith
    apply unat_arith
   defer
   apply (simp add: o_def)
   apply (subst uint_nat, subst the_updated_array, assumption, unat_arith)+
   apply (clarsimp simp: is_array_def array_loc_valid_def)
   apply (intro conjI impI)
    apply (subst (asm) ptr_offsets_eq2, simp, unat_arith, simp, unat_arith)
    apply simp
   apply (simp only: uint_nat)
   apply (subst the_array_elem[symmetric, where n = "unat n"], unat_arith)+
   apply (subst multiset_of_cycle)
       apply (simp, unat_arith)
      apply (simp, unat_arith)
     apply (simp, unat_arith)
    apply simp+
  apply (clarsimp simp: is_array_def unmodified_outside_range_def)
  apply (intro conjI impI)
           apply (subst (asm) ptr_offsets_eq2)
             apply simp+
         apply (subgoal_tac "a \<le> a +\<^sub>p uint b", simp)
         apply (rule_tac n = "n" in array_no_wrap2, simp, unat_arith)
        apply clarsimp
        apply (subgoal_tac "a +\<^sub>p uint b < a +\<^sub>p uint n", simp add: uint_nat)
        apply (erule_tac n = "n" in array_loc_strict_mono2, unat_arith)
       apply (subgoal_tac "a \<le> a +\<^sub>p uint (b + 1)", simp)
       apply (erule_tac n = "n" in array_no_wrap2, unat_arith)
      apply clarsimp
      apply (subgoal_tac "a +\<^sub>p uint aa < a +\<^sub>p uint n", simp add: uint_nat)
      apply (rule_tac n = "n" in array_loc_strict_mono2, assumption+)
     apply (subgoal_tac "a \<le> a +\<^sub>p uint aa", simp)
     apply (rule_tac n = "n" in array_no_wrap2, assumption+)
    apply clarsimp
    apply (subgoal_tac "a +\<^sub>p uint aa < a +\<^sub>p uint n", simp add: uint_nat)
    apply (rule_tac n = "n" in array_loc_strict_mono2, assumption+)
   apply (subgoal_tac "a \<le> a +\<^sub>p uint (b + 1)", simp)
   apply (erule_tac n = "n" in array_no_wrap2, unat_arith)
  apply clarsimp
  apply (subgoal_tac "a +\<^sub>p uint (b + 1) < a +\<^sub>p uint n", simp add: uint_nat)
  apply (erule_tac n = "n" in array_loc_strict_mono2, unat_arith)
  done

(* Induction rule used for quicksort proof *)
lemma word_strong_induct[case_names Ind]:
  "(\<And>n. (\<forall>k < n. P k) \<Longrightarrow> P n) \<Longrightarrow> P (m::word32)"
  by (rule less_induct, blast)

(* Some extra Hoare logic rules *)

lemma when_True:
  "P \<Longrightarrow> when P A = A"
  by monad_eq

lemma when_False:
  "\<not> P \<Longrightarrow> when P A = return ()"
  by monad_eq

lemma hoare_save_pre_state:
  "(\<And>s'. P s' \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> s = s' \<rbrace> f \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
  by (clarsimp simp: valid_def)

lemma validNF_save_pre_state:
  "(\<And>s'. P s' \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> s = s' \<rbrace> f \<lbrace>Q\<rbrace>!) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!"
  by (auto simp: validNF_def valid_def no_fail_def)

lemma is_array_after_changing_left:
  "\<lbrakk> m \<le> n; is_array s1 a n; is_array s2 a m;
     unmodified_outside_range s1 s2 a m \<rbrakk>
   \<Longrightarrow> is_array s2 a n"
  apply (case_tac "m = n", simp)
  apply (frule_tac m = "m" in subarray_not_at_mem_end2, simp)
  apply (erule_tac m = "m" in concat_is_array)
    apply (auto simp: is_still_array subarray2_is_array)
  done

lemma is_array_after_changing_right:
  "\<lbrakk> m \<le> n; is_array s1 a n; is_array s2 (a +\<^sub>p int m) (n - m);
     unmodified_outside_range s1 s2 (a +\<^sub>p int m) (n - m) \<rbrakk>
   \<Longrightarrow> is_array s2 a n"
  apply (case_tac "m = n")
   apply (simp add: is_array_def array_all_elems_valid unmodified_outside_empty_range)
  apply (frule_tac m = "m" in subarray_not_at_mem_end2, simp)
  apply (rule_tac m = "m" in concat_is_array)
     apply (rule_tac s = "s1" and a = "a +\<^sub>p int m" and n = "n - m" in is_still_array)
       apply simp+
     apply (rule_tac n = "n" in subarray1_is_array)
      apply simp+
  done

(*
 * There is an issue later on with using "subst" substitutions on expressions
 * involving certain variables, so we have to use "rule_tac" with rules like
 * the following.
 *)
lemma multiset_of_concat_array:
  "\<lbrakk> m \<le> n; multiset_of (the_array s a m) = multiset_of (the_array s' a m);
     multiset_of (the_array s (a +\<^sub>p int m) (n - m)) = multiset_of (the_array s' (a +\<^sub>p int m) (n - m)) \<rbrakk>
   \<Longrightarrow> multiset_of (the_array s a n) = multiset_of (the_array s' a n)"
  by (simp add: the_array_concat2)

lemma multiset_same_after_shuffling_left:
  "\<lbrakk> m \<le> n; array_loc_valid a n;
     multiset_of (the_array s1 a m) = multiset_of (the_array s2 a m);
     unmodified_outside_range s1 s2 a m \<rbrakk>
   \<Longrightarrow> multiset_of (the_array s1 a n) = multiset_of (the_array s2 a n)"
  apply (case_tac "m = n", simp)
  apply (frule_tac m = "m" in subarray_not_at_mem_end1, simp)
  apply (rule_tac m = "m" in multiset_of_concat_array, assumption+)
  apply (subgoal_tac "the_array s2 (a +\<^sub>p int m) (n - m) =
                      the_array s1 (a +\<^sub>p int m) (n - m)", simp)
  apply (erule_tac a = "a" and n = "m" in the_same_array)
   apply (clarsimp simp: is_array_def array_loc_valid_def
                         unat_linear_over_array_loc2, unat_arith)
  apply simp
  done

lemma multiset_same_after_shuffling_right:
  "\<lbrakk> m \<le> n; array_loc_valid a n;
     multiset_of (the_array s1 (a +\<^sub>p int m) (n - m)) =
     multiset_of (the_array s2 (a +\<^sub>p int m) (n - m));
     unmodified_outside_range s1 s2 (a +\<^sub>p int m) (n - m) \<rbrakk>
   \<Longrightarrow> multiset_of (the_array s1 a n) = multiset_of (the_array s2 a n)"
  apply (rule_tac m = "m" in multiset_of_concat_array)
    apply assumption
   apply (subgoal_tac "the_array s2 a m = the_array s1 a m", simp)
   apply (case_tac "m = n")
    apply (simp add: unmodified_outside_empty_range the_arrays_equal)
   apply (frule_tac m = "m" in subarray_not_at_mem_end1, simp)
   apply (rule_tac a = "a +\<^sub>p int m" and n = "n - m" in the_same_array)
    apply (auto simp: array_not_at_mem_end_def array_loc_valid_def)
  done

(* Preparing for lemmas about partitioned-ness being preserved *)

lemma old_array_elem:
  "\<lbrakk> multiset_of (the_array s a n) =
     multiset_of (the_array s0 a n); i < n \<rbrakk>
   \<Longrightarrow> \<exists>j < n. heap_w32 s (a +\<^sub>p int i) = heap_w32 s0 (a +\<^sub>p int j)"
  apply (drule multiset_of_eq_setD)
  apply (subgoal_tac "heap_w32 s (a +\<^sub>p int i) \<in> set (the_array s a n)")
   apply simp
   apply (frule nth_the_index)
   apply (rule_tac x = "the_index (the_array s0 a n) (heap_w32 s (a +\<^sub>p int i))"
          in exI)
   apply (rule conjI)
    apply (subst (4) the_array_length[symmetric, where s = "s0" and a = "a"])
    apply (erule the_index_bounded)
   apply (subst (asm) the_array_elem)
    apply (subst (4) the_array_length[symmetric, where s = "s0" and a = "a"])
    apply (erule the_index_bounded)
   apply simp
  apply (subst the_array_elem[symmetric, where n = "n"], assumption)
  apply (rule nth_mem, simp)
  done

lemma old_array_elem2:
  "\<lbrakk> multiset_of (the_array s (a +\<^sub>p int k) (n - k)) =
     multiset_of (the_array s0 (a +\<^sub>p int k) (n - k)); k + i < n \<rbrakk>
   \<Longrightarrow> \<exists>j < n. j \<ge> k \<and> heap_w32 s (a +\<^sub>p int (k + i)) = heap_w32 s0 (a +\<^sub>p int j)"
  apply (drule_tac i = "i" in old_array_elem, simp)
  apply clarsimp
  apply (rule_tac x = "k + j" in exI)
  apply simp
  done

lemma partitioned_after_shuffling_left:
  "\<lbrakk> is_array s0 a (unat n); pivot_idx < n;
     partitioned s0 a (unat n) (unat pivot_idx);
     multiset_of (the_array s a (unat pivot_idx)) =
     multiset_of (the_array s0 a (unat pivot_idx));
     unmodified_outside_range s0 s a (unat pivot_idx) \<rbrakk>
   \<Longrightarrow> partitioned s a (unat n) (unat pivot_idx)"
  apply (clarsimp simp: partitioned_def unmodified_outside_range_def)
  apply (subgoal_tac "heap_w32 s (a +\<^sub>p uint pivot_idx) =
                      heap_w32 s0 (a +\<^sub>p uint pivot_idx)", simp add: uint_nat)
   apply (subgoal_tac "array_not_at_mem_end a (unat pivot_idx)")
    apply (case_tac "i < unat pivot_idx", clarsimp)
     apply (subgoal_tac "\<exists>j. (j < unat pivot_idx \<and>
                              heap_w32 s (a +\<^sub>p int i) = heap_w32 s0 (a +\<^sub>p int j))")
      apply clarsimp
      apply (drule_tac x = "j" in spec)
      apply (subgoal_tac "j < unat n")
       apply (clarsimp simp: uint_nat)
      apply unat_arith
     apply (erule old_array_elem, simp)
    apply (drule_tac x = "a +\<^sub>p int i" in spec)
    apply (subgoal_tac "a +\<^sub>p int (unat pivot_idx) \<le> a +\<^sub>p int i")
     apply simp
    apply (rule array_loc_mono)
     apply (rule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2,
            assumption+)
    apply unat_arith
   apply (erule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2,
          unat_arith)
  apply (drule_tac x = "a +\<^sub>p uint pivot_idx" in spec)
  apply (subgoal_tac "array_not_at_mem_end a (unat pivot_idx)")
   apply (simp add: uint_nat)
  apply (erule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2,
         unat_arith)
  done

lemma partitioned_after_shuffling_right:
  "\<lbrakk> is_array s0 a (unat n); pivot_idx < n;
     partitioned s0 a (unat n) (unat pivot_idx);
     multiset_of (the_array s (a +\<^sub>p int (Suc (unat pivot_idx)))
                              (unat n - Suc (unat pivot_idx))) =
     multiset_of (the_array s0 (a +\<^sub>p int (Suc (unat pivot_idx)))
                               (unat n - Suc (unat pivot_idx)));
     unmodified_outside_range s0 s (a +\<^sub>p int (Suc (unat pivot_idx)))
                                   (unat n - unat pivot_idx - 1) \<rbrakk>
   \<Longrightarrow> partitioned s a (unat n) (unat pivot_idx)"
  apply (unfold partitioned_def)
  apply (case_tac "unat n = Suc (unat pivot_idx)")
   apply (simp add: unmodified_outside_empty_range)
  apply (subgoal_tac "Suc (unat pivot_idx) < unat n")
   prefer 2
   apply unat_arith
  apply (subgoal_tac "array_not_at_mem_end a (Suc (unat pivot_idx))")
   prefer 2
   apply (rule_tac s = "s0" and n = "unat n" in subarray_not_at_mem_end2)
    apply assumption+
  apply (unfold unmodified_outside_range_def, clarify)
  apply (frule_tac x = "a +\<^sub>p int (unat pivot_idx)" in spec)
  apply (subgoal_tac "a +\<^sub>p int (unat pivot_idx) < a +\<^sub>p int (Suc (unat pivot_idx))")
   prefer 2
   apply (erule array_loc_strict_mono, simp)
  apply (case_tac "i \<le> unat pivot_idx")
   apply (frule_tac x = "a +\<^sub>p int i" in spec)
   apply (subgoal_tac "a +\<^sub>p int i < a +\<^sub>p int (Suc (unat pivot_idx))")
     apply (simp add: uint_nat)
    apply (erule array_loc_strict_mono, simp)
  apply (subgoal_tac "\<not> i < unat pivot_idx")
   prefer 2
   apply unat_arith
  apply (drule_tac i = "i - Suc (unat pivot_idx)" in old_array_elem2)
   apply unat_arith
  apply clarify
  apply (frule_tac x = "j" in spec)
  apply (subgoal_tac "\<not> j < unat pivot_idx")
   apply (subgoal_tac "a +\<^sub>p 1 +\<^sub>p int (unat pivot_idx) +\<^sub>p
                       int (i - Suc (unat pivot_idx)) = a +\<^sub>p int i")
    apply simp
   apply (subst zdiff_int[symmetric], unat_arith)
   apply (subst ptr_add_assoc[symmetric])+
   apply simp
  apply unat_arith
  done

(*
 * The basic idea of quicksort: if the array is partitioned and
 * both halves are sorted then the array is sorted.
 *)

lemma partitioned_array_sorted:
  "\<lbrakk> m < n; sorted (the_array s a m);
     sorted (the_array s (a +\<^sub>p int (Suc m)) (n - Suc m));
     partitioned s a n m \<rbrakk> \<Longrightarrow>
   sorted (the_array s a n)"
  apply (subst the_array_concat2[where m = "m"], simp)
  apply (subst sorted_append, simp)
  apply (rule conjI)
   apply (subst the_array_concat2[where m = "1"], simp+)
   apply (subst sorted_Cons)
   apply (simp add: partitioned_def)
   apply (subst all_set_conv_all_nth)
   apply (clarsimp simp: the_array_elem)
   apply (drule_tac x = "m + i + 1" in spec)
   apply (subgoal_tac "m + i + 1 < n")
    apply clarsimp
    apply unat_arith
   apply unat_arith
  apply (subst all_set_conv_all_nth)
  apply (clarsimp simp: the_array_elem partitioned_def)
  apply (frule_tac x = "i" in spec)
  apply simp
  apply (subgoal_tac "x \<ge> heap_w32 s (a +\<^sub>p int m)")
   apply simp
  apply (frule nth_the_index)
  apply (subst (asm) the_array_elem)
  apply (frule the_index_bounded, simp)
  apply (subgoal_tac "m + the_index (the_array s (a +\<^sub>p int m) (n - m)) x < n")
   apply (frule_tac x = "m + the_index (the_array s (a +\<^sub>p int m) (n - m)) x"
          in spec)
   apply simp
  apply (subgoal_tac "the_index (the_array s (a +\<^sub>p int m) (n - m)) x < n - m")
   apply simp
  apply (frule the_index_bounded, simp)
  done

(* Some more trivial lemmas *)

lemma array_index_Suc:
  "a +\<^sub>p uint m +\<^sub>p 1 = a +\<^sub>p int (Suc (unat m))"
  by (simp add: uint_nat)

lemma array_loc_le_Suc:
  "array_not_at_mem_end a (Suc (unat m)) \<Longrightarrow> a +\<^sub>p int (unat m) \<le> a +\<^sub>p 1 +\<^sub>p uint m"
  apply (subst ptr_add_commute)
  apply (subst array_index_Suc)
  apply (rule array_loc_mono, simp+)
  done

lemma unat_sub_sub1 [simp]:
  "(m::word32) < n \<Longrightarrow> unat (n - m - 1) = unat n - unat m - 1"
  by unat_arith

lemma unat_inc:
  "(m::word32) < n \<Longrightarrow> unat (m + 1) = Suc (unat m)"
  by unat_arith

(*
lemma old_quicksort_correct:
  shows "\<lbrace> \<lambda>s. is_array s a (unat n) \<and> s = s0 \<and> unat n < m \<rbrace>
         quicksort' m a n
         \<lbrace> \<lambda>r s. is_array s a (unat n) \<and>
                 multiset_of (the_array s a (unat n)) =
                 multiset_of (the_array s0 a (unat n)) \<and>
                 sorted (the_array s a (unat n)) \<and>
                 unmodified_outside_range s0 s a (unat n) \<rbrace>!"
   ( is "\<lbrace> ?pre a n s0 m \<rbrace> quicksort' m a n \<lbrace> ?post a n s0 \<rbrace>!" )
*)

(* FIXME: move *)
(* This puts our {partition,quicksort}_correct lemmas into a form that
   wp can use. *)
lemma make_schematic_post:
  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>!) \<Longrightarrow>
   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>!"
  by (auto simp add: valid_def validNF_def no_fail_def split: prod.splits)

(*
 * Proof of recursive quicksort function!
 *)

lemma quicksort_correct:
  shows "\<forall>a m s0. \<lbrace> \<lambda>s. is_array s a (unat n) \<and> s = s0 \<and> unat n < m \<rbrace>
         quicksort' m a n
         \<lbrace> \<lambda>r s. is_array s a (unat n) \<and>
                 multiset_of (the_array s a (unat n)) =
                 multiset_of (the_array s0 a (unat n)) \<and>
                 sorted (the_array s a (unat n)) \<and>
                 unmodified_outside_range s0 s a (unat n) \<rbrace>!"
   ( is "\<forall>a m s0. \<lbrace> ?pre a n s0 m \<rbrace> quicksort' m a n \<lbrace> ?post a n s0 \<rbrace>!" )

proof (induct n rule: word_strong_induct)
  fix a m s0

next
  fix a n m s0
  assume quicksort_ind_hyp:
    "\<forall>k < n. \<forall>a m s0. \<lbrace> ?pre a k s0 m \<rbrace> quicksort' m a k \<lbrace> ?post a k s0 \<rbrace>!"

  have quicksort_ind_hyp':
    "\<And>k a m. \<forall>s0. \<lbrace> \<lambda>s. ?pre a k s0 m s \<and> k < n \<rbrace> quicksort' m a k \<lbrace> ?post a k s0 \<rbrace>!"
    apply clarsimp
    apply (rule validNF_assume_pre)
    apply (rule validNF_chain)
      apply (rule quicksort_ind_hyp [rule_format])
      apply auto
    done

  show "\<forall>a m s0. \<lbrace> ?pre a n s0 m \<rbrace> quicksort' m a n \<lbrace> ?post a n s0 \<rbrace>!"
    apply clarsimp
    apply (subst quicksort'.simps)
    apply (unfold when_def)
    apply (wp quicksort_ind_hyp' [THEN make_schematic_post]
              partition_correct  [THEN make_schematic_post])
    apply clarsimp
    apply safe
              apply unat_arith
             apply (erule subarray1_is_array, unat_arith)
            apply unat_arith
           apply (case_tac "unat n = Suc (unat rv)", simp add: empty_array_is_array)
           (* Add a few useful facts into the assumption set *)
           apply (frule_tac s = "s'" and m = "unat rv" in subarray_not_at_mem_end2, unat_arith)
           apply (frule_tac s = "s'" and m = "Suc (unat rv)" in subarray_not_at_mem_end2, unat_arith)
           apply (frule_tac s = "s'" and m = "unat rv" in subarray1_is_array, unat_arith)
           apply (frule_tac s = "s'" and m = "unat rv" in subarray2_is_array, unat_arith, simp)
           apply (frule_tac s = "s'" and m = "Suc (unat rv)" in subarray1_is_array, unat_arith)
           apply (frule_tac s = "s'" and m = "Suc (unat rv)" in subarray2_is_array,
                  unat_arith, simp)
           (* ...and back to the proof *)
           apply (erule is_still_array)
            apply (rule disjI2, rule disjI1)
            apply (simp add: array_loc_le_Suc)
           apply (simp add: uint_nat)
          apply unat_arith
         apply unat_arith
        apply (rule_tac ?s1.0 = "s'a" and m = "Suc (unat rv)"
                     in is_array_after_changing_right)
           apply unat_arith
          apply (rule_tac ?s1.0 = "s'" and m = "unat rv"
                       in is_array_after_changing_left)
             apply unat_arith
            apply assumption+
         apply (simp add: uint_nat)+
       apply (subgoal_tac "multiset_of (the_array s'b a (unat n)) =
                           multiset_of (the_array s'a a (unat n))")
        apply (subgoal_tac "multiset_of (the_array s'a a (unat n)) =
                           multiset_of (the_array s' a (unat n))", simp)
        apply (rule_tac m = "unat rv" in multiset_same_after_shuffling_left)
           apply unat_arith
          apply (simp add: is_array_def)
         apply assumption
        apply (simp add: unmodified_outside_range_def)
       apply (rule_tac m = "Suc (unat rv)" in multiset_same_after_shuffling_right)
          apply unat_arith
         apply (simp add: is_array_def)
        apply simp
       apply (simp add: unmodified_outside_range_def)
      apply (rule_tac m = "unat rv" in partitioned_array_sorted)
         apply unat_arith
        apply (subgoal_tac "the_array s'b a (unat rv) = the_array s'a a (unat rv)", simp)
        apply (case_tac "Suc (unat rv) = unat n")
         apply (simp add: unmodified_outside_empty_range the_arrays_equal)
        apply (erule_tac a = "a +\<^sub>p 1 +\<^sub>p uint rv" and n = "unat n - Suc (unat rv)"
                     in the_same_array)
         apply (simp add: is_array_def)
        apply (rule disjI1, rule conjI)
         apply (erule subarray_not_at_mem_end2, unat_arith)
        apply (rule array_loc_le_Suc)
        apply (erule subarray_not_at_mem_end2, unat_arith)
       apply (simp add: uint_nat)
      apply (rule_tac ?s0.0 = "s'a" in partitioned_after_shuffling_right)
          apply (rule_tac ?s1.0 = "s'" and m = "unat rv" in is_array_after_changing_left)
             apply unat_arith
            apply assumption+
        apply (rule_tac ?s0.0 = "s'" in partitioned_after_shuffling_left, assumption+)
       apply (simp add: uint_nat)+
     apply (erule unmodified_outside_range_trans)
     apply (rule_tac ?s2.0 = "s'a" in unmodified_outside_range_trans)
      apply (rule_tac m = "unat rv" in unmodified_outside_subrange1)
        apply (simp add: is_array_def)
       apply assumption
      apply unat_arith
     apply (rule_tac m = "Suc (unat rv)" in unmodified_outside_subrange2)
       apply (simp add: is_array_def)
      apply (simp add: uint_nat)
     apply unat_arith
    apply (case_tac "n = 1", simp)
    apply (subgoal_tac "n = 0", simp, unat_arith)
    done

qed

end

end


(* TODO: Move to lib/ *)
theory Monadify
imports Main "Automatic_Refinement.Refine_Util"
begin
  (* TODO: Move *)
  ML \<open>
    (* Simplified output of rough term structure, for debugging purposes *)
    structure Simplified_Term_Struct : sig
      val tstruct: term -> string
    end = struct
      fun par b s = if b then "("^s^")" else s

      fun psi_aux p env = let
        fun r (Const (n,_)) = Long_Name.base_name n
          | r (Var (n,_)) = Term.string_of_vname n
          | r (Free (n,_)) = n
          | r (Bound i) = nth env i
          | r (Abs (x,_,t)) = par p (let val x = singleton (Name.variant_list env) x in "\<lambda>"^x^". "^psi_aux false (x::env) t end)
          | r (t as _$_) = let
              val (f,args) = strip_comb t
              val f = psi_aux true env f
              val args = map (psi_aux true env) args |> space_implode " "
              val s = f^" "^args
            in par p s end
      in
        r
      end

      val tstruct = psi_aux false []
    end
  \<close>

  lemma eta_expand: "f \<equiv> \<lambda>x. f x" by (rule reflexive)

  ML \<open>
    functor Gen_Monadify (
      (*
        Assumes that the monad combinators have the form return$x and bind$m$f
      *)

      val mk_return: term -> term
      val mk_bind: term -> term -> term
      val dest_return: term -> term option
      val dest_bind: term -> (term * term) option
      val dest_monadT: typ -> typ option
      val strip_op: Proof.context -> term -> term * term list

      (* TODO: Probably can derive mk and dest functions from these theorems! *)
      val bind_return_thm : thm  (* bind m return = m *)
      val return_bind_thm : thm  (* bind (return x) f = f x  *)
      val bind_bind_thm : thm    (* bind (bind m f) g = bind m (\<lambda>x. bind (f x) g) *)

    ) = struct

      val monad_laws = [bind_return_thm, return_bind_thm, bind_bind_thm]

      val is_return = is_some o dest_return
      val is_bind = is_some o dest_bind

      val dest_monadT' = the o dest_monadT
      val is_monadT = is_some o dest_monadT
      val is_monadic = is_monadT o fastype_of

      local open Conv in

        (* TODO: Move, generally useful *)
        (* Apply conversion to direct subterms, fail if conversion fails for a subterm *)
        fun sub_conv' conv ctxt ct = (case Thm.term_of ct of
          Abs _ => abs_conv (conv o snd) ctxt
        | _$_ => comb_conv (conv ctxt)
        | _ => all_conv
        ) ct

      end

      local
        open Conv

        fun ensure_eta_conv ct =
          (case Thm.term_of ct of
            Abs _ => all_conv
          | _ => rewr_conv @{thm eta_expand}
          ) ct

        fun expand_return_thm ctxt =
          Local_Defs.meta_rewrite_rule ctxt bind_return_thm
          RS @{thm Pure.symmetric}

      in

        fun eta_ret_conv ctxt ct = (let
          val t = Thm.term_of ct
          val bnd_conv =
            arg_conv ensure_eta_conv
            then_conv arg1_conv (sub_conv' eta_ret_conv ctxt)
            then_conv arg_conv (abs_conv (eta_ret_conv o snd) ctxt)

        in
          if is_monadic t then
            if is_bind t then bnd_conv
            else if is_return t then arg_conv (eta_ret_conv ctxt)
            else rewr_conv (expand_return_thm ctxt) then_conv bnd_conv
          else
            sub_conv' eta_ret_conv ctxt
        end) ct

      end

      (* Generate a bind, the second term is created by F x, where x is the bound variable *)
      fun BIND M F ctxt = let
        val m = M ctxt
        val T = fastype_of m |> dest_monadT'
        val (n,ctxt) = yield_singleton Variable.variant_fixes "tmp" ctxt
        val x = Free (n,T)

        val f = Term.lambda x (F x ctxt)
      in
        mk_bind m f
      end

      fun ABS_CNV (x,T,t) cnv ctxt = let
        val (n,ctxt) = yield_singleton Variable.variant_fixes x ctxt
        val t = subst_bound (Free (n,T), t)
        val t = cnv t ctxt
        val t = Term.absfree (n,T) t
      in t end

      fun mk_return' t _ = mk_return t

      fun is_operand (Free _) = true
        | is_operand (Var _) = true
        | is_operand (Bound _) = true
        | is_operand _ = false

      val is_ho_operand = fastype_of #> body_type #> is_monadT

      fun process_ho_operand t = let
        val (argTs,T) = fastype_of t |> strip_type
      in
        is_monadT T andalso length (strip_abs_vars t) = length argTs
      end

      fun mk_operand t F =
        if is_operand t then F t
        else if is_ho_operand t then fn ctxt => F (mk_monadify_all t ctxt) ctxt
        else BIND (mk_operation t mk_return') F
      and mk_operation t F ctxt = let
            val (f,xs) = strip_op ctxt t
            fun R t [] = F t | R t (x::xs) = mk_operand x (fn x => R (t$x) xs)
          in
            R f xs ctxt
          end
      and mk_monadify (Abs xTt) = ABS_CNV xTt mk_monadify
        | mk_monadify t = case dest_return t of
            SOME x => mk_operation x mk_return'
          | NONE => mk_operation t (fn t => K t)
      and mk_monadify_all (Abs xTt) = ABS_CNV xTt mk_monadify_all
        | mk_monadify_all t =
            if is_monadT (fastype_of t) then mk_monadify t
            else fn ctxt =>
              strip_comb t |> apsnd (map (fn t => mk_monadify_all t ctxt)) |> list_comb

      fun monadify ctxt t = mk_monadify t (Variable.declare_term t ctxt |> Variable.set_body false)

      fun monadify_conv ctxt ct = let
          val _ = is_monadT (Thm.typ_of_cterm ct |> body_type)
            orelse raise TYPE("No monad type",[Thm.typ_of_cterm ct],[Thm.term_of ct])

          val ctxt = put_simpset HOL_basic_ss ctxt addsimps monad_laws
          val tac = ALLGOALS (simp_tac ctxt)
        in
          (* TODO: f_tac_conv will choke on beta-redexes! *)
          Thm.beta_conversion true then_conv Refine_Util.f_tac_conv ctxt (monadify ctxt) tac then_conv eta_ret_conv ctxt
        end ct

      val monadify_all_conv = Conv.top_sweep_conv monadify_conv

      val monadify_all_tac = CONVERSION o monadify_all_conv

    end
  \<close>

  ML \<open>
    functor Gen_Monadify_Cong (
      val mk_return: term -> term
      val mk_bind: term -> term -> term
      val dest_return: term -> term option
      val dest_bind: term -> (term * term) option
      val dest_monadT: typ -> typ option

      val bind_return_thm : thm  (* bind m return = m *)
      val return_bind_thm : thm  (* bind (return x) f = f x  *)
      val bind_bind_thm : thm    (* bind (bind m f) g = bind m (\<lambda>x. bind (f x) g) *)

    ) = struct

      structure Consts = Generic_Data (
        type T = term Item_Net.T
        val empty = Item_Net.init (op aconv) single
        val merge = Item_Net.merge
        val extend = I
      )

      val add_const_decl = Consts.map o Item_Net.update
      val remove_const_decl = Consts.map o Item_Net.remove
      val get_const_decls = Context.Proof #> Consts.get #> Item_Net.content

      fun prepare_const_decl t ctxt = let
        val t = singleton (Variable.export_terms (Proof_Context.augment t ctxt) ctxt) t

        val _ = is_Var (head_of t) andalso
          (Pretty.block [
            Pretty.str "Head of const is variable: ",
            Syntax.pretty_term ctxt t
           ]) |> Pretty.string_of |> error

      in
        t
      end

      fun prepare_add_const_decl t context = add_const_decl (prepare_const_decl t (Context.proof_of context)) context

      fun is_const ctxt t =
        Item_Net.retrieve_matching (Consts.get (Context.Proof ctxt)) t
        |> exists (K true)

      fun strip_op ctxt t = let
        fun stripc (t as f$x, xs) = if is_const ctxt t then (t,xs) else stripc (f,x::xs)
          | stripc tt = tt
      in stripc (t,[]) end

      structure T = Gen_Monadify (
        val mk_return = mk_return
        val mk_bind = mk_bind
        val dest_return = dest_return
        val dest_bind = dest_bind
        val dest_monadT = dest_monadT
        val strip_op = strip_op
        val bind_return_thm = bind_return_thm
        val return_bind_thm = return_bind_thm
        val bind_bind_thm = bind_bind_thm
      )
      open T

    end
  \<close>

  (*
  (* Test Monad *)

  datatype 'a M = return 'a
  definition "bind \<equiv> \<lambda>return x \<Rightarrow> \<lambda>f. f x"

  lemma monad_laws:
    "bind m return = m"
    "bind (return x) f = f x"
    "bind (bind m (\<lambda>x. f x)) g = bind m (\<lambda>x. bind (f x) g)"
    unfolding bind_def by (auto split: M.split)

  ML \<open>

    structure Monadify = Gen_Monadify_Cong (

      fun mk_return x = @{mk_term "return ?x"}
      fun mk_bind m f = @{mk_term "bind ?m ?f"}

      fun dest_return @{mpat "return ?x"} = SOME x | dest_return _ = NONE
      fun dest_monadT (Type (@{type_name M},[T])) = SOME T | dest_monadT _ = NONE

      val monad_laws = @{thms monad_laws}
    )
  \<close>

  ML_val \<open>
    val t1 = @{term "let (x,y) = p in (return (x+y+y))"} |> Simplified_Term_Struct.tstruct
    val t2 = @{term "case p of (x,y) \<Rightarrow> (return (x+y+y))"} |> Simplified_Term_Struct.tstruct
  \<close>

  ML_val \<open>
    val ctxt = @{context}
    val ts = [
      @{term "case p of (x,y) \<Rightarrow> return (x+y+y)"},
      @{term "let (x,y) = p in return (x+y+y)"}
    ]

    val ts = map (Monadify.monadify ctxt #> Simplified_Term_Struct.tstruct) ts
  \<close>

  lemma "P (let (x,y) = p in return (x+y+y))"
    apply (tactic \<open>CONVERSION (HOLogic.Trueprop_conv (Conv.arg_conv (Monadify.monadify_conv @{context}))) 1\<close>)
    oops

  context
    fixes a :: "'a list"
   begin

  ML_val \<open>
    val ctxt = @{context}
    val t = @{term "a @ b"}
    val ctxt' = Variable.auto_fixes t ctxt

    val t = singleton (Variable.export_terms ctxt' ctxt) t

  \<close>
  end

  ML_val \<open>
    let
      open Monadify
      val ctxt = @{context}

      val ctxt = add_const_decl (prepare_const_decl ctxt @{term "hd f"}) ctxt

      val t = @{cterm \<open>return (hd ([a,b,c]) (g x y))\<close>}
      val t = monadify_conv ctxt t

    in
      t
    end

  \<close>
  *)
end


section \<open>Data\<close>

text \<open>This theory defines the data types and notations, and some preliminary results about them.\<close>

theory Data
  imports Main
begin

subsection \<open>Function notations\<close>

abbreviation \<epsilon> :: "'a \<rightharpoonup> 'b" where
  "\<epsilon> \<equiv> \<lambda>x. None"

fun combine :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a  \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" ("_;;_" 20) where
  "(f ;; g) x = (if g x = None then f x else g x)"

lemma dom_combination_dom_union: "dom (\<tau>;;\<tau>') = dom \<tau> \<union> dom \<tau>'"
  by auto

subsection \<open>Values, expressions and execution contexts\<close>

datatype const = Unit | F | T

datatype (RID\<^sub>V: 'r, LID\<^sub>V: 'l,'v) val =
  CV const
| Var 'v
| Loc 'l
| Rid 'r
| Lambda 'v "('r,'l,'v) expr"
and (RID\<^sub>E: 'r, LID\<^sub>E: 'l,'v) expr =
  VE "('r,'l,'v) val"
| Apply "('r,'l,'v) expr" "('r,'l,'v) expr"
| Ite "('r,'l,'v) expr" "('r,'l,'v) expr" "('r,'l,'v) expr"
| Ref "('r,'l,'v) expr"
| Read "('r,'l,'v) expr"
| Assign "('r,'l,'v) expr" "('r,'l,'v) expr"
| Rfork "('r,'l,'v) expr"
| Rjoin "('r,'l,'v) expr"

datatype (RID\<^sub>C: 'r, LID\<^sub>C: 'l,'v) cntxt =
  Hole ("\<box>")
| ApplyL\<^sub>\<E> "('r,'l,'v) cntxt" "('r,'l,'v) expr"
| ApplyR\<^sub>\<E> "('r,'l,'v) val" "('r,'l,'v) cntxt"
| Ite\<^sub>\<E> "('r,'l,'v) cntxt" "('r,'l,'v) expr" "('r,'l,'v) expr"
| Ref\<^sub>\<E> "('r,'l,'v) cntxt"
| Read\<^sub>\<E> "('r,'l,'v) cntxt"
| AssignL\<^sub>\<E> "('r,'l,'v) cntxt" "('r,'l,'v) expr"
| AssignR\<^sub>\<E> 'l "('r,'l,'v) cntxt"
| Rjoin\<^sub>\<E> "('r,'l,'v) cntxt"

subsection \<open>Plugging and decomposing\<close>

fun plug :: "('r,'l,'v) cntxt \<Rightarrow> ('r,'l,'v) expr \<Rightarrow> ('r,'l,'v) expr" (infix "\<lhd>" 60) where
  "\<box> \<lhd> e = e"
| "ApplyL\<^sub>\<E> \<E> e1 \<lhd> e = Apply (\<E> \<lhd> e) e1"
| "ApplyR\<^sub>\<E> val \<E> \<lhd> e = Apply (VE val) (\<E> \<lhd> e)"
| "Ite\<^sub>\<E> \<E> e1 e2 \<lhd> e = Ite (\<E> \<lhd> e) e1 e2"
| "Ref\<^sub>\<E> \<E> \<lhd> e = Ref (\<E> \<lhd> e)"
| "Read\<^sub>\<E> \<E> \<lhd> e = Read (\<E> \<lhd> e)"
| "AssignL\<^sub>\<E> \<E> e1 \<lhd> e = Assign (\<E> \<lhd> e) e1"
| "AssignR\<^sub>\<E> l \<E> \<lhd> e = Assign (VE (Loc l)) (\<E> \<lhd> e)"
| "Rjoin\<^sub>\<E> \<E> \<lhd> e = Rjoin (\<E> \<lhd> e)"

translations
  "\<E>[x]" \<rightleftharpoons> "\<E> \<lhd> x"

lemma injective_cntxt [simp]: "(\<E>[e1] = \<E>[e2]) = (e1 = e2)" by (induction \<E>) auto

lemma VE_empty_cntxt [simp]: "(VE v = \<E>[e]) = (\<E> = \<box> \<and> VE v = e)" by (cases \<E>, auto)

inductive redex :: "('r,'l,'v) expr \<Rightarrow> bool" where
  app: "redex (Apply (VE (Lambda x e)) (VE v))"
| iteTrue: "redex (Ite (VE (CV T)) e1 e2)"
| iteFalse: "redex (Ite (VE (CV F)) e1 e2)"
| ref: "redex (Ref (VE v))"
| read: "redex (Read (VE (Loc l)))"
| assign: "redex (Assign (VE (Loc l)) (VE v))"
| rfork: "redex (Rfork e)"
| rjoin: "redex (Rjoin (VE (Rid r)))"

inductive_simps redex_simps [simp]: "redex e"
inductive_cases redexE [elim]: "redex e"

lemma plugged_redex_not_val [simp]: "redex r \<Longrightarrow> (\<E> \<lhd> r) \<noteq> (VE t)" by (cases \<E>) auto

inductive decompose :: "('r,'l,'v) expr \<Rightarrow> ('r,'l,'v) cntxt \<Rightarrow> ('r,'l,'v) expr \<Rightarrow> bool" where
  top_redex: "redex e \<Longrightarrow> decompose e \<box> e"
| lapply: "\<lbrakk> \<not>redex (Apply e\<^sub>1 e\<^sub>2); decompose e\<^sub>1 \<E> r \<rbrakk> \<Longrightarrow> decompose (Apply e\<^sub>1 e\<^sub>2) (ApplyL\<^sub>\<E> \<E> e\<^sub>2) r"
| rapply: "\<lbrakk> \<not>redex (Apply (VE v) e); decompose e \<E> r \<rbrakk> \<Longrightarrow> decompose (Apply (VE v) e) (ApplyR\<^sub>\<E> v \<E>) r"
| ite: "\<lbrakk> \<not>redex (Ite e\<^sub>1 e\<^sub>2 e\<^sub>3); decompose e\<^sub>1 \<E> r \<rbrakk> \<Longrightarrow> decompose (Ite e\<^sub>1 e\<^sub>2 e\<^sub>3) (Ite\<^sub>\<E> \<E> e\<^sub>2 e\<^sub>3) r"
| ref: "\<lbrakk> \<not>redex (Ref e); decompose e \<E> r \<rbrakk> \<Longrightarrow> decompose (Ref e) (Ref\<^sub>\<E> \<E>) r"
| read: "\<lbrakk> \<not>redex (Read e); decompose e \<E> r \<rbrakk> \<Longrightarrow> decompose (Read e) (Read\<^sub>\<E> \<E>) r"
| lassign: "\<lbrakk> \<not>redex (Assign e\<^sub>1 e\<^sub>2); decompose e\<^sub>1 \<E> r \<rbrakk> \<Longrightarrow> decompose (Assign e\<^sub>1 e\<^sub>2) (AssignL\<^sub>\<E> \<E> e\<^sub>2) r"
| rassign: "\<lbrakk> \<not>redex (Assign (VE (Loc l)) e\<^sub>2); decompose e\<^sub>2 \<E> r \<rbrakk> \<Longrightarrow> decompose (Assign (VE (Loc l)) e\<^sub>2) (AssignR\<^sub>\<E> l \<E>) r"
| rjoin:  "\<lbrakk> \<not>redex (Rjoin e); decompose e \<E> r \<rbrakk> \<Longrightarrow> decompose (Rjoin e) (Rjoin\<^sub>\<E> \<E>) r"

inductive_cases decomposeE [elim]: "decompose e \<E> r"

lemma plug_decomposition_equivalence: "redex r \<Longrightarrow> decompose e \<E> r = (\<E>[r] = e)"
proof (rule iffI)
  assume x: "decompose e \<E> r"
  show "\<E>[r] = e"
  proof (use x in \<open>induct rule: decompose.induct\<close>)
    case (top_redex e)
    thus "\<box>[e] = e" by simp
  next
    case (lapply e\<^sub>1 e\<^sub>2 \<E> r)
    have "(ApplyL\<^sub>\<E> \<E> e\<^sub>2) [r] = Apply (\<E>[r]) e\<^sub>2" by simp
    also have "... = Apply e\<^sub>1 e\<^sub>2" using \<open>\<E>[r] = e\<^sub>1\<close> by simp
    then show ?case by simp
  qed simp+
next
  assume red: "redex r" and  eq: "\<E>[r] = e"
  have "decompose (\<E>[r]) \<E> r" by (induct \<E>) (use red in \<open>auto intro: decompose.intros\<close>)
  thus "decompose e \<E> r" by (simp add: eq)
qed

lemma unique_decomposition: "decompose e \<E>\<^sub>1 r\<^sub>1 \<Longrightarrow> decompose e \<E>\<^sub>2 r\<^sub>2 \<Longrightarrow> \<E>\<^sub>1 = \<E>\<^sub>2 \<and> r\<^sub>1 = r\<^sub>2"
  by (induct arbitrary: \<E>\<^sub>2 rule: decompose.induct) auto

lemma completion_eq [simp]:
  assumes
    red_e: "redex r" and
    red_e': "redex r'"
  shows "(\<E>[r] = \<E>'[r']) = (\<E> = \<E>' \<and> r = r')"
proof (rule iffI)
  show "\<E>[r] = \<E>'[r'] \<Longrightarrow> \<E> = \<E>' \<and> r = r'"
  proof (rule conjI)
    assume eq: "\<E>[r] = \<E>'[r']"
    have "decompose (\<E>[r]) \<E> r" using plug_decomposition_equivalence red_e by blast
    hence fst_decomp:"decompose (\<E>'[r']) \<E> r" by (simp add: eq)
    have snd_decomp: "decompose (\<E>'[r']) \<E>' r'" using plug_decomposition_equivalence red_e' by blast
    show cntxts_eq: "\<E> = \<E>'" using fst_decomp snd_decomp unique_decomposition by blast
    show "r = r'" using cntxts_eq eq by simp
  qed
qed simp

subsection \<open>Stores and states\<close>

type_synonym ('r,'l,'v) store = "'l \<rightharpoonup> ('r,'l,'v) val"
type_synonym ('r,'l,'v) local_state = "('r,'l,'v) store \<times> ('r,'l,'v) store \<times> ('r,'l,'v) expr"
type_synonym ('r,'l,'v) global_state = "'r \<rightharpoonup> ('r,'l,'v) local_state"

fun doms :: "('r,'l,'v) local_state \<Rightarrow> 'l set" where
  "doms (\<sigma>,\<tau>,e) = dom \<sigma> \<union> dom \<tau>"

fun LID_snapshot :: "('r,'l,'v) local_state \<Rightarrow> ('r,'l,'v) store" ("_\<^sub>\<sigma>" 200) where
  "LID_snapshot (\<sigma>,\<tau>,e) = \<sigma>"

fun LID_local_store :: "('r,'l,'v) local_state \<Rightarrow> ('r,'l,'v) store" ("_\<^sub>\<tau>" 200) where
  "LID_local_store (\<sigma>,\<tau>,e) = \<tau>"

fun LID_expression :: "('r,'l,'v) local_state \<Rightarrow> ('r,'l,'v) expr" ("_\<^sub>e" 200) where
  "LID_expression (\<sigma>,\<tau>,e) = e"

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Cong_Pres
  imports Weak_Early_Cong Weak_Early_Step_Sim_Pres Weak_Early_Bisim_Pres
begin

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "\<tau>.(P) \<simeq> \<tau>.(Q)"
proof -
  from assms have "P \<approx> Q" by(rule congruenceWeakBisim)
  thus ?thesis by(force intro: Weak_Early_Step_Sim_Pres.tauPres simp add: weakCongruence_def dest: weakBisimE(2))
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "a{b}.P \<simeq> a{b}.Q"
proof -
  from assms have "P \<approx> Q" by(rule congruenceWeakBisim)
  thus ?thesis by(force intro: Weak_Early_Step_Sim_Pres.outputPres simp add: weakCongruence_def dest: weakBisimE(2))
qed

  assumes "P \<simeq> Q"

  shows "[a\<frown>b]P \<simeq> [a\<frown>b]Q"
using assms
by(auto simp add: weakCongruence_def intro: Weak_Early_Step_Sim_Pres.matchPres)

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<simeq> Q"

  shows "[a\<noteq>b]P \<simeq> [a\<noteq>b]Q"
using assms
by(auto simp add: weakCongruence_def intro: Weak_Early_Step_Sim_Pres.mismatchPres)

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq> Q"

  shows "P \<oplus> R \<simeq> Q \<oplus> R"
using assms
by(auto simp add: weakCongruence_def intro: Weak_Early_Step_Sim_Pres.sumPres Weak_Early_Bisim.reflexive)

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq> Q"

  shows "P \<parallel> R \<simeq> Q \<parallel> R"
proof -
  have "\<And>P Q R. \<lbrakk>P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q; P \<approx> Q\<rbrakk> \<Longrightarrow> P \<parallel> R \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q \<parallel> R"
  proof -
    fix P Q R
    assume "P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q" and "P \<approx> Q"
    thus "P \<parallel> R \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q \<parallel> R"
      using Weak_Early_Bisim_Pres.parPres Weak_Early_Bisim_Pres.resPres Weak_Early_Bisim.reflexive Weak_Early_Bisim.eqvt
      by(blast intro: Weak_Early_Step_Sim_Pres.parPres)
  qed
  moreover from assms have "P \<approx> Q" by(rule congruenceWeakBisim)
  ultimately show ?thesis using assms
    by(auto simp add: weakCongruence_def dest: weakBisimE)
qed

  assumes PeqQ: "P \<simeq> Q"

  shows "<\<nu>x>P \<simeq> <\<nu>x>Q"
proof -
  have "\<And>P Q x. P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q \<Longrightarrow> <\<nu>x>P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> <\<nu>x>Q"
  proof -
    fix P Q x
    assume "P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q"
    with Weak_Early_Bisim.eqvt Weak_Early_Bisim_Pres.resPres show "<\<nu>x>P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> <\<nu>x>Q"
      by(blast intro: Weak_Early_Step_Sim_Pres.resPres)
  qed
  with assms show ?thesis by(simp add: weakCongruence_def)
qed

  shows "!P \<simeq> !Q"
using assms
proof(induct rule: weakCongISym2)
  case(cSim P Q)
  let ?X = "{(P, Q) | P Q. P \<simeq> Q}"
  from \<open>P \<simeq> Q\<close>  have "(P, Q) \<in> ?X"  by auto
  moreover have "\<And>P Q. (P, Q) \<in> ?X \<Longrightarrow> P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q" by(auto simp add: weakCongruence_def)
  moreover from congruenceWeakBisim have "?X \<subseteq> weakBisim" by auto
  ultimately have "!P \<leadsto>\<guillemotleft>bangRel weakBisim\<guillemotright> !Q" using Weak_Early_Bisim.eqvt
    by(rule Weak_Early_Step_Sim_Pres.bangPres)
  moreover have "bangRel weakBisim \<subseteq> weakBisim" by(rule bangRelSubWeakBisim)
  ultimately show "!P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> !Q"
    by(rule Weak_Early_Step_Sim.monotonic)
qed

end


(*  Title:      HOL/HOLCF/Library/Bool_Discrete.thy
    Author:     Brian Huffman
*)

section {* Discrete cpo instance for booleans *}

theory Bool_Discrete
imports HOLCF
begin

text {* Discrete cpo instance for @{typ bool}. *}

instantiation bool :: discrete_cpo
begin

definition below_bool_def:
  "(x::bool) \<sqsubseteq> y \<longleftrightarrow> x = y"

instance proof
qed (rule below_bool_def)

end

text {*
  TODO: implement a command to automate discrete predomain instances.
*}

instantiation bool :: predomain
begin

definition
  "(liftemb :: bool u \<rightarrow> udom u) \<equiv> liftemb oo u_map\<cdot>(\<Lambda> x. Discr x)"

definition
  "(liftprj :: udom u \<rightarrow> bool u) \<equiv> u_map\<cdot>(\<Lambda> y. undiscr y) oo liftprj"

definition
  "liftdefl \<equiv> (\<lambda>(t::bool itself). LIFTDEFL(bool discr))"

instance proof
  show "ep_pair liftemb (liftprj :: udom u \<rightarrow> bool u)"
    unfolding liftemb_bool_def liftprj_bool_def
    apply (rule ep_pair_comp)
    apply (rule ep_pair_u_map)
    apply (simp add: ep_pair.intro)
    apply (rule predomain_ep)
    done
  show "cast\<cdot>LIFTDEFL(bool) = liftemb oo (liftprj :: udom u \<rightarrow> bool u)"
    unfolding liftemb_bool_def liftprj_bool_def liftdefl_bool_def
    apply (simp add: cast_liftdefl cfcomp1 u_map_map)
    apply (simp add: ID_def [symmetric] u_map_ID)
    done
qed

end

lemma cont2cont_if [simp, cont2cont]:
  assumes b: "cont b" and f: "cont f" and g: "cont g"
  shows "cont (\<lambda>x. if b x then f x else g x)"
by (rule cont_apply [OF b cont_discrete_cpo], simp add: f g)

lemma cont2cont_eq [simp, cont2cont]:
  fixes f g :: "'a::cpo \<Rightarrow> 'b::discrete_cpo"
  assumes f: "cont f" and g: "cont g"
  shows "cont (\<lambda>x. f x = g x)"
apply (rule cont_apply [OF f cont_discrete_cpo])
apply (rule cont_apply [OF g cont_discrete_cpo])
apply (rule cont_const)
done

end


header {* Set by Characteristic Function *}
theory Impl_Cfun_Set
imports "../Intf/Intf_Set"
begin

definition fun_set_rel where
  fun_set_rel_internal_def:
  "fun_set_rel R \<equiv> (R\<rightarrow>bool_rel) O br Collect (\<lambda>_. True)"

lemma fun_set_rel_def: "\<langle>R\<rangle>fun_set_rel = (R\<rightarrow>bool_rel) O br Collect (\<lambda>_. True)"
  by (simp add: relAPP_def fun_set_rel_internal_def)

lemma fun_set_rel_sv[relator_props]:
  "\<lbrakk>single_valued R; Range R = UNIV\<rbrakk> \<Longrightarrow> single_valued (\<langle>R\<rangle>fun_set_rel)"
  unfolding fun_set_rel_def
  by (tagged_solver (keep))

lemma fun_set_rel_RUNIV[relator_props]:
  assumes SV: "single_valued R"
  shows "Range (\<langle>R\<rangle>fun_set_rel) = UNIV"
proof -
  {
    fix b
    have "\<exists>a. (a,b)\<in>\<langle>R\<rangle>fun_set_rel" unfolding fun_set_rel_def
      apply (rule exI)
      apply (rule relcompI)
    proof -
      show "((\<lambda>x. x\<in>b),b)\<in>br Collect (\<lambda>_. True)" by (auto simp: br_def)
      show "(\<lambda>x'. \<exists>x. (x',x)\<in>R \<and> x\<in>b,\<lambda>x. x \<in> b)\<in>R \<rightarrow> bool_rel"
        by (auto dest: single_valuedD[OF SV])
    qed
  } thus ?thesis by blast
qed

lemmas [autoref_rel_intf] = REL_INTFI[of fun_set_rel i_set]

lemma fs_mem_refine[autoref_rules]: "(\<lambda>x f. f x,op \<in>) \<in> R \<rightarrow> \<langle>R\<rangle>fun_set_rel \<rightarrow> bool_rel"
  apply (intro fun_relI)
  apply (auto simp add: fun_set_rel_def br_def dest: fun_relD)
  done

lemma fun_set_Collect_refine[autoref_rules]:
  "(\<lambda>x. x, Collect)\<in>(R\<rightarrow>bool_rel) \<rightarrow> \<langle>R\<rangle>fun_set_rel"
  unfolding fun_set_rel_def
  by (auto simp: br_def)

lemma fun_set_empty_refine[autoref_rules]:
  "(\<lambda>_. False,{})\<in>\<langle>R\<rangle>fun_set_rel"
  by (force simp add: fun_set_rel_def br_def)

lemma fun_set_UNIV_refine[autoref_rules]:
  "(\<lambda>_. True,UNIV)\<in>\<langle>R\<rangle>fun_set_rel"
  by (force simp add: fun_set_rel_def br_def)

end