(*
 * Copyright Florian Haftmann
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Ancient comprehensive Word Library\<close>

theory Word_Lib_Sumo
imports
  "HOL-Library.Word"
  Aligned
  Ancient_Numeral
  Bit_Comprehension
  Bits_Int
  Bitwise_Signed
  Bitwise
  Enumeration_Word
  Generic_set_bit
  Hex_Words
  Least_significant_bit
  More_Arithmetic
  More_Divides
  More_Sublist
  Even_More_List
  More_Misc
  Strict_part_mono
  Legacy_Aliases
  Most_significant_bit
  Next_and_Prev
  Norm_Words
  Reversed_Bit_Lists
  Rsplit
  Signed_Words
  Traditional_Infix_Syntax
  Typedef_Morphisms
  Type_Syntax
  Word_EqI
  Word_Lemmas
  Word_8
  Word_16
  Word_32
  Word_Syntax
  Signed_Division_Word
  More_Word_Operations
  Many_More
begin

declare word_induct2[induct type]
declare word_nat_cases[cases type]

declare signed_take_bit_Suc [simp]

(* these generate take_bit terms, which we often don't want for concrete lengths *)
lemmas of_int_and_nat = unsigned_of_nat unsigned_of_int signed_of_int signed_of_nat

bundle no_take_bit
begin
  declare of_int_and_nat[simp del]
end

lemmas bshiftr1_def = bshiftr1_eq
lemmas is_down_def = is_down_eq
lemmas is_up_def = is_up_eq
lemmas mask_def = mask_eq
lemmas scast_def = scast_eq
lemmas shiftl1_def = shiftl1_eq
lemmas shiftr1_def = shiftr1_eq
lemmas sshiftr1_def = sshiftr1_eq
lemmas sshiftr_def = sshiftr_eq_funpow_sshiftr1
lemmas to_bl_def = to_bl_eq
lemmas ucast_def = ucast_eq
lemmas unat_def = unat_eq_nat_uint
lemmas word_cat_def = word_cat_eq
lemmas word_reverse_def = word_reverse_eq_of_bl_rev_to_bl
lemmas word_roti_def = word_roti_eq_word_rotr_word_rotl
lemmas word_rotl_def = word_rotl_eq
lemmas word_rotr_def = word_rotr_eq
lemmas word_sle_def = word_sle_eq
lemmas word_sless_def = word_sless_eq

lemmas uint_0 = uint_nonnegative
lemmas uint_lt = uint_bounded
lemmas uint_mod_same = uint_idem
lemmas of_nth_def = word_set_bits_def

lemmas of_nat_word_eq_iff = word_of_nat_eq_iff
lemmas of_nat_word_eq_0_iff = word_of_nat_eq_0_iff
lemmas of_int_word_eq_iff = word_of_int_eq_iff
lemmas of_int_word_eq_0_iff = word_of_int_eq_0_iff

lemmas word_next_def = word_next_unfold

lemmas word_prev_def = word_prev_unfold

lemmas is_aligned_def = is_aligned_iff_dvd_nat

lemma shiftl_transfer [transfer_rule]:
  includes lifting_syntax
  shows "(pcr_word ===> (=) ===> pcr_word) (<<) (<<)"
  by (unfold shiftl_eq_push_bit) transfer_prover

lemmas word_and_max_simps =
  word8_and_max_simp
  word16_and_max_simp
  word32_and_max_simp

lemma distinct_lemma: "f x \<noteq> f y \<Longrightarrow> x \<noteq> y" by auto

lemmas and_bang = word_and_nth

lemmas sdiv_int_def = signed_divide_int_def
lemmas smod_int_def = signed_modulo_int_def

(* shortcut for some specific lengths *)
lemma word_fixed_sint_1[simp]:
  "sint (1::8 word) = 1"
  "sint (1::16 word) = 1"
  "sint (1::32 word) = 1"
  "sint (1::64 word) = 1"
  by (auto simp: sint_word_ariths)

declare of_nat_diff [simp]

(* Haskellish names/syntax *)
notation (input)
  test_bit ("testBit")

lemmas cast_simps = cast_simps ucast_down_bl

(* shadows the slightly weaker Word.nth_ucast *)
lemma nth_ucast:
  "(ucast (w::'a::len word)::'b::len word) !! n =
   (w !! n \<and> n < min LENGTH('a) LENGTH('b))"
  by transfer (simp add: bit_take_bit_iff ac_simps)

end


theory TA_More2
  imports TA.TA_More
begin

lemma collect_clock_pairs_concat:
  "collect_clock_pairs (concat xxs) = (\<Union> x \<in> set xxs. collect_clock_pairs x)"
  unfolding collect_clock_pairs_def by auto

end


(*
 * Copyright Florian Haftmann
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Ancient comprehensive Word Library\<close>

theory Word_Lib_Sumo
imports
  "HOL-Library.Word"
  Aligned
  Bit_Comprehension
  Bit_Shifts_Infix_Syntax
  Bits_Int
  Bitwise_Signed
  Bitwise
  Enumeration_Word
  Generic_set_bit
  Hex_Words
  Least_significant_bit
  More_Arithmetic
  More_Divides
  More_Sublist
  Even_More_List
  More_Misc
  Strict_part_mono
  Legacy_Aliases
  Most_significant_bit
  Next_and_Prev
  Norm_Words
  Reversed_Bit_Lists
  Rsplit
  Signed_Words
  Syntax_Bundles
  Typedef_Morphisms
  Type_Syntax
  Word_EqI
  Word_Lemmas
  Word_8
  Word_16
  Word_32
  Word_Syntax
  Signed_Division_Word
  More_Word_Operations
  Many_More
begin

unbundle bit_projection_infix_syntax

declare word_induct2[induct type]
declare word_nat_cases[cases type]

declare signed_take_bit_Suc [simp]

(* these generate take_bit terms, which we often don't want for concrete lengths *)
lemmas of_int_and_nat = unsigned_of_nat unsigned_of_int signed_of_int signed_of_nat

bundle no_take_bit
begin
  declare of_int_and_nat[simp del]
end

lemmas bshiftr1_def = bshiftr1_eq
lemmas is_down_def = is_down_eq
lemmas is_up_def = is_up_eq
lemmas mask_def = mask_eq
lemmas scast_def = scast_eq
lemmas shiftl1_def = shiftl1_eq
lemmas shiftr1_def = shiftr1_eq
lemmas sshiftr1_def = sshiftr1_eq
lemmas sshiftr_def = sshiftr_eq_funpow_sshiftr1
lemmas to_bl_def = to_bl_eq
lemmas ucast_def = ucast_eq
lemmas unat_def = unat_eq_nat_uint
lemmas word_cat_def = word_cat_eq
lemmas word_reverse_def = word_reverse_eq_of_bl_rev_to_bl
lemmas word_roti_def = word_roti_eq_word_rotr_word_rotl
lemmas word_rotl_def = word_rotl_eq
lemmas word_rotr_def = word_rotr_eq
lemmas word_sle_def = word_sle_eq
lemmas word_sless_def = word_sless_eq

lemmas uint_0 = uint_nonnegative
lemmas uint_lt = uint_bounded
lemmas uint_mod_same = uint_idem
lemmas of_nth_def = word_set_bits_def

lemmas of_nat_word_eq_iff = word_of_nat_eq_iff
lemmas of_nat_word_eq_0_iff = word_of_nat_eq_0_iff
lemmas of_int_word_eq_iff = word_of_int_eq_iff
lemmas of_int_word_eq_0_iff = word_of_int_eq_0_iff

lemmas word_next_def = word_next_unfold

lemmas word_prev_def = word_prev_unfold

lemmas is_aligned_def = is_aligned_iff_dvd_nat

lemmas word_and_max_simps =
  word8_and_max_simp
  word16_and_max_simp
  word32_and_max_simp

lemma distinct_lemma: "f x \<noteq> f y \<Longrightarrow> x \<noteq> y" by auto

lemmas and_bang = word_and_nth

lemmas sdiv_int_def = signed_divide_int_def
lemmas smod_int_def = signed_modulo_int_def

(* shortcut for some specific lengths *)
lemma word_fixed_sint_1[simp]:
  "sint (1::8 word) = 1"
  "sint (1::16 word) = 1"
  "sint (1::32 word) = 1"
  "sint (1::64 word) = 1"
  by (auto simp: sint_word_ariths)

declare of_nat_diff [simp]

(* Haskellish names/syntax *)
notation (input)
  bit ("testBit")

lemmas cast_simps = cast_simps ucast_down_bl

(* shadows the slightly weaker Word.nth_ucast *)
lemma nth_ucast:
  "(ucast (w::'a::len word)::'b::len word) !! n =
   (w !! n \<and> n < min LENGTH('a) LENGTH('b))"
  by (auto simp add: bit_simps not_le dest: bit_imp_le_length)

end


(*
 * 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)
 *)

(*
   Miscellaneous library definitions and lemmas.
*)

chapter "Library"

theory Lib
imports Main
begin

(* FIXME: eliminate *)
lemma hd_map_simp:
  "b \<noteq> [] \<Longrightarrow> hd (map a b) = a (hd b)"
  by (rule hd_map)

(* FIXME: could be added to Set.thy *)
lemma Collect_eq:
  "{x. P x} = {x. Q x} \<longleftrightarrow> (\<forall>x. P x = Q x)"
  by (rule iffI) auto

(* FIXME: move next to HOL.iff_allI *)
lemma iff_impI: "\<lbrakk>P \<Longrightarrow> Q = R\<rbrakk> \<Longrightarrow> (P \<longrightarrow> Q) = (P \<longrightarrow> R)" by blast

definition
  fun_app :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "$" 10) where
  "f $ x \<equiv> f x"

declare fun_app_def [iff]

lemma fun_app_cong[fundef_cong]:
  "\<lbrakk> f x = f' x' \<rbrakk> \<Longrightarrow> (f $ x) = (f' $ x')"
  by simp

lemma fun_app_apply_cong[fundef_cong]:
  "f x y = f' x' y' \<Longrightarrow> (f $ x) y = (f' $ x') y'"
  by simp

lemma if_apply_cong[fundef_cong]:
  "\<lbrakk> P = P'; x = x'; P' \<Longrightarrow> f x' = f' x'; \<not> P' \<Longrightarrow> g x' = g' x' \<rbrakk>
     \<Longrightarrow> (if P then f else g) x = (if P' then f' else g') x'"
  by simp

lemma case_prod_apply_cong[fundef_cong]:
  "\<lbrakk> f (fst p) (snd p) s = f' (fst p') (snd p') s' \<rbrakk> \<Longrightarrow> case_prod f p s = case_prod f' p' s'"
  by (simp add: split_def)

definition
  pred_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "and" 35)
where
  "pred_conj P Q \<equiv> \<lambda>x. P x \<and> Q x"

definition
  pred_disj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "or" 30)
where
  "pred_disj P Q \<equiv> \<lambda>x. P x \<or> Q x"

definition
  pred_neg :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" ("not _" [40] 40)
where
  "pred_neg P \<equiv> \<lambda>x. \<not> P x"

definition "K \<equiv> \<lambda>x y. x"

definition
  zipWith :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
  "zipWith f xs ys \<equiv> map (case_prod f) (zip xs ys)"

primrec
  delete :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "delete y [] = []"
| "delete y (x#xs) = (if y=x then xs else x # delete y xs)"

primrec
  find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option"
where
  "find f [] = None"
| "find f (x # xs) = (if f x then Some x else find f xs)"

definition
 "swp f \<equiv> \<lambda>x y. f y x"

primrec (nonexhaustive)
  theRight :: "'a + 'b \<Rightarrow> 'b" where
  "theRight (Inr x) = x"

primrec (nonexhaustive)
  theLeft :: "'a + 'b \<Rightarrow> 'a" where
  "theLeft (Inl x) = x"

definition
 "isLeft x \<equiv> (\<exists>y. x = Inl y)"

definition
 "isRight x \<equiv> (\<exists>y. x = Inr y)"

definition
 "const x \<equiv> \<lambda>y. x"

lemma tranclD2:
  "(x, y) \<in> R\<^sup>+ \<Longrightarrow> \<exists>z. (x, z) \<in> R\<^sup>* \<and> (z, y) \<in> R"
  by (erule tranclE) auto

lemma linorder_min_same1 [simp]:
  "(min y x = y) = (y \<le> (x::'a::linorder))"
  by (auto simp: min_def linorder_not_less)

lemma linorder_min_same2 [simp]:
  "(min x y = y) = (y \<le> (x::'a::linorder))"
  by (auto simp: min_def linorder_not_le)

text \<open>A combinator for pairing up well-formed relations.
        The divisor function splits the population in halves,
        with the True half greater than the False half, and
        the supplied relations control the order within the halves.\<close>

definition
  wf_sum :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
where
  "wf_sum divisor r r' \<equiv>
     ({(x, y). \<not> divisor x \<and> \<not> divisor y} \<inter> r')
   \<union>  {(x, y). \<not> divisor x \<and> divisor y}
   \<union> ({(x, y). divisor x \<and> divisor y} \<inter> r)"

lemma wf_sum_wf:
  "\<lbrakk> wf r; wf r' \<rbrakk> \<Longrightarrow> wf (wf_sum divisor r r')"
  apply (simp add: wf_sum_def)
  apply (rule wf_Un)+
      apply (erule wf_Int2)
     apply (rule wf_subset
             [where r="measure (\<lambda>x. If (divisor x) 1 0)"])
      apply simp
     apply clarsimp
    apply blast
   apply (erule wf_Int2)
  apply blast
  done

abbreviation(input)
 "option_map == map_option"

lemmas option_map_def = map_option_case

lemma False_implies_equals [simp]:
  "((False \<Longrightarrow> P) \<Longrightarrow> PROP Q) \<equiv> PROP Q"
  apply (rule equal_intr_rule)
   apply (erule meta_mp)
   apply simp
  apply simp
  done

lemma split_paired_Ball:
  "(\<forall>x \<in> A. P x) = (\<forall>x y. (x,y) \<in> A \<longrightarrow> P (x,y))"
  by auto

lemma split_paired_Bex:
  "(\<exists>x \<in> A. P x) = (\<exists>x y. (x,y) \<in> A \<and> P (x,y))"
  by auto

end


(*
 * 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)
 *)

theory Memcpy
imports
  "../../../c-parser/CTranslation"
  "../../AutoCorres"
begin

(* Helper for noticing when you accidentally haven't constrained an of_nat *)
abbreviation "of_nat32 \<equiv> of_nat::(nat \<Rightarrow> word32)"

lemma byte_ptr_guarded:
    "ptr_val (x::8 word ptr) \<noteq> 0 \<Longrightarrow> c_guard x"
  unfolding c_guard_def c_null_guard_def ptr_aligned_def
  by (clarsimp simp: intvl_Suc)

(* FIXME: MOVE *)
lemma ptr_add_coerce: "ptr_val (((ptr_coerce x)::('a::{c_type}) ptr) +\<^sub>p a) = (ptr_val x) + (of_int a * of_nat (size_of TYPE('a)))"
  apply (case_tac x)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  done

(* FIXME: MOVE *)
(* Casting a valid pointer to char* and incrementing it by a value less than
 * the size of the underlying type does not give us NULL.
 *)
lemma ptr_contained:"\<lbrakk> c_guard (x::('a::c_type) ptr); size_of TYPE('a) = sz;
                       0 \<le> i; i < int sz; (y::8 word ptr) = ptr_coerce x\<rbrakk> \<Longrightarrow> c_guard (y +\<^sub>p i)"
  apply (rule byte_ptr_guarded)
  unfolding c_guard_def c_null_guard_def ptr_add_def
  apply simp
  apply (clarsimp simp: CTypesDefs.ptr_add_def intvl_def)
  apply (erule allE [where x="nat i"])
  apply (clarsimp simp: nat_less_iff of_nat_nat)
  done

install_C_file "memcpy.c"

(* FIXME: MOVE *)
lemma squash_auxupd_id[polish]:
  "modify (t_hrs_'_update (hrs_htd_update id)) = skip"
  by (monad_eq simp: skip_def id_def hrs_htd_update_def)

autocorres [no_heap_abs=memcpy memcpy_int] "memcpy.c"

(* Dereference a pointer *)
abbreviation "deref s x \<equiv> h_val (hrs_mem (t_hrs_' s)) x"

(* char* cast *)
abbreviation "byte_cast x \<equiv> ((ptr_coerce x)::8 word ptr)"

context memcpy begin

lemma memcpy_char:
  "\<lbrace> \<lambda>s. c_guard (x::8 word ptr) \<and>
         c_guard (y::8 word ptr) \<and>
         unat sz = size_of TYPE(8 word) \<and>
         P (deref s x) \<and>
         x \<noteq> y\<rbrace>
      memcpy' (ptr_coerce y) (ptr_coerce x) sz
   \<lbrace>\<lambda> _ s. P (deref s y) \<rbrace>!"
  (* Evaluate sz *)
  apply clarsimp

  unfolding memcpy'_def
  apply (clarsimp simp:skip_def)
  apply wp

  (* Unroll the loop twice *)
  apply (subst whileLoop_unroll, wp)
     apply (subst whileLoop_unroll, wp)

  (* The remaining loop is never encountered *)
       apply (rule validNF_false_pre)
      apply wp

  (* Finally we're left with the single assignment *)
  apply (clarsimp simp:hrs_mem_update h_val_heap_update)
  apply unat_arith
 done

lemma of_nat_prop_exp: "n < 32 \<Longrightarrow> of_nat (2 ^ n) = 2 ^ (of_nat n)"
  by clarsimp

lemma memcpy_word:
  "\<lbrace> \<lambda>s. c_guard (x::32 word ptr) \<and>
         c_guard (y::32 word ptr) \<and>
         unat sz = size_of TYPE(32 word) \<and>
         P (deref s x) \<and>
         x \<noteq> y \<rbrace>
      memcpy' (ptr_coerce y) (ptr_coerce x) sz
   \<lbrace> \<lambda>_ s. P (deref s y) \<rbrace>!"
  apply clarsimp
  unfolding memcpy'_def apply (clarsimp simp:skip_def)
  apply (rule validNF_assume_pre)
  apply (subgoal_tac "{ptr_val x ..+ unat sz} \<inter> {ptr_val y ..+ unat sz} = {}")
   apply (subst whileLoop_add_inv [where
     I="\<lambda>i s.  unat i \<le> unat sz \<and>
                (\<forall>a < i. deref s (byte_cast x +\<^sub>p uint a) = deref s (byte_cast y +\<^sub>p uint a)) \<and>
                P (deref s x)" and
     M="\<lambda>(i, s). unat sz - unat i"])
   apply (wp validNF_whileLoop_inv_measure_twosteps)
      apply clarsimp
      apply (rule conjI, unat_arith)
      apply (rule conjI, clarsimp)
       apply (case_tac "a = i")
        apply (clarsimp)
        apply (erule_tac x=i in allE)
        apply (clarsimp simp:hrs_mem_update h_val_heap_update)
        apply (subst h_val_heap_same)
            apply (rule ptr_retyp_h_t_valid)
            apply simp
           apply (rule ptr_retyp_disjoint)
            apply (rule ptr_retyp_h_t_valid)
            apply simp
           apply (clarsimp simp:ptr_add_def intvl_def CTypesDefs.ptr_add_def)
          apply simp
         apply (clarsimp simp: CTypesDefs.ptr_add_def field_of_t_simple)
         apply (drule field_of_t_simple)
         apply clarsimp
        apply simp
       apply (subgoal_tac "a < i")
        apply (clarsimp simp:hrs_mem_update)
        apply (subst h_val_heap_update_disjoint)

         (* The current goal should be obvious to unat_arith, but for some reason isn't *)
         apply (clarsimp simp:ptr_add_def intvl_def disjoint_iff_not_equal)
         apply (erule_tac x="ptr_val x + a" in allE, clarsimp)
         apply (erule impE)
          apply (rule_tac x="unat a" in exI, clarsimp)
          apply unat_arith

         apply (erule_tac x="ptr_val y + i" and
                          P="\<lambda>ya. (\<exists>k. ya = ptr_val y + of_nat k \<and> k < 4) \<longrightarrow> ptr_val y + i \<noteq> ya" in allE, clarsimp)
         apply (erule_tac x="unat i" in allE, clarsimp)
          apply unat_arith
         apply (clarsimp simp:CTypesDefs.ptr_add_def)
        apply (subst h_val_heap_update_disjoint)
         (* Similar goal to the previous irritation, but this time Isabelle decides to play ball *)
         apply (clarsimp simp:ptr_add_def intvl_def ptr_val_def disjoint_iff_not_equal)
        apply (clarsimp simp:CTypesDefs.ptr_add_def)
       apply (clarsimp simp:CTypesDefs.ptr_add_def)
      apply unat_arith

      apply (rule conjI)
       apply (subst hrs_mem_update)+
       apply (subst h_val_heap_update_disjoint)
        apply (clarsimp simp: disjoint_iff_not_equal)
        apply (clarsimp simp:CTypesDefs.ptr_add_def intvl_def)
        apply (erule_tac x="ptr_val x + of_nat k" in allE)
        apply (erule impE)
         apply (rule_tac x="k" in exI)
         apply simp
        apply (erule_tac x="ptr_val y + i" and
                         P="\<lambda>ya. (\<exists>k. ya = ptr_val y + of_nat k \<and> k < 4) \<longrightarrow> ptr_val x + of_nat k \<noteq> ya" in allE)
        apply (erule impE)
         apply (rule_tac x="unat i" in exI)
         apply simp
         apply unat_arith
        apply simp
       apply simp

      (* Yet more tedium that unat_arith doesn't like *)
      apply (rule conjI)
       apply (rule byte_ptr_guarded,
              clarsimp simp:CTypesDefs.ptr_add_def c_guard_def c_null_guard_def intvl_def,
              (erule_tac x="unat i" in allE)+,
              clarsimp,
              unat_arith)+

     apply wp
     apply unat_arith
    apply clarsimp
    apply (subgoal_tac "deref sa x = deref sa y")
     apply clarsimp
    apply (clarsimp simp: h_val_def)[1]
    apply (rule arg_cong[where f=from_bytes])
    apply (subst numeral_eqs(3))+
    apply simp
    apply (rule_tac x=0 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=1 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=2 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=3 in allE, assumption, erule impE, unat_arith)
    apply (simp add:CTypesDefs.ptr_add_def)
    apply (simp add: add.commute from_bytes_eq)
   apply clarsimp
  apply (clarsimp simp:intvl_def disjoint_iff_not_equal)
  apply (drule_tac x=x and y=y and j="of_nat k" and i="of_nat ka" and n=2 in neq_imp_bytes_disjoint)
        apply assumption
       apply (case_tac "k = 0", clarsimp) (* insert "k > 0" *)
       apply (clarsimp simp:unat_of_nat_len)
      apply (case_tac "ka = 0", clarsimp)
      apply (clarsimp simp:unat_of_nat_len)
     apply assumption
    apply clarsimp+
  done

text {* The bytes at the pointer @{term p} are @{term bs}. *}
definition
  bytes_at :: "'a globals_scheme \<Rightarrow> 'b::c_type ptr \<Rightarrow> word8 list \<Rightarrow> bool"
where
  "bytes_at s p bs \<equiv> length bs = 0 \<or>
                      (length bs \<le> UINT_MAX \<and> (\<forall>i \<in> {0..(length bs - 1)}. deref s (byte_cast p +\<^sub>p (of_nat i)) = bs ! i))"

lemma bytes_at_none[simp]: "bytes_at s p []"
  by (clarsimp simp:bytes_at_def)

text {* The bytes of typed pointer @{term p} are @{term bs}. *}
definition
  bytes_of :: "'a globals_scheme \<Rightarrow> 'b::c_type ptr \<Rightarrow> word8 list \<Rightarrow> bool"
where
  "bytes_of s p bs \<equiv> length bs = size_of TYPE('b) \<and> bytes_at s p bs"

text {* The bytes at a char pointer are just it dereferenced. *}
lemma bytes_of_char[simp]: "bytes_of s (p::8word ptr) bs = (length bs = 1 \<and> deref s p = hd bs)"
  apply (clarsimp simp:bytes_of_def bytes_at_def)
  apply (rule iffI)
   apply clarsimp
   apply (erule disjE)
    apply clarsimp+
   apply (rule hd_conv_nth[symmetric])
   apply clarsimp+
  apply (clarsimp simp:UINT_MAX_def)
  apply (subgoal_tac "hd bs = bs ! 0")
   apply simp
  apply (rule hd_conv_nth)
  apply clarsimp
  done

text {* A pointer does not wrap around memory. *}
definition
  no_wrap :: "'a::c_type ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "no_wrap p sz \<equiv> 0 \<notin> {ptr_val p ..+ sz}"

text {* Two pointers do not overlap. *}
definition
  no_overlap :: "'a::c_type ptr \<Rightarrow> 'b::c_type ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "no_overlap p q sz \<equiv> {ptr_val p ..+ sz} \<inter> {ptr_val q ..+ sz} = {}"

lemma no_overlap_sym: "no_overlap x y = no_overlap y x"
  apply (rule ext)
  apply (clarsimp simp:no_overlap_def)
  by blast

(* FIXME: MOVE *)
lemma h_val_not_id:
  fixes x :: "'a::mem_type ptr"
    and y :: "'b::mem_type ptr"
  shows "{ptr_val x..+size_of TYPE('a)} \<inter> {ptr_val y..+size_of TYPE('b)} = {}
     \<Longrightarrow> h_val (hrs_mem (hrs_mem_update (heap_update x v) s)) y = h_val (hrs_mem s) y"
  apply (subst hrs_mem_heap_update[symmetric])
  apply (subst h_val_heap_update_disjoint)
   apply blast
  apply clarsimp
  done

definition
  update_bytes :: "'a globals_scheme \<Rightarrow> 'b::mem_type ptr \<Rightarrow> word8 list \<Rightarrow> 'a globals_scheme"
where
  "update_bytes s p bs \<equiv> s\<lparr>t_hrs_' := hrs_mem_update (heap_update_list (ptr_val p) bs) (t_hrs_' s)\<rparr>"

lemma the_horse_says_neigh: "(s\<lparr>t_hrs_' := x\<rparr> = s\<lparr>t_hrs_' := y\<rparr>) = (x = y)"
 by (metis (erased, lifting) globals.cases_scheme globals.select_convs(1) globals.update_convs(1))

lemma upto_singleton[simp]:"[x..x] = [x]"
  by (simp add: upto_rec1)

lemma update_bytes_ignore_ptr_coerce[simp]: "update_bytes s (ptr_coerce p) = update_bytes s p"
  by (clarsimp simp:update_bytes_def intro!:ext)

lemma hrs_mem_update_commute:
  "f \<circ> g = g \<circ> f \<Longrightarrow> hrs_mem_update f (hrs_mem_update g s) = hrs_mem_update g (hrs_mem_update f s)"
  by (metis (no_types, lifting) comp_eq_elim hrs_htd_def hrs_htd_mem_update hrs_mem_def hrs_mem_f prod.collapse)

lemma hrs_mem_update_collapse:
  "hrs_mem_update f (hrs_mem_update g s) = hrs_mem_update (f \<circ> g) s"
  by (metis comp_eq_dest_lhs hrs_htd_def hrs_htd_mem_update hrs_mem_def hrs_mem_f prod.collapse)

lemma update_bytes_reorder:
  "{ptr_val p..+length cs} \<inter> {ptr_val q..+length bs} = {} \<Longrightarrow>
      update_bytes (update_bytes s q bs) p cs = update_bytes (update_bytes s p cs) q bs"
  apply (clarsimp simp:update_bytes_def)
  apply (subst the_horse_says_neigh)
  apply (subst hrs_mem_update_commute)
   apply (clarsimp intro!:ext)
   apply (subst heap_update_list_commute)
    apply clarsimp+
  done

lemma lt_step_down: "\<lbrakk>(x::nat) < y; x = y - 1 \<longrightarrow> P; x < y - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by force

(* XXX: This proof makes me sad. *)
lemma under_uint_imp_no_overflow: "x < UINT_MAX \<Longrightarrow> ((of_nat x)::word32) + 1 \<noteq> 0"
  apply (induct x)
   apply (clarsimp simp:UINT_MAX_def)+
  apply unat_arith
  apply (clarsimp simp:UINT_MAX_def)
  apply (cut_tac y=x and z="(of_nat (UINT_MAX - 1))::word32" in le_unat_uoi)
   apply (clarsimp simp:UINT_MAX_def)+
  done

lemma heap_update_list_append3:
  "1 + length ys < 2 ^ word_bits \<Longrightarrow>
    heap_update_list s (y # ys) hp = heap_update_list s [y] (heap_update_list (s + 1) ys hp)"
  apply clarsimp
  apply (subst heap_update_list_append2[where xs="[y]", simplified])
   apply clarsimp+
  done

lemma hrs_mem_update_cong': "f = g \<Longrightarrow> hrs_mem_update f s = hrs_mem_update g s"
  by presburger

lemma update_bytes_append: "length bs \<le> UINT_MAX \<Longrightarrow>
  update_bytes s p (b # bs) = update_bytes (update_bytes s p [b]) (byte_cast p +\<^sub>p 1) bs"
  apply (clarsimp simp:update_bytes_def)
  apply (subst the_horse_says_neigh)
  apply (subst hrs_mem_update_commute)
   apply (rule ext)+
   apply simp
   apply (case_tac "xa = ptr_val p")
    apply (clarsimp simp:fun_upd_def)
    apply (subst heap_update_nmem_same)
     apply (clarsimp simp:intvl_def ptr_add_def)
     apply (subgoal_tac "k < UINT_MAX")
      prefer 2
      apply unat_arith
     apply (drule under_uint_imp_no_overflow)
     apply unat_arith
    apply clarsimp
   apply (subst heap_update_list_update)
    apply simp
   apply (clarsimp simp:fun_upd_def)
  apply (subst hrs_mem_update_collapse)
  apply (rule hrs_mem_update_cong')
  apply (clarsimp simp:ptr_add_def)
  apply (rule ext)
  apply (cut_tac xs="[b]" and ys=bs and s="ptr_val p" and hp=x in heap_update_list_append)
  apply (clarsimp simp:fun_upd_def intro!:ext)
  apply (rule conjI)
   apply clarsimp
   apply (subst heap_update_nmem_same)
    apply (clarsimp simp:ptr_add_def intvl_def)
    apply (subgoal_tac "k < UINT_MAX")
     prefer 2
     apply unat_arith
    apply (drule under_uint_imp_no_overflow)
    apply unat_arith
   apply clarsimp
  apply clarsimp
  apply (case_tac "xa \<in> {ptr_val p + 1..+length bs}")
  apply (subst heap_update_mem_same_point)
    apply simp
   apply (subgoal_tac "addr_card = UINT_MAX + 1")
    apply clarsimp
   apply (clarsimp simp:addr_card UINT_MAX_def)
  apply (subst heap_update_mem_same_point)
    apply simp
   apply (subgoal_tac "addr_card = UINT_MAX + 1")
    apply clarsimp
   apply (clarsimp simp:addr_card UINT_MAX_def)
  apply clarsimp
  apply (subst heap_update_nmem_same)
   apply clarsimp
  apply (subst heap_update_nmem_same)
   apply clarsimp+
  done

lemma update_bytes_postpend: "length bs = x + 1 \<Longrightarrow>
  update_bytes s p bs = update_bytes (update_bytes s p (take x bs)) (byte_cast p +\<^sub>p (of_nat x)) [bs ! x]"
  apply (clarsimp simp:update_bytes_def)
  apply (subst the_horse_says_neigh)
  apply (clarsimp simp:ptr_add_def)
  apply (subst heap_update_list_concat_fold_hrs_mem)
   apply clarsimp+
  by (metis append_eq_conv_conj append_self_conv hd_drop_conv_nth2 lessI take_hd_drop)

lemma h_val_not_id_general:
  fixes y :: "'a::mem_type ptr"
  shows "\<forall>i \<in> {0..+size_of TYPE('a)}. \<forall>g. f g (ptr_val y + i) = g (ptr_val y + i)
     \<Longrightarrow> h_val (hrs_mem (hrs_mem_update f s)) y = h_val (hrs_mem s) y"
  apply (subst hrs_mem_update)
  apply (clarsimp simp:h_val_def)
  apply (subgoal_tac "heap_list (f (hrs_mem s)) (size_of TYPE('a)) (ptr_val y) =
                      heap_list (hrs_mem s) (size_of TYPE('a)) (ptr_val y)")
   apply clarsimp
  apply (cut_tac h="f (hrs_mem s)" and p="ptr_val y" and n="size_of TYPE('a)"
                 and h'="hrs_mem s" in heap_list_h_eq2)
   apply (erule_tac x="x - ptr_val y" in  ballE)
    apply clarsimp
   apply (clarsimp simp:intvl_def)+
  done

lemma h_val_not_id_list:
  fixes y :: "'a::mem_type ptr"
  shows "{x..+length vs} \<inter> {ptr_val y..+size_of TYPE('a)} = {}
     \<Longrightarrow> h_val (hrs_mem (hrs_mem_update (heap_update_list x vs) s)) y = h_val (hrs_mem s) y"
  apply (subst h_val_not_id_general)
   apply clarsimp
   apply (metis (erased, hide_lams) disjoint_iff_not_equal heap_update_nmem_same intvlD intvlI
          monoid_add_class.add.left_neutral)
  apply clarsimp
  done

lemma h_val_id_update_bytes:
  fixes q :: "'a::mem_type ptr"
  shows "{ptr_val q..+size_of TYPE('a)} \<inter> {ptr_val p..+length bs} = {}
          \<Longrightarrow> deref (update_bytes s p bs) q = deref s q"
  apply (clarsimp simp:update_bytes_def)
  apply (subst h_val_not_id_list)
   apply blast
  by simp

lemma bytes_at_len: "bytes_at s p bs \<Longrightarrow> length bs \<le> UINT_MAX"
  by (clarsimp simp:bytes_at_def, fastforce)

(* Another sad proof. *)
lemma le_uint_max_imp_id: "x \<le> UINT_MAX \<Longrightarrow> unat ((of_nat x)::word32) = x"
  apply (induct x)
   apply (clarsimp simp:UINT_MAX_def)+
  apply unat_arith
  apply clarsimp
  done

lemma update_bytes_id: "update_bytes s p [] = s"
  apply (clarsimp simp:update_bytes_def)
  apply (subst heap_update_list_base')
  by (simp add: hrs_mem_update_id3)

lemma a_horse_by_any_other_name: "t_hrs_'_update f s = s\<lparr>t_hrs_' := f (t_hrs_' s)\<rparr>"
  by auto

lemma heap_update_list_singleton: "heap_update_list p [x] = heap_update (Ptr p) x"
  apply (rule ext)
  by (metis heap_update_def ptr_val.simps to_bytes_word8)

lemma update_bytes_eq: "\<lbrakk>s = s'; p = p'; bs = bs'\<rbrakk> \<Longrightarrow> update_bytes s p bs = update_bytes s' p' bs'"
  by clarsimp

text {*
  Memcpy does what it says on the box.
*}
lemma memcpy_wp':
  fixes src :: "'a::mem_type ptr"
    and dst :: "'b::mem_type ptr"
  shows "\<forall>s0 bs.
  \<lbrace>\<lambda>s. s = s0 \<and> c_guard src \<and> c_guard dst \<and> sz = of_nat (length bs) \<and> bytes_at s src bs \<and>
       no_wrap src (unat sz) \<and> no_wrap dst (unat sz) \<and> no_overlap src dst (unat sz)\<rbrace>
    memcpy' (ptr_coerce dst) (ptr_coerce src) sz
  \<lbrace>\<lambda>r s. r = ptr_coerce dst \<and> bytes_at s dst bs \<and> s = update_bytes s0 dst bs\<rbrace>!"
  apply (rule allI)+
  apply (rule validNF_assume_pre)
  unfolding memcpy'_def
  apply clarsimp
  apply (subst whileLoop_add_inv[where
    I="\<lambda>i s. unat i \<le> unat sz \<and>
             bytes_at s dst (take (unat i) bs) \<and>
             bytes_at s src bs \<and>
             s = update_bytes s0 dst (take (unat i) bs)" and
    M="\<lambda>(i, s). unat sz - unat i"])
  apply wp
    apply clarsimp
    apply (rule conjI)
     apply unat_arith
    apply (rule conjI)
     apply (simp add:bytes_at_def)
     apply (case_tac "bs = []")
      apply (rule disjI1)
      apply clarsimp
     apply (rule disjI2)
     apply clarsimp
     apply (rule conjI)
      apply unat_arith
     apply clarsimp
     apply (case_tac "unat i = ia")
      apply clarsimp
      apply (subgoal_tac "int (unat i) = uint i")
       prefer 2
       apply (subst uint_nat)
       apply simp
      apply simp
      apply (subst h_val_id)
      apply (subst h_val_id_update_bytes)
       apply (clarsimp simp:no_overlap_def ptr_add_def)
       apply (subgoal_tac "{ptr_val src + i..+Suc 0} \<subseteq> {ptr_val src..+unat (of_nat32 (length bs))}")
        prefer 2
        apply (clarsimp simp:intvl_def)
        apply (rule_tac x="unat i" in exI)
        apply unat_arith
       apply (subgoal_tac "{ptr_val dst..+unat i} \<subseteq> {ptr_val dst..+unat (of_nat32 (length bs))}")
        prefer 2
        apply (clarsimp simp:intvl_def)
        apply (rule_tac x=ka in exI)
        apply unat_arith
       apply blast
      apply (erule_tac x="unat i" and P="\<lambda>x. deref s0 (byte_cast src +\<^sub>p int x) = bs ! x" in ballE)
       apply clarsimp
       apply (subst nth_take)
        apply unat_arith
       apply simp
      apply (erule disjE)
       apply clarsimp+
     apply (erule disjE)
      apply (subgoal_tac "length bs \<noteq> 0")
       prefer 2
       apply clarsimp
      apply (case_tac "unat i = 0")
       apply unat_arith
      apply linarith
     apply (subst h_val_not_id)
      apply (clarsimp simp:ptr_add_def intvl_def)
      (* Isabelle, why do you have to make it so hard? *)
      apply (erule_tac P="unat (of_nat ia) = ia" in notE)
      apply (cut_tac y=ia and z="(of_nat UINT_MAX)::word32" in le_unat_uoi)
       apply (subgoal_tac "unat ((of_nat UINT_MAX)::word32) = UINT_MAX")
        prefer 2
        apply (simp add:UINT_MAX_def)
       apply unat_arith
      apply clarsimp
     apply clarsimp
     apply (erule_tac x=ia and A="{0..min (length bs) (unat i) - Suc 0}" in ballE)
      apply clarsimp
      apply (subst nth_take, unat_arith)+
      apply simp
     apply clarsimp
     apply unat_arith
    apply (rule conjI)
     apply (clarsimp simp:bytes_at_def)
     apply (subst h_val_not_id)
      apply (clarsimp simp:no_overlap_def)
      apply (subgoal_tac "ptr_val (byte_cast dst +\<^sub>p uint i) \<in> {ptr_val dst..+unat (of_nat (length bs))}")
       prefer 2
       apply (clarsimp simp:ptr_add_def intvl_def)
       apply (rule_tac x="unat i" in exI)
       apply clarsimp
       apply unat_arith
      (* More or less symmetric subgoal *)
      apply (subgoal_tac "ptr_val (byte_cast src +\<^sub>p int ia) \<in> {ptr_val src..+unat ((of_nat (length bs))::word32)}")
       prefer 2
       apply (clarsimp simp:ptr_add_def intvl_def)
       apply (rule_tac x=ia in exI)
       apply clarsimp
       apply (subgoal_tac "unat ((of_nat (length bs))::word32) = length bs")
        apply clarsimp
        apply arith
       apply (cut_tac y="length bs" and z="(of_nat UINT_MAX)::word32" in le_unat_uoi)
        apply (clarsimp simp:UINT_MAX_def)
       apply arith
      apply (clarsimp simp:intvl_def ptr_add_def)
      apply blast
     apply clarsimp
    apply (rule conjI)
     apply (subst h_val_id_update_bytes)
      apply (clarsimp simp:no_overlap_def ptr_add_def)
      apply (subgoal_tac "{ptr_val src + i..+Suc 0} \<subseteq> {ptr_val src..+unat (of_nat32 (length bs))}")
       prefer 2
       apply (clarsimp simp:intvl_def)
       apply (rule_tac x="unat i" in exI)
       apply unat_arith
      apply (subgoal_tac "{ptr_val dst..+min (length bs) (unat i)} \<subseteq> {ptr_val dst..+unat (of_nat32 (length bs))}")
       prefer 2
       apply (clarsimp simp:intvl_def)
       apply (rule_tac x=ka in exI)
       apply unat_arith
      apply blast
     apply (subgoal_tac "deref s0 (byte_cast src +\<^sub>p uint i) = bs ! (unat i)")
      apply clarsimp
      apply (subgoal_tac "update_bytes s0 dst (take (unat (i + 1)) bs) =
                          update_bytes (update_bytes s0 dst (take (unat i) bs)) (byte_cast dst +\<^sub>p uint i) [bs ! unat i]")
       apply clarsimp
       apply (subgoal_tac
               "\<forall>s'. t_hrs_'_update (hrs_mem_update (heap_update (byte_cast dst +\<^sub>p uint i) (bs ! unat i))) s' =
                     update_bytes s' (byte_cast dst +\<^sub>p uint i) [bs ! unat i]")
        apply fast
       apply (clarsimp simp:update_bytes_def)
       apply (subst a_horse_by_any_other_name)
       apply (subst the_horse_says_neigh)
       apply (clarsimp simp:ptr_add_def)
       apply (subst heap_update_list_singleton)
       apply simp
      apply (cut_tac s=s0 and p=dst and bs="take (unat (i + 1)) bs" and x="unat i"
                     in update_bytes_postpend)
       apply (subgoal_tac "unat (i + 1) \<le> length bs")
        apply clarsimp
        apply unat_arith
       apply (subgoal_tac "unat i < length bs")
        apply unat_arith
       apply (rule unat_less_helper)
       apply simp
      apply clarsimp
      apply (rule update_bytes_eq)
        apply (subgoal_tac "min (unat i) (unat (i + 1)) = unat i")
         apply clarsimp
        apply clarsimp
        apply unat_arith
       apply (clarsimp simp:ptr_add_def)
      apply clarsimp
      apply (rule nth_take)
      apply unat_arith
     apply (clarsimp simp:bytes_at_def)
     apply (erule disjE)
      apply clarsimp
     apply clarsimp
     apply (erule_tac x="unat i" in ballE)
      apply (subst (asm) uint_nat[symmetric])
      apply simp
     apply clarsimp
     apply (subgoal_tac "unat i < length bs")
      prefer 2
      apply (rule unat_less_helper)
      apply simp
     apply unat_arith
    apply (rule conjI)
     apply unat_arith
    apply (rule conjI)
     apply (rule byte_ptr_guarded)
     apply (clarsimp simp:no_wrap_def intvl_def ptr_add_def)
     apply (erule_tac x="unat i" in allE)
     apply clarsimp
    apply (rule byte_ptr_guarded)
    apply (clarsimp simp:no_wrap_def intvl_def ptr_add_def)
    apply (erule_tac x="unat i" and
                     P="\<lambda>x. ptr_val dst + ((of_nat x)::word32) = 0 \<longrightarrow> \<not> x < unat ((of_nat (length bs))::word32)"
                    in allE)
    apply clarsimp
   apply clarsimp
   apply (rule conjI)
    apply (subgoal_tac "unat i = length bs")
     apply clarsimp
    apply (case_tac "length bs = 0")
     apply clarsimp
    apply (subgoal_tac "length bs \<le> UINT_MAX")
     prefer 2
     apply (clarsimp simp:bytes_at_def)
    (* XXX: We keep introducing this subgoal; we should do it once and for all up top. *)
    apply (subgoal_tac "unat ((of_nat (length bs))::word32) = length bs")
     prefer 2
     apply (cut_tac y="length bs" and z="(of_nat UINT_MAX)::word32" in le_unat_uoi)
      apply (clarsimp simp:UINT_MAX_def)
     apply clarsimp+
    apply unat_arith
   (* insert a bunch a tedium... *)
   apply (subgoal_tac "unat i = length bs")
    prefer 2
    apply (drule bytes_at_len)
    apply (subgoal_tac "unat (of_nat32 (length bs)) = length bs")
     prefer 2
     apply (rule le_uint_max_imp_id)
     apply simp
    apply unat_arith
   apply clarsimp
  apply (simp add:update_bytes_id)
  done

lemma validNF_make_schematic_post':
  "(\<forall>s0 x. \<lbrace> \<lambda>s. P s0 x s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 x rv s \<rbrace>!) \<Longrightarrow>
   \<lbrace> \<lambda>s. \<exists>s0 x. P s0 x s \<and> (\<forall>rv s'. Q s0 x 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)

lemmas memcpy_wp = memcpy_wp'[THEN validNF_make_schematic_post', simplified]

lemma h_val_not_id_update_bytes:
  fixes q :: "'a::mem_type ptr"
  shows "\<lbrakk>ptr_val p = ptr_val q; length bs = size_of TYPE('a)\<rbrakk> \<Longrightarrow>
            deref (update_bytes s p bs) q = from_bytes bs"
  apply (clarsimp simp:update_bytes_def h_val_def)
  apply (subst hrs_mem_update)
  apply (cut_tac p="ptr_val q" and v=bs and h="hrs_mem (t_hrs_' s)" in heap_list_update)
   apply clarsimp
   apply (metis less_imp_le max_size)
  by clarsimp

text {*
  Test that we can use memcpy in a compositional proof. The following proof can be done much more
  pleasantly, but we're just trying to check that the memcpy WP lemma is usable.
  TODO: This relies on disabling heap abstraction for the calling function as well. We should be
  able to phrase an exec_concrete WP lemma over memcpy that lets us prove properties about
  heap-abstracted callers. This will need AutoCorres support to connect is_valid_* with
  c_guard/no_overlap/no_wrap.
*}

definition
  memcpy_int_spec :: "sword32 ptr \<Rightarrow> sword32 ptr \<Rightarrow> bool"
where
  "memcpy_int_spec dst src \<equiv>
    \<forall>x. \<lbrace>\<lambda>s. deref s src = x \<and>
             {ptr_val src..+4} \<inter> {ptr_val dst..+4} = {} \<and>
             c_guard src \<and> c_guard dst \<and>
             no_wrap src 4 \<and> no_wrap dst 4\<rbrace>
          memcpy_int' dst src
        \<lbrace>\<lambda>_ s. deref s dst = x\<rbrace>!"

lemma memcpy_int_wp'[unfolded memcpy_int_spec_def]: "memcpy_int_spec dst src"
  unfolding memcpy_int_spec_def
  apply (rule allI)
  unfolding memcpy_int'_def
  apply (wp memcpy_wp)
  apply clarsimp
  apply (rule_tac x="[deref s (byte_cast src),
                      deref s (byte_cast src +\<^sub>p 1),
                      deref s (byte_cast src +\<^sub>p 2),
                      deref s (byte_cast src +\<^sub>p 3)]" in exI)
  apply (clarsimp simp:bytes_at_def no_overlap_def UINT_MAX_def)
  apply (rule conjI)
   apply clarsimp
   apply (case_tac "i = 0", clarsimp)
   apply (case_tac "i = 1", clarsimp)
   apply (case_tac "i = 2", clarsimp)
   apply (case_tac "i = 3", clarsimp)
   apply clarsimp
  apply clarsimp
  apply (subst h_val_not_id_update_bytes)
    apply clarsimp+
  apply (clarsimp simp:h_val_def)
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 4 (ptr_val src) =
                      deref s (byte_cast src) # (heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1))")
   prefer 2
   apply (clarsimp simp:h_val_def)
   apply (metis Suc_numeral from_bytes_eq heap_list_rec semiring_norm(2) semiring_norm(8))
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1) =
                      deref s (byte_cast src +\<^sub>p 1) # (heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2))")
   prefer 2
   apply (clarsimp simp:h_val_def ptr_add_def)
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 1" and n=2 in heap_list_rec)
   apply clarsimp
   apply (simp add: add.commute from_bytes_eq)
  apply clarsimp
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2) =
                      deref s (byte_cast src +\<^sub>p 2) # (heap_list (hrs_mem (t_hrs_' s)) 1 (ptr_val src + 3))")
   prefer 2
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 2" and n=3 in heap_list_rec)
   apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
   apply (metis (no_types, hide_lams) Suc_eq_plus1 heap_list_base heap_list_rec is_num_normalize(1)
                monoid_add_class.add.left_neutral one_add_one one_plus_numeral semiring_norm(3))
  apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
  done

text {* memcpying a typed variable is equivalent to assignment. *}
lemma memcpy_type_wp':
  fixes dst :: "'a::mem_type ptr"
    and src :: "'a::mem_type ptr"
  shows "\<forall>s0 bs.
   \<lbrace>\<lambda>s. s = s0 \<and> c_guard dst \<and> c_guard src \<and> sz = of_nat (size_of TYPE('a)) \<and>
        no_overlap dst src (unat sz) \<and> no_wrap dst (unat sz) \<and> no_wrap src (unat sz) \<and>
        bytes_of s src bs\<rbrace>
     memcpy' (ptr_coerce dst) (ptr_coerce src) sz
   \<lbrace>\<lambda>r s. r = ptr_coerce dst \<and> bytes_of s dst bs \<and> s = update_bytes s0 dst bs\<rbrace>!"
  apply (rule allI)+
  apply (wp memcpy_wp)
  apply clarsimp
  apply (rule_tac x=bs in exI)
  apply clarsimp
  apply (subst no_overlap_sym)
  apply (clarsimp simp:bytes_of_def)
  done

lemmas memcpy_type_wp = memcpy_type_wp'[THEN validNF_make_schematic_post', simplified]

text {* Confirm that we can also prove memcpy_int using the previous generic lemma. *}
lemma memcpy_int_wp''[unfolded memcpy_int_spec_def]: "memcpy_int_spec dst src"
  unfolding memcpy_int_spec_def memcpy_int'_def
  apply (rule allI)
  apply (wp memcpy_type_wp)
  (* Remainder mostly clagged from the original proof above. *)
  apply clarsimp
  apply (rule conjI, clarsimp simp:no_overlap_def, blast)
  apply (rule_tac x="[deref s (byte_cast src),
                      deref s (byte_cast src +\<^sub>p 1),
                      deref s (byte_cast src +\<^sub>p 2),
                      deref s (byte_cast src +\<^sub>p 3)]" in exI)
  apply (rule conjI)
   apply (clarsimp simp:bytes_of_def bytes_at_def UINT_MAX_def)
   apply (case_tac "i = 0", clarsimp)
   apply (case_tac "i = 1", clarsimp)
   apply (case_tac "i = 2", clarsimp)
   apply (case_tac "i = 3", clarsimp)
   apply clarsimp
  apply clarsimp
  apply (subst h_val_not_id_update_bytes, clarsimp+)
  apply (clarsimp simp:h_val_def)
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 4 (ptr_val src) =
                      deref s (byte_cast src) # (heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1))")
   prefer 2
   apply (clarsimp simp:h_val_def from_bytes_eq)
   apply (subst heap_list_rec[symmetric])
   apply simp
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1) =
                      deref s (byte_cast src +\<^sub>p 1) # (heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2))")
   prefer 2
   apply (clarsimp simp:h_val_def ptr_add_def)
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 1" and n=2 in heap_list_rec)
   apply (clarsimp simp: from_bytes_eq)
   apply (metis add.commute)
  apply clarsimp
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2) =
                      deref s (byte_cast src +\<^sub>p 2) # (heap_list (hrs_mem (t_hrs_' s)) 1 (ptr_val src + 3))")
   prefer 2
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 2" and n=3 in heap_list_rec)
   apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
   apply (metis (no_types, hide_lams) Suc_eq_plus1 heap_list_base heap_list_rec is_num_normalize(1)
                monoid_add_class.add.left_neutral one_add_one one_plus_numeral semiring_norm(3))
  apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
  done

lemma bytes_of_imp_at[simp]: "bytes_of s x bs \<Longrightarrow> bytes_at s x bs"
  by (clarsimp simp:bytes_of_def bytes_at_def)

lemma bytes_at_imp_of:
  fixes x :: "'a::mem_type ptr"
  shows "\<lbrakk>bytes_at s x bs; length bs = size_of TYPE('a)\<rbrakk> \<Longrightarrow> bytes_of s x bs"
  by (clarsimp simp:bytes_of_def bytes_at_def)

text {*
  Memcpying from a source to a destination via an intermediary does what it should. This is close to
  the desirable property we want for CAmkES systems; i.e. that copying into your IPC buffer on one
  side and then out on the other gives you back what you put in. Note that the type of the
  intermediate pointer is irrelevant and we don't need to assume that the source and final
  destination do not overlap.
*}
lemma memcpy_seq:
  fixes x :: "'a::mem_type ptr"
    and y :: "'b::mem_type ptr"
    and z :: "'a::mem_type ptr"
  shows "\<forall>s0 bs.
   \<lbrace>\<lambda>s. s = s0 \<and> sz = of_nat (size_of TYPE('a)) \<and>
        c_guard x \<and> c_guard y \<and> c_guard z \<and>
        no_wrap x (unat sz) \<and> no_wrap y (unat sz) \<and> no_wrap z (unat sz) \<and>
        no_overlap x y (unat sz) \<and> no_overlap y z (unat sz) \<and>
        bytes_of s x bs\<rbrace>
    do memcpy' (ptr_coerce y) (ptr_coerce x) sz;
       memcpy' (ptr_coerce z) (ptr_coerce y) sz
    od
   \<lbrace>\<lambda>r s. r = ptr_coerce z \<and> bytes_of s z bs\<rbrace>!"
  apply (rule allI)+
  apply (wp memcpy_wp)
  apply clarsimp
  apply (rule_tac x=bs in exI)
  apply clarsimp
  apply (rule conjI, clarsimp simp:bytes_of_def)
  apply clarsimp
  apply (rule_tac x=bs in exI)
  apply (rule conjI, clarsimp simp:bytes_of_def)
  apply clarsimp
  apply (rule bytes_at_imp_of)
   apply (clarsimp simp:bytes_of_def)+
  done

lemma update_ti_eq:
  fixes x :: "'a::mem_type"
    and y :: 'a
  shows "\<lbrakk>length bs = size_of TYPE('a); bs = bs'\<rbrakk>
          \<Longrightarrow> update_ti_t (typ_info_t TYPE('a)) bs x = update_ti_t (typ_info_t TYPE('a)) bs' y"
  by (clarsimp simp:upd)

lemma from_bytes_cong: "x = y \<Longrightarrow> from_bytes x = from_bytes y"
  by simp

declare from_bytes_eq [simp]

text {*
  If you dereference a pointer, the value you get is the same as the underlying bytes backing that
  memory.
*}
lemma val_eq_bytes:
  fixes x :: "'a::mem_type ptr"
  shows "deref s x = from_bytes (map (\<lambda>off. deref s (byte_cast x +\<^sub>p of_nat off)) [0..<size_of TYPE('a)])"
  apply (clarsimp simp:h_val_def ptr_add_def)
  apply (rule from_bytes_cong)
  apply (rule nth_equalityI)
   apply clarsimp+
  apply (subst heap_list_nth)
   apply clarsimp+
  done

lemma extract_list_elem: "i < n \<Longrightarrow> f i = (map f [0..<n]) ! i"
  apply (induct i)
   apply clarsimp+
  done

lemma update_deref:
  fixes x :: "'a::mem_type ptr"
  shows "size_of TYPE('a) = length bs \<Longrightarrow> deref (update_bytes s x bs) x = from_bytes bs"
  apply (clarsimp simp:update_bytes_def)
  apply (subst hrs_mem_update)
  apply (clarsimp simp:h_val_def)
  apply (subst heap_list_update)
   apply (metis less_imp_le max_size)
  apply clarsimp
  done

text {*
  The memcpy_int proof can now be completed more elegantly. Note that the body of this proof is more
  generic than the previous attempts and doesn't involve manually reasoning about each byte.
*}
lemma memcpy_int_wp'''[unfolded memcpy_int_spec_def]: "memcpy_int_spec dst src"
  unfolding memcpy_int_spec_def memcpy_int'_def
  apply (rule allI)
  apply (wp memcpy_type_wp)
  apply clarsimp
  apply (rule conjI, clarsimp simp:no_overlap_def, blast)
  apply (rule_tac x="map (\<lambda>i. deref s (byte_cast src +\<^sub>p of_nat i)) [0..<size_of TYPE(32sword)]" in exI)
  apply (rule conjI)
   apply (clarsimp simp:bytes_of_def bytes_at_def UINT_MAX_def)+
  apply (subst update_deref)
   apply clarsimp
  apply (cut_tac s=s and x=src in val_eq_bytes)
  apply clarsimp
  done

lemma bytes_at_heap_list:
  fixes x :: "'a::mem_type ptr"
  shows "\<lbrakk>n \<le> UINT_MAX; no_wrap x n\<rbrakk>
          \<Longrightarrow> bytes_at s x (heap_list (hrs_mem (t_hrs_' s)) n (ptr_val x))"
  apply (clarsimp simp:bytes_at_def ptr_add_def h_val_def)
  apply (subst heap_list_nth)
   apply unat_arith
  apply clarsimp
  done

text {*
  A collection of useful type-generic implications for moving from the abstract heap to the concrete
  heap.
*}
definition
  is_valid_imp_c_guard :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_c_guard is_valid \<equiv> \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> c_guard p"
definition
  is_valid_imp_no_null :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_no_null is_valid \<equiv>
     \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> 0 \<notin> {ptr_val p..of_nat (size_of TYPE('b))}"
definition
  is_valid_imp_no_wrap :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_no_wrap is_valid \<equiv>
     \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> no_wrap p (size_of TYPE('b))"
definition
  is_valid_imp_no_overlap :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_no_overlap is_valid \<equiv>
     \<forall>s p q. is_valid (lift_global_heap s) p \<and> is_valid (lift_global_heap s) q \<and> p \<noteq> q
               \<longrightarrow> no_overlap p q (size_of TYPE('b))"
definition
  is_valid_imp_heap_ptr_valid :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_heap_ptr_valid is_valid \<equiv>
     \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> heap_ptr_valid (hrs_htd (t_hrs_' s)) p"

text {* We can easily discharge these for a given type. *}
lemma is_valid_w32_imp_c_guard[unfolded is_valid_imp_c_guard_def, simplified]:
    "is_valid_imp_c_guard is_valid_w32"
  unfolding is_valid_imp_c_guard_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (rule simple_lift_c_guard, force)
  done

lemma is_valid_w32_imp_no_null[unfolded is_valid_imp_no_null_def, simplified]:
    "is_valid_imp_no_null is_valid_w32"
  unfolding is_valid_imp_no_null_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  by force

lemma is_valid_w32_imp_no_wrap[unfolded is_valid_imp_no_wrap_def, simplified]:
    "is_valid_imp_no_wrap is_valid_w32"
  unfolding is_valid_imp_no_wrap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  done

lemma is_valid_w32_imp_no_overlap[unfolded is_valid_imp_no_overlap_def, simplified]:
    "is_valid_imp_no_overlap is_valid_w32"
  unfolding is_valid_imp_no_overlap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)+
  apply clarsimp
  apply (drule simple_lift_heap_ptr_valid)+
  apply (clarsimp simp:no_overlap_def)
  apply (cut_tac p=p and q=q and d="hrs_htd (t_hrs_' s)" in heap_ptr_valid_neq_disjoint)
     apply clarsimp+
  done

lemma is_valid_w32_imp_heap_ptr_valid[unfolded is_valid_imp_heap_ptr_valid_def, simplified]:
    "is_valid_imp_heap_ptr_valid is_valid_w32"
  unfolding is_valid_imp_heap_ptr_valid_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  by (rule simple_lift_heap_ptr_valid, force)

text {*
  With that support in place, we can now prove a heap-abstracted call to memcpy of a type in a
  reasonably generic way. Note that we leverage the relationship between
  is_valid_*/lift_global_heap/simple_lift to transfer assumptions across the boundary between the
  abstract and concrete heaps.
*}
lemma
  fixes dst :: "32word ptr"
    and src :: "32word ptr"
  shows "\<forall>s0 x.
   \<lbrace>\<lambda>s. s = s0 \<and> is_valid_w32 s dst \<and> is_valid_w32 s src \<and> sz = of_nat (size_of TYPE(32word)) \<and>
        heap_w32 s src = x \<and> dst \<noteq> src\<rbrace>
     exec_concrete lift_global_heap (memcpy' (ptr_coerce dst) (ptr_coerce src) sz)
   \<lbrace>\<lambda>r s. r = ptr_coerce dst \<and> heap_w32 s dst = x\<rbrace>!"
  apply (rule allI)+
  apply (wp memcpy_wp)
  apply (clarsimp simp:is_valid_w32_imp_c_guard
                       is_valid_w32_imp_no_wrap
                       is_valid_w32_imp_no_overlap)
  apply (rule_tac x="map (\<lambda>i. deref s (byte_cast src +\<^sub>p of_nat i)) [0..<size_of TYPE(32word)]" in exI)
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp:bytes_at_def UINT_MAX_def)
  apply clarsimp
  apply (subst lifted_globals_ext_simps(3))+
  apply (clarsimp simp:simple_lift_def is_valid_w32_imp_heap_ptr_valid)
  apply (rule conjI)
   apply clarsimp
   apply (subst update_deref)
    apply clarsimp+
   apply (cut_tac s=s and x=src in val_eq_bytes)
   apply clarsimp
  apply (clarsimp simp:update_bytes_def is_valid_w32_imp_heap_ptr_valid)
  done

text {*
  Let's do the same instantiation for a structure. Note that the proof text for the following lemmas
  is identical to the word 32 instantiation above. These could be straightforwardly abstracted into
  a locale which could be automatically interpreted with the use of generated proofs.
*}
lemma is_valid_my_structure_imp_c_guard[unfolded is_valid_imp_c_guard_def, simplified]:
    "is_valid_imp_c_guard is_valid_my_structure_C"
  unfolding is_valid_imp_c_guard_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (rule simple_lift_c_guard, force)
  done

lemma is_valid_my_structure_imp_no_null[unfolded is_valid_imp_no_null_def, simplified]:
    "is_valid_imp_no_null is_valid_my_structure_C"
  unfolding is_valid_imp_no_null_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  by force

lemma is_valid_my_structure_imp_no_wrap[unfolded is_valid_imp_no_wrap_def, simplified]:
    "is_valid_imp_no_wrap is_valid_my_structure_C"
  unfolding is_valid_imp_no_wrap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  done

lemma is_valid_my_structure_imp_no_overlap[unfolded is_valid_imp_no_overlap_def, simplified]:
    "is_valid_imp_no_overlap is_valid_my_structure_C"
  unfolding is_valid_imp_no_overlap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)+
  apply clarsimp
  apply (drule simple_lift_heap_ptr_valid)+
  apply (clarsimp simp:no_overlap_def)
  apply (cut_tac p=p and q=q and d="hrs_htd (t_hrs_' s)" in heap_ptr_valid_neq_disjoint)
     apply clarsimp+
  done

lemma is_valid_my_structure_imp_heap_ptr_valid[unfolded is_valid_imp_heap_ptr_valid_def, simplified]:
    "is_valid_imp_heap_ptr_valid is_valid_my_structure_C"
  unfolding is_valid_imp_heap_ptr_valid_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  by (rule simple_lift_heap_ptr_valid, force)

text {*
  Again, we can now trivially transfer Hoare triple properties.
*}
lemma
  fixes dst :: "my_structure_C ptr"
    and src :: "my_structure_C ptr"
  shows "\<forall>s0 x.
   \<lbrace>\<lambda>s. s = s0 \<and> is_valid_my_structure_C s dst \<and> is_valid_my_structure_C s src \<and>
        heap_my_structure_C s src = x \<and> dst \<noteq> src\<rbrace>
     memcpy_struct' dst src
   \<lbrace>\<lambda>r s. r = dst \<and> heap_my_structure_C s dst = x\<rbrace>!"
  apply (rule allI)+
  unfolding memcpy_struct'_def
  apply (wp memcpy_wp)
  apply (clarsimp simp:is_valid_my_structure_imp_c_guard)
  apply (rule_tac x="map (\<lambda>i. deref s (byte_cast src +\<^sub>p of_nat i)) [0..<size_of TYPE(my_structure_C)]" in exI)
  apply (clarsimp simp:is_valid_my_structure_imp_no_wrap is_valid_my_structure_imp_no_overlap)
  apply (rule conjI)
   apply (clarsimp simp:bytes_at_def UINT_MAX_def)
  apply clarsimp
  apply (subst lifted_globals_ext_simps)+
  apply (clarsimp simp:simple_lift_def is_valid_my_structure_imp_heap_ptr_valid)
  apply (rule conjI)
   apply clarsimp
   apply (subst update_deref)
    apply clarsimp
   apply (cut_tac s=s and x=src in val_eq_bytes)
   apply clarsimp
  apply (clarsimp simp:update_bytes_def is_valid_my_structure_imp_heap_ptr_valid)
  done

end

end


theory ExpandLogicPhase
  imports Canonicalizations.Common
begin

phase ExpandLogicPhase
  terminating size
begin

lemma ExpandShortCircuitVal:
  assumes "x \<noteq> UndefVal \<and> y \<noteq> UndefVal"
  assumes "val[(x || y)] \<noteq> UndefVal"
  shows "val[((x || y) ? t : f)] = val[(x ? t : (y ? t : f))]"
  using assms apply (cases x; cases y; auto)
  using or_eq_0_iff by blast+

optimization ExpandShortCircuit:
  "((x || y) ? t : f) \<longmapsto> (x ? t : (y ? t : f))"
  defer apply simp
  using ExpandShortCircuitVal
  apply (smt (verit, ccfv_threshold) ConditionalExpr ConditionalExprE bin_eval.simps(7) evaltree_not_undef intval_conditional.elims unfold_binary)
  sorry

lemma swap_branches:
  assumes "x \<noteq> UndefVal \<and> \<not>x \<noteq> UndefVal"
  shows "val[(\<not>x) ? t : f] = val[x ? f : t]"
  using assms
  by simp

optimization ExpandShortCircuitXNeg:
  "(((\<not>x) || y) ? t : f) \<longmapsto> (x ? (y ? t : f) : t)"
  defer apply simp
  apply (rule allI)+ apply (rule impI)
  using ExpandShortCircuit(1) unfolding rewrite_preservation.simps le_expr_def

  using swap_branches
  sorry

  (*apply (smt (verit, ccfv_threshold) ConditionalExpr ConditionalExprE ExpandShortCircuit(1) intval_logic_negation.elims le_expr_def rewrite_preservation.simps(1) unary_eval.simps(4) unfold_unary val_to_bool.simps(1) val_to_bool.simps(2) zero_neq_one)
  sorry*)

optimization ExpandShortCircuitYNeg:
  "((x || (\<not>y)) ? t : f) \<longmapsto> (x ? t : (y ? f : t))"
  defer apply simp
  apply (rule allI)+ apply (rule impI)
  using ExpandShortCircuitVal
  sorry

optimization ExpandShortCircuitXYNeg:
  "(((\<not>x) || (\<not>y)) ? t : f) \<longmapsto> (x ? (y ? f : t) : t)"
  defer apply simp
  apply (rule allI)+ apply (rule impI)
  using ExpandShortCircuitVal swap_branches
  sorry

end

end


section \<open>Rewriting\<close>
theory Rewriting
  imports Terms_Positions
begin

subsection \<open>Basic rewrite definitions\<close>

subsubsection \<open>Rewrite steps with implicit signature declaration (encoded in the type)\<close>

inductive_set rrstep :: "('f, 'v) term rel \<Rightarrow> ('f, 'v) term rel" for \<R> where
  [intro]: "(l, r) \<in> \<R> \<Longrightarrow> (l \<cdot> \<sigma>, r \<cdot> \<sigma>) \<in> rrstep \<R>"

inductive_set rstep :: "('f, 'v) term rel \<Rightarrow> ('f, 'v) term rel" for \<R> where
  "(s, t) \<in> rrstep \<R> \<Longrightarrow> (C\<langle>s\<rangle>, C\<langle>t\<rangle>) \<in> rstep \<R>"

subsubsection \<open>Restrict relations to terms induced by a given signature\<close>

definition "sig_step \<F> \<R> = Restr \<R> (Collect (\<lambda> s. funas_term s \<subseteq> \<F>))"

subsubsection \<open>Rewriting under a given signature/restricted to ground terms\<close>

abbreviation "srrstep \<F> \<R> \<equiv> sig_step \<F> (rrstep \<R>)"
abbreviation "srstep \<F> \<R> \<equiv> sig_step \<F> (rstep \<R>)"
abbreviation "gsrstep \<F> \<R> \<equiv> Restr (sig_step \<F> (rstep \<R>)) (Collect ground)"

subsubsection \<open>Rewriting sequences involving a root step\<close>

abbreviation (input) relto :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "relto R S \<equiv> S^* O R O S^*"
definition "srsteps_with_root_step \<F> \<R> \<equiv> relto (sig_step \<F> (rrstep \<R>)) (srstep \<F> \<R>)"

subsection \<open>Monotonicity laws\<close>

lemma Restr_mono: "Restr r A \<subseteq> r" by auto

lemma Restr_trancl_mono_set: "(Restr r A)\<^sup>+ \<subseteq> A \<times> A"
  by (simp add: trancl_subset_Sigma)

lemma rrstep_rstep_mono: "rrstep \<R> \<subseteq> rstep \<R>"
  by (auto intro: rstep.intros[where ?C = \<box>, simplified])

lemma sig_step_mono:
  "\<F> \<subseteq> \<G> \<Longrightarrow> sig_step \<F> \<R> \<subseteq> sig_step \<G> \<R>"
  by (auto simp: sig_step_def)

lemma sig_step_mono2:
  "\<R> \<subseteq> \<L> \<Longrightarrow> sig_step \<F> \<R> \<subseteq> sig_step \<F> \<L>"
  by (auto simp: sig_step_def)

lemma srrstep_monp:
  "\<F> \<subseteq> \<G> \<Longrightarrow> srrstep \<F> \<R> \<subseteq> srrstep \<G> \<R>"
  by (simp add: sig_step_mono)

lemma srstep_monp:
  "\<F> \<subseteq> \<G> \<Longrightarrow> srstep \<F> \<R> \<subseteq> srstep \<G> \<R>"
  by (simp add: sig_step_mono)

lemma srsteps_monp:
  "\<F> \<subseteq> \<G> \<Longrightarrow> (srstep \<F> \<R>)\<^sup>+ \<subseteq> (srstep \<G> \<R>)\<^sup>+"
  by (simp add: sig_step_mono trancl_mono_set)

lemma srsteps_eq_monp:
  "\<F> \<subseteq> \<G> \<Longrightarrow> (srstep \<F> \<R>)\<^sup>* \<subseteq> (srstep \<G> \<R>)\<^sup>*"
  by (meson rtrancl_mono sig_step_mono subrelI subsetD trancl_into_rtrancl)

lemma srsteps_with_root_step_sig_mono:
   "\<F> \<subseteq> \<G> \<Longrightarrow> srsteps_with_root_step \<F> \<R> \<subseteq> srsteps_with_root_step \<G> \<R>"
  unfolding srsteps_with_root_step_def
  by (simp add: relcomp_mono srrstep_monp srsteps_eq_monp)

subsection \<open>Introduction, elimination, and destruction rules for @{const sig_step}, @{const rstep}, @{const rrstep},
   @{const srrstep}, and @{const srstep}\<close>

lemma sig_stepE [elim, consumes 1]:
  "(s, t) \<in> sig_step \<F> \<R> \<Longrightarrow> \<lbrakk>(s, t) \<in> \<R> \<Longrightarrow> funas_term s \<subseteq> \<F> \<Longrightarrow> funas_term t \<subseteq> \<F> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (auto simp: sig_step_def)

lemma sig_stepI [intro]:
  "funas_term s \<subseteq> \<F> \<Longrightarrow> funas_term t \<subseteq> \<F> \<Longrightarrow> (s, t) \<in> \<R> \<Longrightarrow> (s, t) \<in> sig_step \<F> \<R>"
  by (auto simp: sig_step_def)

lemma rrstep_subst [elim, consumes 1]:
  assumes "(s, t) \<in> rrstep \<R>"
  obtains l r \<sigma> where "(l, r) \<in> \<R>" "s = l \<cdot> \<sigma>" "t = r \<cdot> \<sigma>" using assms
  by (meson rrstep.simps)

lemma rstep_imp_C_s_r:
  assumes "(s, t) \<in> rstep \<R>"
  shows "\<exists>C \<sigma> l r. (l,r) \<in> \<R> \<and> s = C\<langle>l\<cdot>\<sigma>\<rangle> \<and> t = C\<langle>r\<cdot>\<sigma>\<rangle>"using assms
  by (metis rrstep.cases rstep.simps)

lemma rstep_imp_C_s_r' [elim, consumes 1]:
  assumes "(s, t) \<in> rstep \<R>"
  obtains C l r \<sigma> where "(l,r) \<in> \<R>" "s = C\<langle>l\<cdot>\<sigma>\<rangle>" "t = C\<langle>r\<cdot>\<sigma>\<rangle>" using assms
  using rstep_imp_C_s_r by blast

lemma rrstep_basicI [intro]:
  "(l, r) \<in> \<R> \<Longrightarrow> (l, r) \<in> rrstep \<R>"
  by (metis rrstepp.intros rrstepp_rrstep_eq subst_apply_term_empty)

lemma rstep_ruleI [intro]:
  "(l, r) \<in> \<R> \<Longrightarrow> (l, r) \<in> rstep \<R>"
  using rrstep_rstep_mono by blast

lemma rstepI [intro]:
  "(l, r) \<in> \<R> \<Longrightarrow> s = C\<langle>l \<cdot> \<sigma>\<rangle> \<Longrightarrow> t = C\<langle>r \<cdot> \<sigma>\<rangle> \<Longrightarrow> (s, t) \<in> rstep \<R>"
  by (simp add: rrstep.intros rstep.intros)

lemma rstep_substI [intro]:
  "(s, t) \<in> rstep \<R> \<Longrightarrow> (s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> rstep \<R>"
  by (auto elim!: rstep_imp_C_s_r' simp flip: subst_subst_compose)

lemma rstep_ctxtI [intro]:
  "(s, t) \<in> rstep \<R> \<Longrightarrow> (C\<langle>s\<rangle>, C\<langle>t\<rangle>) \<in> rstep \<R>"
  by (auto elim!: rstep_imp_C_s_r' simp flip: ctxt_ctxt_compose)

lemma srrstepD:
  "(s, t) \<in> srrstep \<F> \<R> \<Longrightarrow> (s, t) \<in> rrstep \<R> \<and> funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F>"
  by (auto simp: sig_step_def)

lemma srstepD:
  "(s, t) \<in> (srstep \<F> \<R>) \<Longrightarrow> (s, t) \<in> rstep \<R> \<and> funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F>"
  by (auto simp: sig_step_def)

lemma srstepsD:
  "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+ \<Longrightarrow> (s, t) \<in> (rstep \<R>)\<^sup>+ \<and> funas_term s \<subseteq> \<F> \<and> funas_term t \<subseteq> \<F>"
  unfolding sig_step_def using trancl_mono_set[OF Restr_mono]
  by (auto simp: sig_step_def dest: subsetD[OF Restr_trancl_mono_set])

subsubsection \<open>Transitive and relfexive closure distribution over @{const sig_step}\<close>

lemma funas_rel_converse:
  "funas_rel \<R> \<subseteq> \<F> \<Longrightarrow> funas_rel (\<R>\<inverse>) \<subseteq> \<F>" unfolding funas_rel_def
  by auto

lemma rstep_term_to_sig_r:
  assumes "(s, t) \<in> rstep \<R>" and "funas_rel \<R> \<subseteq> \<F>" and "funas_term s \<subseteq> \<F>"
  shows "(s, term_to_sig \<F> v t) \<in> rstep \<R>"
proof -
  from assms(1) obtain C l r \<sigma> where
    *: "s = C\<langle>l \<cdot> \<sigma>\<rangle>" "t = C\<langle>r \<cdot> \<sigma>\<rangle>" "(l, r) \<in> \<R>" by auto
  from assms(2, 3) *(3) have "funas_ctxt C \<subseteq> \<F>" "funas_term l \<subseteq> \<F>" "funas_term r \<subseteq> \<F>"
    by (auto simp: *(1) funas_rel_def funas_term_subst subset_eq)
  then have "(term_to_sig \<F> v s, term_to_sig \<F> v t) \<in> rstep \<R>" using *(3)
    by (auto simp: *(1, 2) funas_ctxt_ctxt_well_def_hole_path)
  then show ?thesis using assms(3) by auto
qed

lemma rstep_term_to_sig_l:
  assumes "(s, t) \<in> rstep \<R>" and "funas_rel \<R> \<subseteq> \<F>" and "funas_term t \<subseteq> \<F>"
  shows "(term_to_sig \<F> v s, t) \<in> rstep \<R>"
proof -
  from assms(1) obtain C l r \<sigma> where
    *: "s = C\<langle>l \<cdot> \<sigma>\<rangle>" "t = C\<langle>r \<cdot> \<sigma>\<rangle>" "(l, r) \<in> \<R>" by auto
  from assms(2, 3) *(3) have "funas_ctxt C \<subseteq> \<F>" "funas_term l \<subseteq> \<F>" "funas_term r \<subseteq> \<F>"
    by (auto simp: *(2) funas_rel_def funas_term_subst subset_eq)
  then have "(term_to_sig \<F> v s, term_to_sig \<F> v t) \<in> rstep \<R>" using *(3)
    by (auto simp: *(1, 2) funas_ctxt_ctxt_well_def_hole_path)
  then show ?thesis using assms(3) by auto
qed

lemma rstep_trancl_sig_step_r:
  assumes "(s, t) \<in> (rstep \<R>)\<^sup>+" and "funas_rel \<R> \<subseteq> \<F>" and "funas_term s \<subseteq> \<F>"
  shows "(s, term_to_sig \<F> v t) \<in> (srstep \<F> \<R>)\<^sup>+" using assms
proof (induct)
  case (base t)
  then show ?case using subsetD[OF fuans_term_term_to_sig, of _ \<F> v]
    by (auto simp: rstep_term_to_sig_r sig_step_def intro!: r_into_trancl)
next
  case (step t u)
  then have st: "(s, term_to_sig \<F> v t) \<in> (srstep \<F> \<R>)\<^sup>+" by auto
  from step(2) obtain  C l r \<sigma> where
    *: "t = C\<langle>l \<cdot> \<sigma>\<rangle>" "u = C\<langle>r \<cdot> \<sigma>\<rangle>" "(l, r) \<in> \<R>" by auto
  show ?case
  proof (cases "ctxt_well_def_hole_path \<F> C")
    case True
    from *(3) step(4) have "funas_term l \<subseteq> \<F>" "funas_term r \<subseteq> \<F>" by (auto simp: funas_rel_def)
    then have "(term_to_sig \<F> v t, term_to_sig \<F> v u) \<in> rstep \<R>"
      using True step(2) *(3) unfolding *
      by auto
    then have "(term_to_sig \<F> v t, term_to_sig \<F> v u) \<in> srstep \<F> \<R>"
      by (auto simp:_ sig_step_def)
    then show ?thesis using st by auto
  next
    case False
    then have "term_to_sig \<F> v t = term_to_sig \<F> v u" unfolding * by auto
    then show ?thesis using st by auto
  qed
qed

lemma rstep_trancl_sig_step_l:
  assumes "(s, t) \<in> (rstep \<R>)\<^sup>+" and "funas_rel \<R> \<subseteq> \<F>" and "funas_term t \<subseteq> \<F>"
  shows "(term_to_sig \<F> v s, t) \<in> (srstep \<F> \<R>)\<^sup>+" using assms
proof (induct rule: converse_trancl_induct)
  case (base t)
  then show ?case using subsetD[OF fuans_term_term_to_sig, of _ \<F> v]
    by (auto simp: rstep_term_to_sig_l sig_step_def intro!: r_into_trancl)
next
  case (step s u)
  then have st: "(term_to_sig \<F> v u, t) \<in> (srstep \<F> \<R>)\<^sup>+" by auto
  from step(1) obtain C l r \<sigma> where
    *: "s = C\<langle>l \<cdot> \<sigma>\<rangle>" "u = C\<langle>r \<cdot> \<sigma>\<rangle>" "(l, r) \<in> \<R>" by auto
  show ?case
  proof (cases "ctxt_well_def_hole_path \<F> C")
    case True
    from *(3) step(4) have "funas_term l \<subseteq> \<F>" "funas_term r \<subseteq> \<F>" by (auto simp: funas_rel_def)
    then have "(term_to_sig \<F> v s, term_to_sig \<F> v u) \<in> rstep \<R>"
      using True step(2) *(3) unfolding *
      by auto
    then have "(term_to_sig \<F> v s, term_to_sig \<F> v u) \<in> srstep \<F> \<R>"
      by (auto simp:_ sig_step_def)
    then show ?thesis using st by auto
  next
    case False
    then have "term_to_sig \<F> v s = term_to_sig \<F> v u" unfolding * by auto
    then show ?thesis using st by auto
  qed
qed

lemma rstep_srstepI [intro]:
  "funas_rel \<R> \<subseteq> \<F> \<Longrightarrow> funas_term s \<subseteq> \<F> \<Longrightarrow> funas_term t \<subseteq> \<F> \<Longrightarrow> (s, t) \<in> rstep \<R> \<Longrightarrow> (s, t) \<in> srstep \<F> \<R>"
  by blast

lemma rsteps_srstepsI [intro]:
  "funas_rel \<R> \<subseteq> \<F> \<Longrightarrow> funas_term s \<subseteq> \<F> \<Longrightarrow> funas_term t \<subseteq> \<F> \<Longrightarrow> (s, t) \<in> (rstep \<R>)\<^sup>+ \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  using rstep_trancl_sig_step_r[of s t \<R> \<F>]
  by auto

lemma rsteps_eq_srsteps_eqI [intro]:
  "funas_rel \<R> \<subseteq> \<F> \<Longrightarrow> funas_term s \<subseteq> \<F> \<Longrightarrow> funas_term t \<subseteq> \<F> \<Longrightarrow> (s, t) \<in> (rstep \<R>)\<^sup>* \<Longrightarrow> (s, t) \<in> (srstep \<F> \<R>)\<^sup>*"
  by (auto simp add: rtrancl_eq_or_trancl)

lemma rsteps_eq_relcomp_srsteps_eq_relcompI [intro]:
  assumes "funas_rel \<R> \<subseteq> \<F>" "funas_rel \<S> \<subseteq> \<F>"
    and funas: "funas_term s \<subseteq> \<F>" "funas_term t \<subseteq> \<F>"
    and steps: "(s, t) \<in> (rstep \<R>)\<^sup>* O (rstep \<S>)\<^sup>*"
  shows "(s, t) \<in> (srstep \<F> \<R>)\<^sup>* O (srstep \<F> \<S>)\<^sup>*"
proof -
  from steps obtain u where "(s, u) \<in> (rstep \<R>)\<^sup>*" "(u, t) \<in> (rstep \<S>)\<^sup>*" by auto
  then have "(s, term_to_sig \<F> v u) \<in> (srstep \<F> \<R>)\<^sup>*" "(term_to_sig \<F> v u, t) \<in> (srstep \<F> \<S>)\<^sup>*"
    using rstep_trancl_sig_step_l[OF _ assms(2) funas(2), of u v]
    using rstep_trancl_sig_step_r[OF _ assms(1) funas(1), of u v] funas
    by (auto simp: rtrancl_eq_or_trancl)
  then show ?thesis by auto
qed

subsubsection \<open>Distributivity laws\<close>

lemma rstep_smycl_dist:
  "(rstep \<R>)\<^sup>\<leftrightarrow> = rstep (\<R>\<^sup>\<leftrightarrow>)"
  by (auto simp: sig_step_def)

lemma sig_step_symcl_dist:
  "(sig_step \<F> \<R>)\<^sup>\<leftrightarrow> = sig_step \<F> (\<R>\<^sup>\<leftrightarrow>)"
  by (auto simp: sig_step_def)

lemma srstep_symcl_dist:
  "(srstep \<F> \<R>)\<^sup>\<leftrightarrow> = srstep \<F> (\<R>\<^sup>\<leftrightarrow>)"
  by (auto simp: sig_step_def)

lemma Restr_smycl_dist:
  "(Restr \<R> \<A>)\<^sup>\<leftrightarrow> = Restr (\<R>\<^sup>\<leftrightarrow>) \<A>"
  by auto

lemmas rew_symcl_inwards = rstep_smycl_dist sig_step_symcl_dist srstep_symcl_dist Restr_smycl_dist
lemmas rew_symcl_outwards = rew_symcl_inwards[symmetric]

lemma rstep_converse_dist:
  "(rstep \<R>)\<inverse> = rstep (\<R>\<inverse>)"
  by auto

lemma srrstep_converse_dist:
  "(srrstep \<F> \<R>)\<inverse> = srrstep \<F> (\<R>\<inverse>)"
  by (fastforce simp: sig_step_def)

lemma sig_step_converse_rstep:
  "(srstep \<F> \<R>)\<inverse> = sig_step \<F> ((rstep \<R>)\<inverse>)"
  by (meson converse.simps set_eq_subset sig_stepE(1) sig_stepE sig_stepI subrelI)

lemma srstep_converse_dist:
  "(srstep \<F> \<R>)\<inverse> = srstep \<F> (\<R>\<inverse>)"
  by (auto simp: sig_step_def)

lemma Restr_converse: "(Restr \<R> A)\<inverse> = Restr (\<R>\<inverse>) A"
  by auto

lemmas rew_converse_inwards = rstep_converse_dist srrstep_converse_dist sig_step_converse_rstep
   srstep_converse_dist Restr_converse trancl_converse[symmetric] rtrancl_converse[symmetric]
lemmas rew_converse_outwards = rew_converse_inwards[symmetric]

lemma sig_step_rsteps_dist:
  "funas_rel \<R> \<subseteq> \<F> \<Longrightarrow> sig_step \<F> ((rstep \<R>)\<^sup>+) = (srstep \<F> \<R>)\<^sup>+"
  by (auto elim!: sig_stepE dest: srstepsD)

lemma sig_step_rsteps_eq_dist:
  "funas_rel \<R> \<subseteq> \<F> \<Longrightarrow> sig_step \<F> ((rstep \<R>)\<^sup>+) \<union> Id = (srstep \<F> \<R>)\<^sup>*"
  by (auto simp: rtrancl_eq_or_trancl sig_step_rsteps_dist)

lemma sig_step_conversion_dist:
  "(srstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>* = (srstep \<F> (\<R>\<^sup>\<leftrightarrow>))\<^sup>*"
  by (auto simp: rtrancl_eq_or_trancl sig_step_rsteps_dist conversion_def srstep_symcl_dist)

lemma gsrstep_conversion_dist:
  "(gsrstep \<F> \<R>)\<^sup>\<leftrightarrow>\<^sup>* = (gsrstep \<F> (\<R>\<^sup>\<leftrightarrow>))\<^sup>*"
  by (auto simp: conversion_def rew_symcl_inwards)

lemma sig_step_grstep_dist:
  "gsrstep \<F> \<R> = sig_step \<F> (Restr (rstep \<R>) (Collect ground))"
  by (auto simp: sig_step_def)

subsection \<open>Substitution closure of @{const srstep}\<close>

lemma srstep_subst_closed:
  assumes "(s, t) \<in> srstep \<F> \<R>" "\<And> x. funas_term (\<sigma> x) \<subseteq> \<F>"
  shows "(s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> srstep \<F> \<R>" using assms
  by (auto simp: sig_step_def funas_term_subst)

lemma srsteps_subst_closed:
  assumes "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+" "\<And> x. funas_term (\<sigma> x) \<subseteq> \<F>"
  shows "(s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> (srstep \<F> \<R>)\<^sup>+" using assms(1)
proof (induct rule: trancl.induct)
  case (r_into_trancl s t) show ?case
    using srstep_subst_closed[OF r_into_trancl assms(2)]
    by auto
next
  case (trancl_into_trancl s t u)
  from trancl_into_trancl(2) show ?case
    using srstep_subst_closed[OF trancl_into_trancl(3) assms(2)]
    by (meson rtrancl_into_trancl1 trancl_into_rtrancl)
qed

lemma srsteps_eq_subst_closed:
  assumes "(s, t) \<in> (srstep \<F> \<R>)\<^sup>*" "\<And> x. funas_term (\<sigma> x) \<subseteq> \<F>"
  shows "(s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> (srstep \<F> \<R>)\<^sup>*" using assms srsteps_subst_closed
  by (metis rtrancl_eq_or_trancl)

lemma srsteps_eq_subst_relcomp_closed:
  assumes "(s, t) \<in> (srstep \<F> \<R>)\<^sup>* O (srstep \<F> \<S>)\<^sup>*" "\<And> x. funas_term (\<sigma> x) \<subseteq> \<F>"
  shows "(s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> (srstep \<F> \<R>)\<^sup>* O (srstep \<F> \<S>)\<^sup>*"
proof -
  from assms(1) obtain u where "(s, u) \<in> (srstep \<F> \<R>)\<^sup>*" "(u, t) \<in> (srstep \<F> \<S>)\<^sup>*" by auto
  then have "(s \<cdot> \<sigma>, u \<cdot> \<sigma>) \<in> (srstep \<F> \<R>)\<^sup>*" "(u \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> (srstep \<F> \<S>)\<^sup>*"
    using assms srsteps_eq_subst_closed
    by metis+
  then show ?thesis by auto
qed

subsection \<open>Context closure of @{const srstep}\<close>

lemma srstep_ctxt_closed:
  assumes "funas_ctxt C \<subseteq> \<F>" and "(s, t) \<in> srstep \<F> \<R>"
  shows "(C\<langle>s\<rangle>, C\<langle>t\<rangle>) \<in> srstep \<F> \<R>" using assms
  by (intro sig_stepI) (auto dest: srstepD)

lemma srsteps_ctxt_closed:
  assumes "funas_ctxt C \<subseteq> \<F>" and "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+"
  shows "(C\<langle>s\<rangle>, C\<langle>t\<rangle>) \<in> (srstep \<F> \<R>)\<^sup>+" using assms(2) srstep_ctxt_closed[OF assms(1)]
  by (induct) force+

lemma srsteps_eq_ctxt_closed:
  assumes "funas_ctxt C \<subseteq> \<F>" and "(s, t) \<in> (srstep \<F> \<R>)\<^sup>*"
  shows "(C\<langle>s\<rangle>, C\<langle>t\<rangle>) \<in> (srstep \<F> \<R>)\<^sup>*" using srsteps_ctxt_closed[OF assms(1)] assms(2)
  by (metis rtrancl_eq_or_trancl)

lemma sig_steps_join_ctxt_closed:
  assumes "funas_ctxt C \<subseteq> \<F>" and "(s, t) \<in> (srstep \<F> \<R>)\<^sup>\<down>"
  shows "(C\<langle>s\<rangle>, C\<langle>t\<rangle>) \<in> (srstep \<F> \<R>)\<^sup>\<down>" using srsteps_eq_ctxt_closed[OF assms(1)] assms(2)
  unfolding join_def rew_converse_inwards
  by auto

text \<open>The following lemma shows that every rewrite sequence either contains a root step or is root stable\<close>

lemma nsrsteps_with_root_step_step_on_args:
  assumes "(s, t) \<in> (srstep \<F> \<R>)\<^sup>+" "(s, t) \<notin> srsteps_with_root_step \<F> \<R>"
  shows "\<exists> f ss ts. s = Fun f ss \<and> t = Fun f ts \<and> length ss = length ts \<and>
    (\<forall> i < length ts. (ss ! i, ts ! i) \<in> (srstep \<F> \<R>)\<^sup>*)" using assms
proof (induct)
  case (base t)
  obtain C l r \<sigma> where [simp]: "s = C\<langle>l \<cdot> \<sigma>\<rangle>" "t = C\<langle>r \<cdot> \<sigma>\<rangle>" and r: "(l, r) \<in> \<R>"
    using base(1) unfolding sig_step_def
    by blast
  then have funas: "funas_ctxt C \<subseteq> \<F>" "funas_term (l \<cdot> \<sigma>) \<subseteq> \<F>" "funas_term (r \<cdot> \<sigma>) \<subseteq> \<F>"
    using base(1) by (auto simp: sig_step_def)
  from funas(2-) r have "(l \<cdot> \<sigma>, r \<cdot> \<sigma>) \<in> srrstep \<F> \<R>"
    by (auto simp: sig_step_def)
  then have "C = Hole \<Longrightarrow> False" using base(2) r
    by (auto simp: srsteps_with_root_step_def)
  then obtain f ss D ts where [simp]: "C = More f ss D ts" by (cases C) auto
  have "(D\<langle>l \<cdot> \<sigma>\<rangle>, D\<langle>r \<cdot> \<sigma>\<rangle>) \<in> (srstep \<F> \<R>)" using base(1) r funas
    by (auto simp: sig_step_def)
  then show ?case using funas by (auto simp: nth_append_Cons)
next
  case (step t u) show ?case
  proof (cases "(s, t) \<in> srsteps_with_root_step \<F> \<R> \<or> (t, u) \<in> sig_step \<F> (rrstep \<R>)")
    case True then show ?thesis using step(1, 2, 4)
      by (auto simp add: relcomp3_I rtrancl.rtrancl_into_rtrancl srsteps_with_root_step_def)
  next
    case False
    obtain C l r \<sigma> where *[simp]: "t = C\<langle>l \<cdot> \<sigma>\<rangle>" "u = C\<langle>r \<cdot> \<sigma>\<rangle>" and r: "(l, r) \<in> \<R>"
      using step(2) unfolding sig_step_def by blast
    then have funas: "funas_ctxt C \<subseteq> \<F>" "funas_term (l \<cdot> \<sigma>) \<subseteq> \<F>" "funas_term (r \<cdot> \<sigma>) \<subseteq> \<F>"
      using step(2) by (auto simp: sig_step_def)
    from False have "C \<noteq> Hole" using funas r by (force simp: sig_step_def)
    then obtain f ss D ts where c[simp]: "C = More f ss D ts" by (cases C) auto
    from step(3, 1) False obtain g sss tss where
      **[simp]: "s = Fun g sss" "t = Fun g tss" and l: "length sss = length tss" and
      inv: "\<forall> i < length tss. (sss ! i, tss ! i) \<in> (srstep \<F> \<R>)\<^sup>*"
      by auto
    have [simp]: "g = f" and lc: "Suc (length ss + length ts) = length sss"
      using l *(1) unfolding c using **(2) by auto
    then have "\<forall> i < Suc (length ss + length ts). ((ss @ D\<langle>l \<cdot> \<sigma>\<rangle> # ts) ! i, (ss @ D\<langle>r \<cdot> \<sigma>\<rangle> # ts) ! i) \<in> (srstep \<F> \<R>)\<^sup>*"
      using * funas r by (auto simp: nth_append_Cons r_into_rtrancl rstep.intros rstepI sig_stepI)
    then have "i < length tss \<Longrightarrow> (sss ! i, (ss @ D\<langle>r \<cdot> \<sigma>\<rangle> # ts) ! i) \<in> (srstep \<F> \<R>)\<^sup>*" for i
      using inv * l lc funas **
      by (auto simp: nth_append_Cons simp del: ** * split!: if_splits)
    then show ?thesis using inv l lc * unfolding c
      by auto
  qed
qed

lemma rstep_to_pos_replace:
  assumes "(s, t) \<in> rstep \<R>"
  shows "\<exists> p l r \<sigma>. p \<in> poss s \<and> (l, r) \<in> \<R> \<and> s |_ p = l \<cdot> \<sigma> \<and> t = s[p \<leftarrow> r \<cdot> \<sigma>]"
proof -
  from assms obtain C l r \<sigma> where st: "(l, r) \<in> \<R>" "s = C\<langle>l \<cdot> \<sigma>\<rangle>" "t = C\<langle>r \<cdot> \<sigma>\<rangle>"
    using rstep_imp_C_s_r by fastforce
  from st(2, 3) have *: "t = s[hole_pos C \<leftarrow> r \<cdot> \<sigma>]" by simp
  from this st show ?thesis unfolding *
    by (intro exI[of _ "hole_pos C"]) auto
qed

lemma pos_replace_to_rstep:
  assumes "p \<in> poss s" "(l, r) \<in> \<R>"
    and "s |_ p = l \<cdot> \<sigma>" "t = s[p \<leftarrow> r \<cdot> \<sigma>]"
  shows "(s, t) \<in> rstep \<R>"
  using assms(1, 3-) replace_term_at_subt_at_id [of s p]
  by (intro rstepI[OF assms(2), of s "ctxt_at_pos s p" \<sigma>])
     (auto simp add: ctxt_of_pos_term_apply_replace_at_ident)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Words of Length 16"

theory Word_16
imports
  More_Word
  Signed_Words
begin

lemma len16: "len_of (x :: 16 itself) = 16" by simp

context
  includes bit_operations_syntax
begin

lemma word16_and_max_simp:
  \<open>x AND 0xFFFF = x\<close> for x :: \<open>16 word\<close>
  using word_and_full_mask_simp [of x]
  by (simp add: numeral_eq_Suc mask_Suc_exp)

end

end