\<^marker>\<open>creator Florian Keßler\<close>

section "Binary Operations in IMP--"

theory Binary_Operations
  imports IMP_Minus_To_IMP_Minus_Minus_State_Translations IMP_Minus.Max_Constant
    IMP_Minus_Minus_Subprograms
begin

text \<open> We give programs in IMP-- that work on states translated from IMP- to IMP-- and simulate
       the arithmetic expressions of IMP-. They work by first loading the operands into some special
       operand registers, and then performing standard binary addition / subtraction. \<close>

type_synonym IMP_Minus_com = Com.com
type_synonym IMP_Minus_Minus_com = com

unbundle Com.no_com_syntax

fun com_list_to_seq:: "IMP_Minus_Minus_com list \<Rightarrow> IMP_Minus_Minus_com" where
"com_list_to_seq [] = SKIP" |
"com_list_to_seq (c # cs) = c ;; (com_list_to_seq cs)"

lemma t_small_step_fun_com_list_to_seq_terminates: "t1 + t2 < t
  \<Longrightarrow> t_small_step_fun t1 (com_list_to_seq as, s1) = (SKIP, s3)
  \<Longrightarrow> t_small_step_fun t2 (com_list_to_seq bs, s3) = (SKIP, s2)
  \<Longrightarrow> t_small_step_fun t (com_list_to_seq (as @ bs), s1) = (SKIP, s2)"
proof(induction as arbitrary: s1 t1 t)
  case Nil
  then show ?case using t_small_step_fun_increase_time
    by (metis Pair_inject append_self_conv2 com_list_to_seq.simps le_add2
        less_imp_le_nat t_small_step_fun_SKIP)
next
  case (Cons a as)
  then obtain ta sa where ta_def: "ta < t1 \<and> t_small_step_fun ta (a, s1) = (SKIP, sa)
    \<and> t_small_step_fun (t1 - (ta + 1)) (com_list_to_seq as, sa) = (SKIP, s3)"
    by (auto simp: seq_terminates_iff)
  hence "t_small_step_fun (t - (ta + 1)) (com_list_to_seq (as @ bs), sa) = (SKIP, s2)"
    apply -
    apply(rule Cons(1))
    using Cons by(auto)
  thus ?case using ta_def Cons seq_terminates_iff by fastforce
qed

lemma com_list_to_seq_of_length_one_terminates_iff:
  "t_small_step_fun t (com_list_to_seq [c], s1) = (SKIP, s2) \<longleftrightarrow>
  (t > 0 \<and> t_small_step_fun (t - 1) (c, s1) = (SKIP, s2))"
  apply(auto simp: seq_terminates_iff)
  using t_small_step_fun_increase_time apply (metis One_nat_def diff_Suc_1 le_add1 less_imp_Suc_add)
  using diff_Suc_less by blast

lemma com_list_to_seq_variables: "set (enumerate_variables (com_list_to_seq cs))
  = { v | v c. c \<in> set cs \<and> v \<in> set (enumerate_variables c)}"
  apply(induction cs)
  by(auto simp: set_enumerate_variables_seq)

fun binary_assign_constant:: "nat \<Rightarrow> vname \<Rightarrow> nat \<Rightarrow> IMP_Minus_Minus_com" where
"binary_assign_constant 0 v x = SKIP" |
"binary_assign_constant (Suc n) v x = (var_bit_to_var (v, n)) ::= nth_bit x n ;;
  binary_assign_constant n v x"

lemma result_of_binary_assign_constant: "t_small_step_fun (3 * n)
  (binary_assign_constant n v x, s)
  = (SKIP, \<lambda>w. (case var_to_var_bit w of
      Some (w', m) \<Rightarrow> (if w' = v \<and> m < n then Some (nth_bit x m) else s w) |
      _ \<Rightarrow> s w))"
proof(induction n arbitrary: s)
  case (Suc n)
  thus ?case
    apply auto
    apply(rule seq_terminates_when[where ?t1.0=1 and ?t2.0="3*n" and
          ?s3.0="s(var_bit_to_var (v, n) \<mapsto> nth_bit x n)"])
    by(auto simp: fun_eq_iff var_to_var_bit_eq_Some_iff  split: option.splits)
qed (auto simp: fun_eq_iff split: option.splits)

lemma binary_assign_constant_variables: "set (enumerate_variables (binary_assign_constant n v x))
  = { var_bit_to_var (v, i) | i. i < n }"
  apply(induction n)
  by(auto simp: set_enumerate_variables_seq)

lemma result_of_binary_assign_constant_on_translated_state_aux:
  assumes "n > 0"
  shows "t_small_step_fun (3 * n) (binary_assign_constant n v x,
    IMP_Minus_State_To_IMP_Minus_Minus s n)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus (s(v := x)) n)"
  apply(subst result_of_binary_assign_constant)
  using assms
  by (auto simp: fun_eq_iff IMP_Minus_State_To_IMP_Minus_Minus_def
      IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def split: option.splits)

lemma result_of_binary_assign_constant_on_translated_state:
  assumes "n > 0"
  shows "t_small_step_fun (50 * (n + 1)) (binary_assign_constant n v x,
    IMP_Minus_State_To_IMP_Minus_Minus s n)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus (s(v := x)) n)"
  apply(rule t_small_step_fun_increase_time[where ?t="3*n"])
  apply simp
  apply(subst result_of_binary_assign_constant_on_translated_state_aux)
  using assms by auto

fun copy_var_to_operand:: "nat \<Rightarrow> char \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"copy_var_to_operand 0 op v = SKIP" |
"copy_var_to_operand (Suc i) op v =
   (IF [var_bit_to_var (v, i)] \<noteq>0 THEN
   (operand_bit_to_var (op, i)) ::= One
    ELSE
    (operand_bit_to_var (op, i)) ::= Zero) ;;
    copy_var_to_operand i op v "

lemma copy_var_to_operand_result:
  "t_small_step_fun (4 * n) (copy_var_to_operand n op v, s)
  = (SKIP, \<lambda>w. (case var_to_operand_bit w of
    Some (op', i) \<Rightarrow> (if op' = op \<and> i < n
  then (case s (var_bit_to_var (v, i)) of Some x \<Rightarrow> Some x | None \<Rightarrow> Some One)
  else s w) |
    _ \<Rightarrow> s w))"
proof(induction n arbitrary: s)
  case 0
  then show ?case by (auto simp: fun_eq_iff split: option.splits)
next
  case (Suc n)
  let ?s' = "s(operand_bit_to_var (op, n)
    \<mapsto> (case s (var_bit_to_var (v, n)) of Some x \<Rightarrow> x | None \<Rightarrow> One))"
  show ?case using Suc
    by(auto simp: fun_eq_iff var_to_operand_bit_eq_Some_iff numeral_3_eq_3 less_Suc_eq_le
      split!: option.splits if_splits
      intro!: seq_terminates_when[where ?t1.0=3 and ?t2.0="4 * n" and ?s3.0="?s'"])
qed

fun copy_const_to_operand:: "nat \<Rightarrow> char \<Rightarrow> nat \<Rightarrow> IMP_Minus_Minus_com" where
"copy_const_to_operand 0 op x = SKIP" |
"copy_const_to_operand (Suc i) op x =
   (operand_bit_to_var (op, i)) ::= (nth_bit x i) ;;
    copy_const_to_operand i op x "

lemma copy_const_to_operand_result:
  "t_small_step_fun (4 * n) (copy_const_to_operand n op x, s)
  = (SKIP, \<lambda>w. (case var_to_operand_bit w of
    Some (op', i) \<Rightarrow> (if op' = op \<and> i < n then Some (nth_bit x i) else s w) |
    _ \<Rightarrow> s w))"
proof(induction n arbitrary: s)
  case 0
  then show ?case by (simp add: fun_eq_iff split: option.splits)
next
  case (Suc n)
  let ?s' = "s(operand_bit_to_var (op, n) \<mapsto> nth_bit x n)"
  show ?case using Suc
    apply(auto simp: fun_eq_iff var_to_operand_bit_eq_Some_iff split!: option.splits if_splits
      intro!: seq_terminates_when[where ?t1.0=1 and ?t2.0 ="4*n" and ?s3.0="?s'"])
  using less_antisym by blast
qed

definition copy_atom_to_operand:: "nat \<Rightarrow> char \<Rightarrow> AExp.atomExp \<Rightarrow> IMP_Minus_Minus_com" where
"copy_atom_to_operand n op a = (case a of
  AExp.N x \<Rightarrow> copy_const_to_operand n op x |
  AExp.V x \<Rightarrow> copy_var_to_operand n op x)"

lemma copy_atom_to_operand_a_result:
  "t_small_step_fun (4 * n) (copy_atom_to_operand n (CHR ''a'') a,
   IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n b c)
  = (SKIP,  IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n (AExp.atomVal a s) c)"
  by(auto simp: copy_atom_to_operand_def fun_eq_iff copy_const_to_operand_result
      copy_var_to_operand_result IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def
      var_to_operand_bit_eq_Some_iff
      split!: option.splits AExp.atomExp.splits char.splits bool.splits)

lemma copy_atom_to_operand_b_result:
  "t_small_step_fun (4 * n) (copy_atom_to_operand n (CHR ''b'') a,
   IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n b c)
  = (SKIP,  IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n b (AExp.atomVal a s))"
  by(auto simp: copy_atom_to_operand_def fun_eq_iff copy_const_to_operand_result
      copy_var_to_operand_result IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def
      var_to_operand_bit_eq_Some_iff
      split!: option.splits AExp.atomExp.splits char.splits bool.splits)

lemma copy_atom_to_operand_variables:
  "set (enumerate_variables (copy_atom_to_operand n op a))
    = { operand_bit_to_var (op, i) | i. i < n }
    \<union> { var_bit_to_var (v, i) | i v. i < n \<and> v \<in> set (atomExp_var a) }"
  apply (induction n)
  apply(cases a)
    apply (auto simp: copy_atom_to_operand_def enumerate_variables_def)[1]
   apply (auto simp: copy_atom_to_operand_def enumerate_variables_def)[1]
  apply(cases a)
   apply (auto simp: copy_atom_to_operand_def set_enumerate_variables_seq)
  by(auto simp: enumerate_variables_def var_bit_to_var_neq_operand_bit_to_var[symmetric])

definition assign_var_carry::
  "nat \<Rightarrow> vname \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> IMP_Minus_Minus_com" where
"assign_var_carry i v a b c =
  (var_bit_to_var (v, i)) ::= (if a + b + c = 1 \<or> a + b + c = 3 then One else Zero) ;;
  ''carry'' ::= (if a + b + c \<ge> 2 then One else Zero)"

lemma result_of_assign_var_carry:
  "t_small_step_fun 7 (assign_var_carry i v a b c, s)
    = (SKIP, s(var_bit_to_var (v, i) \<mapsto> (if a + b + c = 1 \<or> a + b + c = 3 then One else Zero),
     ''carry'' \<mapsto> (if a + b + c \<ge> 2 then One else Zero)))"
  by(auto simp: assign_var_carry_def t_small_step_fun_terminate_iff)

definition full_adder:: "nat \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"full_adder i v  = (let assign = assign_var_carry i v; op_a = operand_bit_to_var (CHR ''a'', i);
  op_b = operand_bit_to_var (CHR ''b'', i) in
  IF [op_a]\<noteq>0 THEN
    IF [''carry'']\<noteq>0 THEN
      IF [op_b]\<noteq>0 THEN assign 1 1 1
      ELSE assign 1 1 0
    ELSE
      IF [op_b]\<noteq>0 THEN assign 1 0 1
      ELSE assign 1 0 0
  ELSE
    IF [''carry'']\<noteq>0 THEN
      IF [op_b]\<noteq>0 THEN assign 0 1 1
      ELSE assign 0 1 0
    ELSE
      IF [op_b]\<noteq>0 THEN assign 0 0 1
      ELSE assign 0 0 0)"

lemma full_adder_correct:
  assumes "i = 0 \<longrightarrow> s ''carry'' = Some Zero"
    "i > 0 \<longrightarrow> s ''carry'' = Some (nth_carry (i - 1) a b)"
    "s (operand_bit_to_var (CHR ''a'', i)) = Some (nth_bit a i)"
    "s (operand_bit_to_var (CHR ''b'', i)) = Some (nth_bit b i)"
  shows "t_small_step_fun 10 (full_adder i v, s) = (SKIP,
    s(var_bit_to_var (v, i) \<mapsto> nth_bit (a + b) i, ''carry'' \<mapsto> nth_carry i a b))"
  using assms
  apply(simp add: full_adder_def Let_def t_small_step_fun_terminate_iff result_of_assign_var_carry)
  apply(cases i)
  by(simp_all add: fun_eq_iff first_bit_of_add nth_bit_of_add)

lemma full_adder_variables: "set (enumerate_variables (full_adder i v)) =
  { operand_bit_to_var (CHR ''a'', i), operand_bit_to_var (CHR ''b'', i), var_bit_to_var (v, i),
    ''carry''}"
  apply (auto simp: full_adder_def Let_def)
  by(simp_all add: enumerate_variables_def assign_var_carry_def split: if_splits)

lemma sequence_of_full_adders:
  assumes
    "s ''carry'' = Some Zero"
    "\<forall>j < k. s (operand_bit_to_var (CHR ''a'', j)) = Some (nth_bit a j)"
    "\<forall>j < k. s (operand_bit_to_var (CHR ''b'', j)) = Some (nth_bit b j)"
  shows
   "t_small_step_fun (12 * k) (com_list_to_seq (map (\<lambda>i. full_adder i v) [0..< k]), s)
  = (SKIP, (\<lambda>w. (case var_to_var_bit w of
    Some (w', m) \<Rightarrow> (if w' = v \<and> m < k then Some (nth_bit (a + b) m) else s w) |
    _ \<Rightarrow> (if w = ''carry'' \<and> k > 0 then Some (nth_carry (k - 1) a b)
          else s w))))"
  using assms
proof(induction k)
  case 0
  then show ?case by(auto simp: fun_eq_iff split: option.splits)
next
  case (Suc k)
  hence "t_small_step_fun (12 + 12 * k)
   (com_list_to_seq ((map (\<lambda>i. full_adder i v) [0..< k]) @ [full_adder k v]), s)
    = (SKIP, (\<lambda>w. (case var_to_var_bit w of
    Some (w', m) \<Rightarrow> (if w' = v \<and> m < Suc k then Some (nth_bit (a + b) m) else s w) |
    _ \<Rightarrow> (if w = ''carry'' \<and> Suc k > 0 then Some (nth_carry k a b)
          else s w))))"
    apply(auto simp only: com_list_to_seq_of_length_one_terminates_iff
        intro!: t_small_step_fun_com_list_to_seq_terminates[where ?t1.0="12 * k" and ?t2.0=11])
    apply(auto)
    apply(subst full_adder_correct)
    by(auto simp add: fun_eq_iff var_to_var_bit_eq_Some_iff split!: option.splits)
  thus ?case by auto
qed

definition adder:: "nat \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"adder n v = com_list_to_seq (map (\<lambda>i. full_adder i v) [0..< n]) ;;
  ''carry'' ::= Zero"

lemma result_of_adder:
  assumes "a + b < 2 ^ n"
  shows "t_small_step_fun (12 * n + 2) (adder n v,
    IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n a b)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b (s(v := a + b)) n a b)"
  apply(simp only: adder_def)
  apply(rule seq_terminates_when[OF _  sequence_of_full_adders,
        where ?t2.0="1" and ?b="''carry'' ::= Zero"])
  by(auto simp: fun_eq_iff IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def
      split: option.splits)

definition binary_adder:: "nat \<Rightarrow> vname \<Rightarrow> AExp.atomExp \<Rightarrow> AExp.atomExp \<Rightarrow> IMP_Minus_Minus_com" where
"binary_adder n v a b =
  copy_atom_to_operand n (CHR ''a'') a ;;
  (copy_atom_to_operand n (CHR ''b'') b ;;
  (adder n v ;;
  (copy_atom_to_operand n (CHR ''a'') (AExp.N 0) ;;
  copy_atom_to_operand n (CHR ''b'') (AExp.N 0))))"

lemma binary_adder_correct:
  assumes "n > 0"
    "AExp.atomVal a s + AExp.atomVal b s < 2 ^ n"
  shows "t_small_step_fun (50 * (n + 1)) (binary_adder n v a b,
    IMP_Minus_State_To_IMP_Minus_Minus s n)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus (s(v := AExp.atomVal a s + AExp.atomVal b s)) n)"
  using seq_terminates_when'[OF copy_atom_to_operand_a_result[where ?n=n]
      seq_terminates_when'[OF copy_atom_to_operand_b_result
      seq_terminates_when'[OF result_of_adder
      seq_terminates_when'[OF copy_atom_to_operand_a_result copy_atom_to_operand_b_result]]]]
  assms
  by(fastforce simp: binary_adder_def IMP_Minus_State_To_IMP_Minus_Minus_def)

definition assign_var_carry_sub::
  "nat \<Rightarrow> vname \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> IMP_Minus_Minus_com" where
"assign_var_carry_sub i v a b c =
  (var_bit_to_var (v, i)) ::= (if b + c = 0 \<or> b + c = 2 then (if a = 1 then One else Zero)
    else (if b + c = 1 \<and> a = 0 then One else Zero)) ;;
  ''carry'' ::= (if a < b + c then One else Zero)"

lemma result_of_assign_var_carry_sub:
  "t_small_step_fun 7 (assign_var_carry_sub i v a b c, s)
    = (SKIP, s(var_bit_to_var (v, i) \<mapsto> (if b + c = 0 \<or> b + c = 2 then (if a = 1 then One else Zero)
    else (if b + c = 1 \<and> a = 0 then One else Zero)),
     ''carry'' \<mapsto>  (if a < b + c then One else Zero)))"
  by(auto simp: assign_var_carry_sub_def t_small_step_fun_terminate_iff)

definition full_subtractor:: "nat \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"full_subtractor i v  = (let assign = assign_var_carry_sub i v;
  op_a = [operand_bit_to_var (CHR ''a'', i)];
  op_b = [operand_bit_to_var (CHR ''b'', i)] in
  IF op_a\<noteq>0 THEN
    IF [''carry'']\<noteq>0 THEN
      IF op_b\<noteq>0 THEN assign 1 1 1
      ELSE assign 1 1 0
    ELSE
      IF op_b\<noteq>0 THEN assign 1 0 1
      ELSE assign 1 0 0
  ELSE
    IF [''carry'']\<noteq>0 THEN
      IF op_b\<noteq>0 THEN assign 0 1 1
      ELSE assign 0 1 0
    ELSE
      IF op_b\<noteq>0 THEN assign 0 0 1
      ELSE assign 0 0 0)"

lemma full_subtractor_correct_no_underflow:
  assumes "a \<ge> b"
    "i = 0 \<longrightarrow> s ''carry'' = Some Zero"
    "i > 0 \<longrightarrow> s ''carry'' = Some (nth_carry_sub (i - 1) a b)"
    "s (operand_bit_to_var (CHR ''a'', i)) = Some (nth_bit a i)"
    "s (operand_bit_to_var (CHR ''b'', i)) = Some (nth_bit b i)"
  shows "t_small_step_fun 10 (full_subtractor i v, s) = (SKIP,
    s(var_bit_to_var (v, i) \<mapsto> nth_bit (a - b) i, ''carry'' \<mapsto> nth_carry_sub i a b))"
  using assms
  apply(simp add: full_subtractor_def Let_def t_small_step_fun_terminate_iff
      result_of_assign_var_carry_sub)
  apply(cases i)
  by(simp_all add: fun_eq_iff first_bit_of_sub_n_no_underflow nth_bit_of_sub_n_no_underflow Let_def)

lemma full_subtractor_variables: "set (enumerate_variables (full_subtractor i v)) =
  { operand_bit_to_var (CHR ''a'', i), operand_bit_to_var (CHR ''b'', i), var_bit_to_var (v, i),
    ''carry''}"
  apply (auto simp: full_subtractor_def Let_def)
  by(simp_all add: enumerate_variables_def assign_var_carry_sub_def split: if_splits)

lemma sequence_of_full_subtractors_no_underflow:
  assumes "a \<ge> b"
    "s ''carry'' = Some Zero"
    "\<forall>j < n. s (operand_bit_to_var (CHR ''a'', j)) = Some (nth_bit a j)"
    "\<forall>j < n. s (operand_bit_to_var (CHR ''b'', j)) = Some (nth_bit b j)"
  shows
   "t_small_step_fun (12 * n)
                       (com_list_to_seq (map (\<lambda>i. full_subtractor i v) [0..< n]), s)
  = (SKIP, (\<lambda>w. (case var_to_var_bit w of
    Some (w', m) \<Rightarrow> (if w' = v \<and> m < n then Some (nth_bit (a - b) m) else s w) |
    _ \<Rightarrow> (if w = ''carry'' \<and> n > 0 then Some (nth_carry_sub (n - 1) a b)
          else s w))))"
  using assms
proof(induction n)
  case 0
  then show ?case by(auto simp: fun_eq_iff split: option.splits)
next
  case (Suc n)
  have "t_small_step_fun (12 + 12 * n)
   (com_list_to_seq ((map (\<lambda>i. full_subtractor i v) [0..< n]) @ [full_subtractor n v]), s)
    = (SKIP, (\<lambda>w. (case var_to_var_bit w of
    Some (w', m) \<Rightarrow> (if w' = v \<and> m < Suc n then Some (nth_bit (a - b) m) else s w) |
    _ \<Rightarrow> (if w = ''carry'' \<and> Suc n > 0 then Some (nth_carry_sub n a b)
          else s w))))"
    apply(rule t_small_step_fun_com_list_to_seq_terminates[OF _ Suc.IH
          iffD2[OF com_list_to_seq_of_length_one_terminates_iff[where ?t="11"]]])
    using Suc  apply(auto)
    apply(subst full_subtractor_correct_no_underflow)
    using Suc
    by(auto simp add: fun_eq_iff var_to_var_bit_eq_Some_iff split!: option.splits)
  thus ?case by auto
qed

lemma sequence_of_full_subtractors_with_underflow:
  assumes "a < b"
    "a < 2^n" "b < 2^n"
    "s ''carry'' = Some Zero"
    "\<forall>j < n. s (operand_bit_to_var (CHR ''a'', j)) = Some (nth_bit a j)"
    "\<forall>j < n. s (operand_bit_to_var (CHR ''b'', j)) = Some (nth_bit b j)"
  shows
   "t_small_step_fun (12 * n)
                       (com_list_to_seq (map (\<lambda>i. full_subtractor i v) [0..< n]), s)
  = (SKIP, (\<lambda>w. (case var_to_var_bit w of
    Some (w', m) \<Rightarrow> (if w' = v \<and> m < n then Some (nth_bit (2^n + a - b) m) else s w) |
    _ \<Rightarrow> (if w = ''carry'' \<and> n > 0 then Some One
          else s w))))"
proof -
  have "\<forall>j < n. s (operand_bit_to_var (CHR ''a'', j)) = Some (nth_bit (2 ^ n + a) j)"
    using nth_bit_add_out_of_range[OF \<open>a < 2^n\<close>]
      \<open>\<forall>j < n. s (operand_bit_to_var (CHR ''a'', j)) = Some (nth_bit a j)\<close> by simp
  moreover have "2 ^ n + a > b" using \<open>b < 2^n\<close> by simp
  ultimately have "t_small_step_fun (12 * n)
                       (com_list_to_seq (map (\<lambda>i. full_subtractor i v) [0..< n]), s)
  = (SKIP, (\<lambda>w. (case var_to_var_bit w of
    Some (w', m) \<Rightarrow> (if w' = v \<and> m < n then Some (nth_bit (2^n + a - b) m) else s w) |
    _ \<Rightarrow> (if w = ''carry'' \<and> n > 0 then Some (nth_carry_sub (n - 1) (2^n + a) b)
          else s w))))"
    using sequence_of_full_subtractors_no_underflow[where ?a="2^n + a" and ?b=b] assms
    by(auto simp: fun_eq_iff)
  thus ?thesis using assms nth_carry_sub_underflow by auto
qed

definition underflow_handler:: "nat \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"underflow_handler n v = (IF [''carry'']\<noteq>0 THEN (''carry'' ::= Zero ;;
  binary_assign_constant n v 0)
  ELSE SKIP)"

definition subtract_handle_underflow::
  "nat \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"subtract_handle_underflow n v =
  com_list_to_seq (map (\<lambda>i. full_subtractor i v) [0..<n]) ;;
  underflow_handler n v"

lemma result_of_subtract_handle_underflow:
  assumes "n > 0" "a < 2 ^ n" "b < 2 ^ n"
  shows "t_small_step_fun (15 * n + 4) (subtract_handle_underflow n v,
    IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n a b)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b (s(v := a - b)) n a b)"
proof(cases "a < b")
  case True
  then show ?thesis
    apply(simp only: subtract_handle_underflow_def)
    apply(rule seq_terminates_when[OF _  sequence_of_full_subtractors_with_underflow[where ?a=a and ?b=b],
          where ?t2.0="3 * n + 3"])
    using assms apply(auto simp add: underflow_handler_def t_small_step_fun_terminate_iff)
     apply(auto simp add: t_small_step_fun_small_step_fun result_of_binary_assign_constant fun_eq_iff)
    by(auto simp:  IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_changed_s_neq_iff
        var_to_var_bit_eq_Some_iff split!: option.splits if_splits)
next
  case False
  then show ?thesis
    apply(simp only: subtract_handle_underflow_def)
    apply(rule seq_terminates_when[OF _  sequence_of_full_subtractors_no_underflow[where ?a=a and ?b=b],
          where ?t2.0="3 * n + 3"])
    using assms apply(auto simp add: underflow_handler_def t_small_step_fun_terminate_iff)
       apply(auto simp add: t_small_step_fun_small_step_fun result_of_binary_assign_constant fun_eq_iff)
    using nth_carry_sub_no_underflow[OF _ \<open>a < 2 ^ n\<close> \<open>b < 2 ^ n\<close>]
    apply(auto simp:  IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_changed_s_neq_iff
        var_to_var_bit_eq_Some_iff
        split!: option.splits if_splits)
    by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def)
qed

lemma subtract_handle_underflow_variables:
  "set (enumerate_variables (subtract_handle_underflow n v))
  = { operand_bit_to_var (op, i) | i op. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') }
    \<union> { var_bit_to_var (v, i) | i. i < n }
    \<union> { ''carry'' }"
  by(auto simp: subtract_handle_underflow_def
      set_enumerate_variables_seq com_list_to_seq_variables full_subtractor_variables
      set_enumerate_variables_if underflow_handler_def binary_assign_constant_variables)

definition binary_subtractor:: "nat \<Rightarrow> vname \<Rightarrow> AExp.atomExp \<Rightarrow> AExp.atomExp \<Rightarrow> IMP_Minus_Minus_com" where
"binary_subtractor n v a b =
  copy_atom_to_operand n (CHR ''a'') a ;;
  (copy_atom_to_operand n (CHR ''b'') b ;;
  (subtract_handle_underflow n v ;;
  (copy_atom_to_operand n (CHR ''a'') (AExp.N 0) ;;
  copy_atom_to_operand n (CHR ''b'') (AExp.N 0))))"

lemma binary_subtractor_correct:
  assumes "n > 0"
    "AExp.atomVal a s < 2 ^ n" "AExp.atomVal b s < 2 ^ n"
  shows "t_small_step_fun (50 * (n + 1)) (binary_subtractor n v a b,
    IMP_Minus_State_To_IMP_Minus_Minus s n)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus (s(v := AExp.atomVal a s - AExp.atomVal b s)) n)"
  using seq_terminates_when'[OF copy_atom_to_operand_a_result[where ?n=n]
      seq_terminates_when'[OF copy_atom_to_operand_b_result
      seq_terminates_when'[OF result_of_subtract_handle_underflow
      seq_terminates_when'[OF copy_atom_to_operand_a_result copy_atom_to_operand_b_result]]]]
  assms
  by(fastforce simp: binary_subtractor_def IMP_Minus_State_To_IMP_Minus_Minus_def)

text \<open> The two copy_atom_to_operand which don't have any effect on the output are only a hack to
       ensure that all bits of all variables in IMP- occur in IMP-- \<close>

fun binary_parity:: "nat \<Rightarrow> vname \<Rightarrow> AExp.atomExp \<Rightarrow> IMP_Minus_Minus_com" where
"binary_parity n v (N a) = binary_assign_constant n v (a mod 2)" |
"binary_parity n v (V a) = (IF [var_bit_to_var (a, 0)]\<noteq>0 THEN
    binary_assign_constant n v 1
  ELSE
    binary_assign_constant n v 0) ;;
  (copy_atom_to_operand n (CHR ''a'') (AExp.V a) ;;
  copy_atom_to_operand n (CHR ''a'') (AExp.N 0))"

lemma binary_parity_correct:
  assumes "n > 0"
  shows "t_small_step_fun (50 * (n + 1)) (binary_parity n v a,
    IMP_Minus_State_To_IMP_Minus_Minus s n)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus (s(v := atomVal a s mod 2)) n)"
  apply(cases a)
   apply simp
   apply(rule result_of_binary_assign_constant_on_translated_state[OF \<open>n > 0\<close>, simplified])
  apply(simp add: IMP_Minus_State_To_IMP_Minus_Minus_def)
  apply(subst seq_terminates_when
      [OF _ _ seq_terminates_when[OF _ copy_atom_to_operand_a_result copy_atom_to_operand_a_result],
        where ?t1.0="3 * n + 1" and ?t2.0="9 * n"])
  using result_of_binary_assign_constant_on_translated_state_aux \<open>n > 0\<close>
  by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_def nth_bit_def nat_to_bit_eq_One_iff
      t_small_step_fun_small_step_fun nat_to_bit_eq_Zero_iff split: if_splits)

lemma binary_parity_variables: "n > 0 \<Longrightarrow> set (enumerate_variables (binary_parity n v a))
  = { var_bit_to_var (v, i) | i. i < n }
    \<union> (case a of (V v') \<Rightarrow>
        { var_bit_to_var (v', i) | i. i < n } \<union> { operand_bit_to_var (CHR ''a'', i) | i. i < n } |
        _ \<Rightarrow> ({}))"
  apply(cases a)
  by(auto simp: binary_assign_constant_variables copy_atom_to_operand_variables
      var_bit_to_var_neq_operand_bit_to_var[symmetric]
      set_enumerate_variables_seq set_enumerate_variables_if)

fun assign_shifted_bits:: "nat \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"assign_shifted_bits 0 v = SKIP" |
"assign_shifted_bits (Suc i) v = (IF [operand_bit_to_var ((CHR ''a''), Suc i)]\<noteq>0 THEN
    (var_bit_to_var (v, i)) ::= One
  ELSE
    (var_bit_to_var (v, i)) ::= Zero) ;;
  assign_shifted_bits i v"

lemma result_of_assign_shifted_bits:
  "t_small_step_fun (3 * k) (assign_shifted_bits k v, s) = (SKIP, (\<lambda>w.
    (case var_to_var_bit w of Some(v', i) \<Rightarrow> (if v' = v \<and> i < k then
      (if s (operand_bit_to_var (CHR ''a'', Suc i)) \<noteq> Some Zero then Some One else Some Zero)
      else s w) |
      _ \<Rightarrow> s w)))"
proof(induction k arbitrary: s)
  case (Suc k)
  have *: "t_small_step_fun 2 (IF [operand_bit_to_var ((CHR ''a''), Suc k)]\<noteq>0 THEN
      (var_bit_to_var (v, k)) ::= One
   ELSE
      (var_bit_to_var (v, k)) ::= Zero, s) = (SKIP, s(var_bit_to_var (v, k) \<mapsto>
        (if s (operand_bit_to_var (CHR ''a'', Suc k)) \<noteq> Some Zero then One else Zero)))"
    by(auto simp: numeral_2_eq_2)
  show ?case
    using seq_terminates_when[OF _ * Suc.IH, where ?t="3 + 3 * k"]
    apply (auto simp: fun_eq_iff var_to_var_bit_eq_Some_iff split: option.splits)
    using var_bit_to_var_neq_operand_bit_to_var
    by (metis operand_bit_to_var.simps)+
qed (auto simp: fun_eq_iff split: option.splits)

lemma assign_shifted_bits_variables: "set (enumerate_variables (assign_shifted_bits k v))
  = { var_bit_to_var (v, i) | i. i < k } \<union> { operand_bit_to_var (CHR ''a'', i) | i. i > 0 \<and> i \<le> k }"
  apply(induction k)
   apply(auto simp: set_enumerate_variables_seq set_enumerate_variables_if)
  using operand_bit_to_var_eq_operand_bit_to_var_iff'
  by (metis Suc_eq_plus1 le_SucE)

definition assign_shifted_bits_and_zero_most_significant::
  "nat \<Rightarrow> vname \<Rightarrow> IMP_Minus_Minus_com" where
"assign_shifted_bits_and_zero_most_significant n v = assign_shifted_bits (n - 1) v ;;
  (var_bit_to_var (v, n - 1)) ::= Zero"

lemma assign_shifted_bits_and_zero_most_significant_correct:
  assumes "n > 0" "a < 2 ^ n"
  shows "t_small_step_fun (3 * n) (assign_shifted_bits_and_zero_most_significant n v,
    IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b s n a b)
    = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b (s(v := a div 2)) n a b)"
  apply(simp only: assign_shifted_bits_and_zero_most_significant_def)
  apply(rule seq_terminates_when[OF _ result_of_assign_shifted_bits, where ?t2.0=1])
  using assms apply(auto simp: fun_eq_iff var_to_var_bit_eq_Some_iff div2_is_right_shift
      le_2_to_the_n_then_nth_bit_zero split: option.splits)
  using IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_of_changed_s_neq_iff
  by (metis option.simps)

definition binary_right_shift:: "nat \<Rightarrow> vname \<Rightarrow> AExp.atomExp \<Rightarrow> IMP_Minus_Minus_com" where
"binary_right_shift n v a =  copy_atom_to_operand n (CHR ''a'') a ;;
    assign_shifted_bits_and_zero_most_significant n v ;;
    copy_atom_to_operand n (CHR ''a'') (N 0)"

lemma binary_right_shift_correct:
  assumes "n > 0" "atomVal a s < 2 ^ n"
  shows "t_small_step_fun (50 * (n + 1)) (binary_right_shift n v a,
  IMP_Minus_State_To_IMP_Minus_Minus s n) =
  (SKIP, IMP_Minus_State_To_IMP_Minus_Minus (s(v := atomVal a s div 2)) n)"
  apply(simp only: IMP_Minus_State_To_IMP_Minus_Minus_def binary_right_shift_def)
  using seq_terminates_when[OF _ seq_terminates_when[OF _ copy_atom_to_operand_a_result
          assign_shifted_bits_and_zero_most_significant_correct]
        copy_atom_to_operand_a_result, where ?t1.0="8 * n"]
  using assms by auto

definition assignment_to_binary:: "nat \<Rightarrow> vname \<Rightarrow> AExp.aexp \<Rightarrow> IMP_Minus_Minus_com" where
"assignment_to_binary n v aexp = (case aexp of
  AExp.A a \<Rightarrow> binary_adder n v a (AExp.N 0) |
  AExp.Plus a b \<Rightarrow> binary_adder n v a b |
  AExp.Sub a b \<Rightarrow> binary_subtractor n v a b |
  AExp.Parity a \<Rightarrow> binary_parity n v a |
  AExp.RightShift a \<Rightarrow> binary_right_shift n v a)"

lemma assignment_to_binary_correct:
  assumes "n > 0"  "AExp.aval a s < 2 ^ n" "\<forall>v. s v < 2 ^ n" "aexp_max_constant a < 2 ^ n"
  shows "t_small_step_fun (50 * (n + 1)) (assignment_to_binary n v a,
  IMP_Minus_State_To_IMP_Minus_Minus s n)
  = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus (s(v := AExp.aval a s)) n)"
using assms binary_adder_correct  proof(cases a)
  case (Sub x31 x32)
  then show ?thesis
    apply(simp add: assignment_to_binary_def)
    apply(rule binary_subtractor_correct[simplified])
    using assms by(cases x31; cases x32; auto)+
next
  case (RightShift x5)
  then show ?thesis using assms apply(simp add: assignment_to_binary_def)
    apply(rule binary_right_shift_correct[simplified])
    by (cases x5; auto)+
qed (auto simp: assignment_to_binary_def binary_parity_correct[simplified])

lemma assignment_to_binary_variables:
  "n > 0 \<Longrightarrow> set (enumerate_variables (assignment_to_binary n v a)) \<subseteq>
    { var_bit_to_var (w, i) | w i. i < n \<and> (w = v \<or> w \<in> set (aexp_vars a)) }
    \<union> { operand_bit_to_var (op, i) | op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') }
    \<union> { ''carry'' }"
  apply(cases a)
  by(auto simp: assignment_to_binary_def binary_adder_def set_enumerate_variables_seq
      copy_atom_to_operand_variables adder_def com_list_to_seq_variables full_adder_variables
    binary_subtractor_def subtract_handle_underflow_variables binary_parity_variables
    binary_right_shift_def assign_shifted_bits_and_zero_most_significant_def
    assign_shifted_bits_variables split: atomExp.splits)

end


theory ReduceProper
  imports SafeSubRename ResMapValid
begin

fun path_lookup :: "nres_map \<Rightarrow> string \<Rightarrow> string list \<Rightarrow> string \<Rightarrow> bool" where
  "path_lookup rs_map z Nil x = (z = x)"
| "path_lookup rs_map z (y # t) x = (case rs_map z of
    None \<Rightarrow> False
    | Some r_s \<Rightarrow> r_s (Loc y) \<noteq> NoPerm \<and> path_lookup rs_map y t x
  )"

lemma path_lookup_parent: "\<lbrakk> l \<noteq> Nil; path_lookup rs_map z l x; valid_nres_map s rs_map \<rbrakk> \<Longrightarrow>
  (\<exists> l' y r_s. path_lookup rs_map z l' y \<and> rs_map y = Some r_s \<and> r_s (Loc x) \<noteq> NoPerm )"
  apply (induct l arbitrary: z)
   apply (auto)
  apply (case_tac "rs_map z")
   apply (auto)
    (* case where we have reached x *)
  apply (case_tac "a = x")
   apply (rule_tac x="Nil" in exI)
   apply (auto)
    (* otherwise, induct *)
  apply (case_tac "l = []")
   apply (auto)
  apply (case_tac "\<exists>l' y. path_lookup rs_map a l' y \<and> (\<exists>r_s. rs_map y = Some r_s \<and> r_s (Loc x) \<noteq> NoPerm)")
   apply (erule_tac exE)
   apply (auto)
  apply (rule_tac x="a # l'" in exI)
  apply (auto)
  done

lemma path_lookup_append: "\<lbrakk> path_lookup rs_map x l y; path_lookup rs_map y m z \<rbrakk> \<Longrightarrow> path_lookup rs_map x (l @ m) z"
  apply (induct l arbitrary: x)
   apply (auto)
  apply (case_tac "rs_map x")
   apply (auto)
  done

lemma add_path_lookup: "\<lbrakk> path_lookup rs_map x l y; rs_map z = None; x \<noteq> z \<rbrakk> \<Longrightarrow> path_lookup (add_env rs_map z r_s) x l y"
  apply (induct l arbitrary: x)
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "rs_map x")
   apply (auto)
  apply (case_tac "a = z")
   apply (case_tac l)
    apply (auto)
  apply (simp add: add_env_def)
  done

(*
fun own_pairs where
  "own_pairs (ConstExp c) = {}"
| "own_pairs (OpExp xop) = {}"
| "own_pairs (VarExp v) = (case v of
    VarType x \<Rightarrow> {}
    | LocType x y \<Rightarrow> {(y, x)}
  )"
| "own_pairs (PairExp e1 e2) = (own_pairs e1 \<union> own_pairs e2)"
| "own_pairs (IfExp e1 e2 e3) = (own_pairs e1 \<union> own_pairs e2 \<union> own_pairs e3)"
| "own_pairs (LamExp x e) = own_pairs e"
| "own_pairs (AppExp e1 e2) = (own_pairs e1 \<union> own_pairs e2)"

    (* ##### given a perm set, we derive its "resource completion" by taking all of the resources that are reachable from it.
        in other words, for each permission z in s, we lookup its resource map, and take all of the resources in it, as well
        as recursing on each resource. #####
     *)

    (* ##### proper expressions ##### *)

definition proper_exp :: "nres_map \<Rightarrow> p_exp \<Rightarrow> bool" where
  "proper_exp rs_map e = (\<forall> x y. (x, y) \<in> own_pairs e \<longrightarrow> (\<exists> l. path_lookup rs_map x l y))"

lemma proper_pair: "\<lbrakk> proper_exp rs_map (PairExp e1 e2) \<rbrakk> \<Longrightarrow> proper_exp rs_map e1 \<and> proper_exp rs_map e2"
  apply (simp add: proper_exp_def)
  done

lemma proper_if: "\<lbrakk> proper_exp rs_map (IfExp e1 e2 e3) \<rbrakk> \<Longrightarrow> proper_exp rs_map e1 \<and> proper_exp rs_map e2 \<and> proper_exp rs_map e3"
  apply (simp add: proper_exp_def)
  done

lemma proper_app: "\<lbrakk> proper_exp rs_map (AppExp e1 e2) \<rbrakk> \<Longrightarrow> proper_exp rs_map e1 \<and> proper_exp rs_map e2"
  apply (simp add: proper_exp_def)
  done

lemma proper_subst_exp: "\<lbrakk> proper_exp rs_map e; proper_exp rs_map e' \<rbrakk> \<Longrightarrow> proper_exp rs_map (subst_exp e x e')"
  apply (induct e)
        apply (auto)
      apply (case_tac xa)
       apply (auto)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
     apply (auto)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma proper_alpha_rename: "\<lbrakk> proper_exp rs_map e \<rbrakk> \<Longrightarrow> proper_exp rs_map (deep_alpha_rename e a b)"
  apply (induct e)
        apply (auto)
       apply (simp add: proper_exp_def)
       apply (auto)
       apply (case_tac x)
        apply (auto)
       apply (case_tac "a = x1")
        apply (auto)
      apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
       apply (auto)
      apply (simp add: proper_exp_def)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma proper_lam_var_remove_ex: "\<lbrakk> proper_exp rs_map e; well_typed env r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> proper_exp rs_map (lam_var_remove e a b)"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
      apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
       apply (auto)
      apply (simp add: proper_exp_def)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (cut_tac rs_map="rs_map" and e="e" and a="a" and b="b" in proper_alpha_rename)
     apply (simp add: proper_exp_def)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma proper_lam_var_remove: "\<lbrakk> proper_exp rs_map e \<rbrakk> \<Longrightarrow> proper_exp rs_map (lam_var_remove e a b)"
  apply (induct e)
        apply (auto)
      apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
       apply (auto)
      apply (simp add: proper_exp_def)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (cut_tac rs_map="rs_map" and e="e" and a="a" and b="b" in proper_alpha_rename)
     apply (simp add: proper_exp_def)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma lam_var_remove_eq: "\<lbrakk> a \<notin> lam_vars e \<rbrakk> \<Longrightarrow> lam_var_remove e a b = e"
  apply (induct e)
        apply (auto)
  done

lemma proper_lvlr_ex: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; proper_exp rs_map e; unique_post_vars vl;
  post_vars vl \<inter> (free_vars e \<union> lam_vars e) = {} \<rbrakk> \<Longrightarrow> proper_exp rs_map (lam_var_list_remove e vl)"
  apply (induct vl arbitrary: e)
   apply (auto)
  (*apply (case_tac "a \<notin> lam_vars e")
   apply (simp add: lam_var_remove_eq)*)
  apply (cut_tac rs_map="rs_map" and e="e" and a="a" and b="b" in proper_lam_var_remove_ex)
    apply (auto)
    (* we have to prove that the post vars are still disjoint from the lam_vars / ref_vars, which is true since
        the only new lam_var is b, which must be disjoint from the rest of the post_var list *)
  apply (case_tac "post_vars vl \<inter> (free_vars (lam_var_remove e a b) \<union> lam_vars (lam_var_remove e a b)) \<noteq> {}")
   apply (auto)
    apply (cut_tac x="x" and e="e" and a="a" and b="b" in lam_var_remove_free_var_none)
     apply (auto)
   apply (case_tac "x = b")
    apply (auto)
   apply (cut_tac x="x" and e="e" and a="a" and b="b" in lam_var_remove_lam_var_none)
     apply (auto)
    (* the last part of the induction is to prove that e is still well-typed *)
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and e="e" and x="a" and y="b" in lam_var_remove_type_preserve)
      apply (auto)
  done

lemma proper_safe_subst_exp: "\<lbrakk> proper_exp rs_map e; well_typed env r_s1 e tau r_s2 rx;
  proper_exp rs_map e'; safe_subst_exp e x e' e_f \<rbrakk> \<Longrightarrow> proper_exp rs_map e_f"
  apply (simp add: safe_subst_exp_def)
  apply (auto)
  apply (rule_tac proper_subst_exp)
   apply (rule_tac proper_lvlr_ex)
      apply (auto)
  done*)

definition ext_delta :: "owner_env \<Rightarrow> string \<Rightarrow> perm_use_env \<Rightarrow> owner_env" where
  "ext_delta delta x r_s = (\<lambda> y. if r_s (Loc (delta y)) \<noteq> NoPerm then x else delta y)"

end


(*  Title:      JinjaThreads/J/State.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

header {*
  \chapter{JinjaThreads source language}
  \isaheader{Program State}
*}

theory State
imports
  "../Common/Heap"
begin

type_synonym
  'addr locals = "vname \<rightharpoonup> 'addr val"      -- "local vars, incl. params and ``this''"
type_synonym
  ('addr, 'heap) Jstate = "'heap \<times> 'addr locals"     -- "the heap and the local vars"

definition hp :: "'heap \<times> 'x \<Rightarrow> 'heap" where "hp \<equiv> fst"

definition lcl :: "'heap \<times> 'x \<Rightarrow> 'x" where "lcl \<equiv> snd"

lemma hp_conv [simp]: "hp (h, l) = h"
by(simp add: hp_def)

lemma lcl_conv [simp]: "lcl (h, l) = l"
by(simp add: lcl_def)

end


(*  Title:       An Executable Algorithm for Clause Subsumption
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>An Executable Algorithm for Clause Subsumption\<close>

text \<open>
This theory provides an executable functional implementation of clause
subsumption, building on the \textsf{IsaFoR} library.
\<close>

theory Executable_Subsumption
  imports
    IsaFoR_Term
    First_Order_Terms.Matching
begin

subsection \<open>Naive Implementation of Clause Subsumption\<close>

fun subsumes_list where
  "subsumes_list [] Ks \<sigma> = True"
| "subsumes_list (L # Ls) Ks \<sigma> =
     (\<exists>K \<in> set Ks. is_pos K = is_pos L \<and>
       (case match_term_list [(atm_of L, atm_of K)] \<sigma> of
         None \<Rightarrow> False
       | Some \<rho> \<Rightarrow> subsumes_list Ls (remove1 K Ks) \<rho>))"

lemma atm_of_map_literal[simp]: "atm_of (map_literal f l) = f (atm_of l)"
  by (cases l; simp)

definition "extends_subst \<sigma> \<tau> = (\<forall>x \<in> dom \<sigma>. \<sigma> x = \<tau> x)"

lemma extends_subst_refl[simp]: "extends_subst \<sigma> \<sigma>"
  unfolding extends_subst_def by auto

lemma extends_subst_trans: "extends_subst \<sigma> \<tau> \<Longrightarrow> extends_subst \<tau> \<rho> \<Longrightarrow> extends_subst \<sigma> \<rho>"
  unfolding extends_subst_def dom_def by (metis mem_Collect_eq)

lemma extends_subst_dom: "extends_subst \<sigma> \<tau> \<Longrightarrow> dom \<sigma> \<subseteq> dom \<tau>"
  unfolding extends_subst_def dom_def by auto

lemma extends_subst_extends: "extends_subst \<sigma> \<tau> \<Longrightarrow> x \<in> dom \<sigma> \<Longrightarrow> \<tau> x = \<sigma> x"
  unfolding extends_subst_def dom_def by auto

lemma extends_subst_fun_upd_new:
  "\<sigma> x = None \<Longrightarrow> extends_subst (\<sigma>(x \<mapsto> t)) \<tau> \<longleftrightarrow> extends_subst \<sigma> \<tau> \<and> \<tau> x = Some t"
  unfolding extends_subst_def dom_fun_upd subst_of_map_def
  by (force simp add: dom_def split: option.splits)

lemma extends_subst_fun_upd_matching:
  "\<sigma> x = Some t \<Longrightarrow> extends_subst (\<sigma>(x \<mapsto> t)) \<tau> \<longleftrightarrow> extends_subst \<sigma> \<tau>"
  unfolding extends_subst_def dom_fun_upd subst_of_map_def
  by (auto simp add: dom_def split: option.splits)

lemma extends_subst_empty[simp]: "extends_subst Map.empty \<tau>"
  unfolding extends_subst_def by auto

lemma extends_subst_cong_term:
  "extends_subst \<sigma> \<tau> \<Longrightarrow> vars_term t \<subseteq> dom \<sigma> \<Longrightarrow> t \<cdot> subst_of_map Var \<sigma> = t \<cdot> subst_of_map Var \<tau>"
  by (force simp: extends_subst_def subst_of_map_def split: option.splits intro!: term_subst_eq)

lemma extends_subst_cong_lit:
  "extends_subst \<sigma> \<tau> \<Longrightarrow> vars_lit L \<subseteq> dom \<sigma> \<Longrightarrow> L \<cdot>lit subst_of_map Var \<sigma> = L \<cdot>lit subst_of_map Var \<tau>"
  by (cases L) (auto simp: extends_subst_cong_term)

definition "subsumes_modulo C D \<sigma> =
   (\<exists>\<tau>. dom \<tau> = vars_clause C \<union> dom \<sigma> \<and> extends_subst \<sigma> \<tau> \<and> subst_cls C (subst_of_map Var \<tau>) \<subseteq># D)"

abbreviation subsumes_list_modulo where
  "subsumes_list_modulo Ls Ks \<sigma> \<equiv> subsumes_modulo (mset Ls) (mset Ks) \<sigma>"

lemma vars_clause_add_mset[simp]: "vars_clause (add_mset L C) = vars_lit L \<union> vars_clause C"
  unfolding vars_clause_def by auto

lemma subsumes_list_modulo_Cons: "subsumes_list_modulo (L # Ls) Ks \<sigma> \<longleftrightarrow>
  (\<exists>K \<in> set Ks. \<exists>\<tau>. extends_subst \<sigma> \<tau> \<and> dom \<tau> = vars_lit L \<union> dom \<sigma> \<and> L \<cdot>lit (subst_of_map Var \<tau>) = K
     \<and> subsumes_list_modulo Ls (remove1 K Ks) \<tau>)"
  unfolding subsumes_modulo_def
proof (safe, goal_cases left_right right_left)
  case (left_right \<tau>)
  then show ?case
    by (intro bexI[of _ "L \<cdot>lit subst_of_map Var \<tau>"]
      exI[of _ "\<lambda>x. if x \<in> vars_lit L \<union> dom \<sigma> then \<tau> x else None"], intro conjI exI[of _ \<tau>])
      (auto 0 3 simp: extends_subst_def dom_def split: if_splits
      simp: insert_subset_eq_iff subst_lit_def  intro!: extends_subst_cong_lit)
next
  case (right_left K \<tau> \<tau>')
  then show ?case
    by (intro bexI[of _ "L \<cdot>lit subst_of_map Var \<tau>"] exI[of _ \<tau>'], intro conjI exI[of _ \<tau>])
     (auto simp: insert_subset_eq_iff subst_lit_def extends_subst_cong_lit
       intro: extends_subst_trans)
qed

lemma decompose_Some_var_terms: "decompose (Fun f ss) (Fun g ts) = Some eqs \<Longrightarrow>
   f = g \<and> length ss = length ts \<and> eqs = zip ss ts \<and>
   (\<Union>(t, u)\<in>set ((Fun f ss, Fun g ts) # P). vars_term t) =
   (\<Union>(t, u)\<in>set (eqs @ P). vars_term t)"
  by (drule decompose_Some)
    (fastforce simp: in_set_zip in_set_conv_nth Bex_def image_iff)

lemma match_term_list_sound: "match_term_list tus \<sigma> = Some \<tau> \<Longrightarrow>
  extends_subst \<sigma> \<tau> \<and> dom \<tau> = (\<Union>(t, u)\<in>set tus. vars_term t) \<union> dom \<sigma> \<and>
  (\<forall>(t,u)\<in>set tus. t \<cdot> subst_of_map Var \<tau> = u)"
proof (induct tus \<sigma> rule: match_term_list.induct)
  case (2 x t P \<sigma>)
  then show ?case
    by (auto 0 3 simp: extends_subst_fun_upd_new extends_subst_fun_upd_matching
      subst_of_map_def dest: extends_subst_extends simp del: fun_upd_apply
      split: if_splits option.splits)
next
  case (3 f ss g ts P \<sigma>)
  from 3(2) obtain eqs where "decompose (Fun f ss) (Fun g ts) = Some eqs"
    "match_term_list (eqs @ P) \<sigma> = Some \<tau>" by (auto split: option.splits)
  with 3(1)[OF this] show ?case
  proof (elim decompose_Some_var_terms[where P = P, elim_format] conjE, intro conjI, goal_cases extend dom subst)
    case subst
    from subst(3,5,6,7) show ?case
      by (auto 0 6 simp: in_set_conv_nth list_eq_iff_nth_eq Ball_def)
  qed auto
qed auto

lemma match_term_list_complete: "match_term_list tus \<sigma> = None \<Longrightarrow>
   extends_subst \<sigma> \<tau> \<Longrightarrow> dom \<tau> = (\<Union>(t, u)\<in>set tus. vars_term t) \<union> dom \<sigma> \<Longrightarrow>
    (\<exists>(t,u)\<in>set tus. t \<cdot> subst_of_map Var \<tau> \<noteq> u)"
proof (induct tus \<sigma> arbitrary: \<tau> rule: match_term_list.induct)
  case (2 x t P \<sigma>)
  then show ?case
    by (auto simp: extends_subst_fun_upd_new extends_subst_fun_upd_matching
      subst_of_map_def dest: extends_subst_extends simp del: fun_upd_apply
      split: if_splits option.splits)
next
  case (3 f ss g ts P \<sigma>)
  show ?case
  proof (cases "decompose (Fun f ss) (Fun g ts) = None")
    case False
    with 3(2) obtain eqs where "decompose (Fun f ss) (Fun g ts) = Some eqs"
      "match_term_list (eqs @ P) \<sigma> = None" by (auto split: option.splits)
    with 3(1)[OF this 3(3) trans[OF 3(4) arg_cong[of _ _ "\<lambda>x. x \<union> dom \<sigma>"]]] show ?thesis
    proof (elim decompose_Some_var_terms[where P = P, elim_format] conjE, goal_cases subst)
      case subst
      from subst(1)[OF subst(6)] subst(4,5) show ?case
        by (auto 0 3 simp: in_set_conv_nth list_eq_iff_nth_eq Ball_def)
    qed
  qed auto
qed auto

lemma unique_extends_subst:
  assumes extends: "extends_subst \<sigma> \<tau>" "extends_subst \<sigma> \<rho>" and
    dom: "dom \<tau> = vars_term t \<union> dom \<sigma>" "dom \<rho> = vars_term t \<union> dom \<sigma>" and
    eq: "t \<cdot> subst_of_map Var \<rho> = t \<cdot> subst_of_map Var \<tau>"
  shows "\<rho> = \<tau>"
proof
  fix x
  consider (a) "x \<in> dom \<sigma>" | (b) "x \<in> vars_term t" | (c) "x \<notin> dom \<tau>" using assms by auto
  then show "\<rho> x = \<tau> x"
  proof cases
    case a
    then show ?thesis using extends unfolding extends_subst_def by auto
  next
    case b
    with eq show ?thesis
    proof (induct t)
      case (Var x)
      with trans[OF dom(1) dom(2)[symmetric]] show ?case
        by (auto simp: subst_of_map_def split: option.splits)
    qed auto
  next
    case c
    then have "\<rho> x = None" "\<tau> x = None" using dom by auto
    then show ?thesis by simp
  qed
qed

lemma subsumes_list_alt:
  "subsumes_list Ls Ks \<sigma> \<longleftrightarrow> subsumes_list_modulo Ls Ks \<sigma>"
proof (induction Ls Ks \<sigma> rule: subsumes_list.induct[case_names Nil Cons])
  case (Cons L Ls Ks \<sigma>)
  show ?case
    unfolding subsumes_list_modulo_Cons subsumes_list.simps
  proof ((intro bex_cong[OF refl] ext iffI; elim exE conjE), goal_cases LR RL)
    case (LR K)
    show ?case
      by (insert LR; cases K; cases L; auto simp: Cons.IH split: option.splits dest!: match_term_list_sound)
  next
    case (RL K \<tau>)
    then show ?case
    proof (cases "match_term_list [(atm_of L, atm_of K)] \<sigma>")
      case None
      with RL show ?thesis
        by (auto simp: Cons.IH dest!: match_term_list_complete)
    next
      case (Some \<tau>')
      with RL show ?thesis
        using unique_extends_subst[of \<sigma> \<tau> \<tau>' "atm_of L"]
        by (auto simp: Cons.IH dest!: match_term_list_sound)
    qed
  qed
qed (auto simp: subsumes_modulo_def subst_cls_def vars_clause_def intro: extends_subst_refl)

lemma subsumes_subsumes_list[code_unfold]:
  "subsumes (mset Ls) (mset Ks) = subsumes_list Ls Ks Map.empty"
unfolding subsumes_list_alt[of Ls Ks Map.empty]
proof
  assume "subsumes (mset Ls) (mset Ks)"
  then obtain \<sigma> where "subst_cls (mset Ls) \<sigma> \<subseteq># mset Ks" unfolding subsumes_def by blast
  moreover define \<tau> where "\<tau> = (\<lambda>x. if x \<in> vars_clause (mset Ls) then Some (\<sigma> x) else None)"
  ultimately show "subsumes_list_modulo Ls Ks Map.empty"
    unfolding subsumes_modulo_def
    by (subst (asm) same_on_vars_clause[of _ \<sigma> "subst_of_map Var \<tau>"])
      (auto intro!: exI[of _ \<tau>] simp: subst_of_map_def[abs_def] split: if_splits)
qed (auto simp: subsumes_modulo_def subst_lit_def subsumes_def)

lemma strictly_subsumes_subsumes_list[code_unfold]:
  "strictly_subsumes (mset Ls) (mset Ks) =
    (subsumes_list Ls Ks Map.empty \<and> \<not> subsumes_list Ks Ls Map.empty)"
  unfolding strictly_subsumes_def subsumes_subsumes_list by simp

lemma subsumes_list_filterD: "subsumes_list Ls (filter P Ks) \<sigma> \<Longrightarrow> subsumes_list Ls Ks \<sigma>"
proof (induction Ls arbitrary: Ks \<sigma>)
  case (Cons L Ls)
  from Cons.prems show ?case
    by (auto dest!: Cons.IH simp: filter_remove1[symmetric] split: option.splits)
qed simp

lemma subsumes_list_filterI:
  assumes match: "(\<And>L K \<sigma> \<tau>. L \<in> set Ls \<Longrightarrow>
    match_term_list [(atm_of L, atm_of K)] \<sigma> = Some \<tau> \<Longrightarrow> is_pos L = is_pos K \<Longrightarrow> P K)"
  shows "subsumes_list Ls Ks \<sigma> \<Longrightarrow> subsumes_list Ls (filter P Ks) \<sigma>"
using assms proof (induction Ls Ks \<sigma> rule: subsumes_list.induct[case_names Nil Cons])
  case (Cons L Ls Ks \<sigma>)
  from Cons.prems show ?case
    unfolding subsumes_list.simps set_filter bex_simps conj_assoc
    by (elim bexE conjE)
      (rule exI, rule conjI, assumption,
        auto split: option.splits simp: filter_remove1[symmetric] intro!: Cons.IH)
qed simp

lemma subsumes_list_Cons_filter_iff:
  assumes sorted_wrt: "sorted_wrt leq (L # Ls)" and trans: "transp leq"
  and match: "(\<And>L K \<sigma> \<tau>.
    match_term_list [(atm_of L, atm_of K)] \<sigma> = Some \<tau> \<Longrightarrow> is_pos L = is_pos K \<Longrightarrow> leq L K)"
shows "subsumes_list (L # Ls) (filter (leq L) Ks) \<sigma> \<longleftrightarrow> subsumes_list (L # Ls) Ks \<sigma>"
  apply (rule iffI[OF subsumes_list_filterD subsumes_list_filterI]; assumption?)
  unfolding list.set insert_iff
  apply (elim disjE)
  subgoal by (auto split: option.splits elim!: match)
  subgoal for L K \<sigma> \<tau>
    using sorted_wrt unfolding List.sorted_wrt.simps(2)
    apply (elim conjE)
    apply (drule bspec, assumption)
    apply (erule transpD[OF trans])
    apply (erule match)
    by auto
  done

definition leq_head  :: "('f::linorder, 'v) term \<Rightarrow> ('f, 'v) term \<Rightarrow> bool" where
  "leq_head t u = (case (root t, root u) of
    (None, _) \<Rightarrow> True
  | (_, None) \<Rightarrow> False
  | (Some f, Some g) \<Rightarrow> f \<le> g)"
definition "leq_lit L K = (case (K, L) of
    (Neg _, Pos _) \<Rightarrow> True
  | (Pos _, Neg _) \<Rightarrow> False
  | _ \<Rightarrow> leq_head (atm_of L) (atm_of K))"

lemma transp_leq_lit[simp]: "transp leq_lit"
  unfolding transp_def leq_lit_def leq_head_def by (force split: option.splits literal.splits)

lemma reflp_leq_lit[simp]: "reflp_on A leq_lit"
  unfolding reflp_on_def leq_lit_def leq_head_def by (auto split: option.splits literal.splits)

lemma total_leq_lit[simp]: "totalp_on A leq_lit"
  unfolding totalp_on_def leq_lit_def leq_head_def by (auto split: option.splits literal.splits)

lemma leq_head_subst[simp]: "leq_head t (t \<cdot> \<sigma>)"
  by (induct t) (auto simp: leq_head_def)

lemma leq_lit_match:
  fixes L K :: "('f :: linorder, 'v) term literal"
  shows "match_term_list [(atm_of L, atm_of K)] \<sigma> = Some \<tau> \<Longrightarrow> is_pos L = is_pos K \<Longrightarrow> leq_lit L K"
  by (cases L; cases K)
    (auto simp: leq_lit_def dest!: match_term_list_sound split: option.splits)

subsection \<open>Optimized Implementation of Clause Subsumption\<close>

fun subsumes_list_filter where
  "subsumes_list_filter [] Ks \<sigma> = True"
| "subsumes_list_filter (L # Ls) Ks \<sigma> =
     (let Ks = filter (leq_lit L) Ks in
     (\<exists>K \<in> set Ks. is_pos K = is_pos L \<and>
       (case match_term_list [(atm_of L, atm_of K)] \<sigma> of
         None \<Rightarrow> False
       | Some \<rho> \<Rightarrow> subsumes_list_filter Ls (remove1 K Ks) \<rho>)))"

lemma sorted_wrt_subsumes_list_subsumes_list_filter:
  "sorted_wrt leq_lit Ls \<Longrightarrow> subsumes_list Ls Ks \<sigma> = subsumes_list_filter Ls Ks \<sigma>"
proof (induction Ls arbitrary: Ks \<sigma>)
  case (Cons L Ls)
  from Cons.prems have "subsumes_list (L # Ls) Ks \<sigma> = subsumes_list (L # Ls) (filter (leq_lit L) Ks) \<sigma>"
    by (intro subsumes_list_Cons_filter_iff[symmetric]) (auto dest: leq_lit_match)
  also have "subsumes_list (L # Ls) (filter (leq_lit L) Ks) \<sigma> = subsumes_list_filter (L # Ls) Ks \<sigma>"
    using Cons.prems by (auto simp: Cons.IH split: option.splits)
  finally show ?case .
qed simp

subsection \<open>Definition of Deterministic QuickSort\<close>

text \<open>
  This is the functional description of the standard variant of deterministic
  QuickSort that always chooses the first list element as the pivot as given
  by Hoare in 1962. For a list that is already sorted, this leads to $n(n-1)$
  comparisons, but as is well known, the average case is much better.

  The code below is adapted from Manuel Eberl's \<open>Quick_Sort_Cost\<close> AFP
  entry, but without invoking probability theory and using a predicate instead
  of a set.
\<close>

fun quicksort :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "quicksort _ [] = []"
| "quicksort R (x # xs) =
     quicksort R (filter (\<lambda>y. R y x) xs) @ [x] @ quicksort R (filter (\<lambda>y. \<not> R y x) xs)"

text \<open>
  We can easily show that this QuickSort is correct:
\<close>

theorem mset_quicksort [simp]: "mset (quicksort R xs) = mset xs"
  by (induction R xs rule: quicksort.induct) simp_all

corollary set_quicksort [simp]: "set (quicksort R xs) = set xs"
  by (induction R xs rule: quicksort.induct) auto

theorem sorted_wrt_quicksort:
  assumes "transp R" and "totalp_on (set xs) R" and "reflp_on (set xs) R"
  shows   "sorted_wrt R (quicksort R xs)"
using assms
proof (induction R xs rule: quicksort.induct)
  case (2 R x xs)
  have total: "R a b" if "\<not> R b a" "a \<in> set (x#xs)" "b \<in> set (x#xs)" for a b
    using "2.prems" that unfolding totalp_on_def reflp_on_def by (cases "a = b") auto

  have "sorted_wrt R (quicksort R (filter (\<lambda>y. R y x) xs))"
          "sorted_wrt R (quicksort R (filter (\<lambda>y. \<not> R y x) xs))"
    using "2.prems" by (intro "2.IH"; auto simp: totalp_on_def reflp_on_def)+
  then show ?case
    by (auto simp: sorted_wrt_append \<open>transp R\<close>
     intro: transpD[OF \<open>transp R\<close>] dest!: total)
qed auto

text \<open>
End of the material adapted from Eberl's \<open>Quick_Sort_Cost\<close>.
\<close>

lemma subsumes_list_subsumes_list_filter[abs_def, code_unfold]:
  "subsumes_list Ls Ks \<sigma> = subsumes_list_filter (quicksort leq_lit Ls) Ks \<sigma>"
  by (rule trans[OF box_equals[OF _ subsumes_list_alt[symmetric] subsumes_list_alt[symmetric]]
    sorted_wrt_subsumes_list_subsumes_list_filter])
    (auto simp: sorted_wrt_quicksort)

end


(*<*)
theory Slicing
  imports Abstract_Monitor MFOTL
begin
(*>*)

section \<open>Slicing framework\<close>

text \<open>This section formalizes the abstract slicing framework and the joint data slicer
  presented in the article~\<^cite>\<open>\<open>Sections 4.2 and~4.3\<close> in "SchneiderBBKT-STTT20"\<close>.\<close>

subsection \<open>Abstract slicing\<close>

subsubsection \<open>Definition 1\<close>

text \<open>Corresponds to locale @{locale monitor} defined in theory
  @{theory MFOTL_Monitor.Abstract_Monitor}.\<close>

subsubsection \<open>Definition 2\<close>

locale slicer = monitor +
  fixes submonitor :: "'k :: finite \<Rightarrow> 'a prefix \<Rightarrow> (nat \<times> 'b option list) set"
  and   splitter :: "'a prefix \<Rightarrow> 'k \<Rightarrow> 'a prefix"
  and   joiner :: "('k \<Rightarrow> (nat \<times> 'b option list) set) \<Rightarrow> (nat \<times> 'b option list) set"
assumes mono_splitter: "\<pi> \<le> \<pi>' \<Longrightarrow> splitter \<pi> k \<le> splitter \<pi>' k"
  and   correct_slicer: "joiner (\<lambda>k. submonitor k (splitter \<pi> k)) = M \<pi>"
begin

lemmas sound_slicer = equalityD1[OF correct_slicer]
lemmas complete_slicer = equalityD2[OF correct_slicer]

end

locale self_slicer = slicer nfv fv sat M "\<lambda>_. M" splitter joiner for nfv fv sat M splitter joiner

subsubsection \<open>Definition 3\<close>

locale event_separable_splitter =
  fixes event_splitter :: "'a \<Rightarrow> 'k :: finite set"
begin

lift_definition splitter :: "'a prefix \<Rightarrow> 'k \<Rightarrow> 'a prefix" is
  "\<lambda>\<pi> k. map (\<lambda>(D, t). ({e \<in> D. k \<in> event_splitter e}, t)) \<pi>"
  by (auto simp: o_def split_beta)

subsubsection \<open>Lemma 1\<close>

lemma mono_splitter: "\<pi> \<le> \<pi>' \<Longrightarrow> splitter \<pi> k \<le> splitter \<pi>' k"
  by transfer auto

end

subsection \<open>Joint data slicer\<close>

abbreviation (input) "ok \<phi> v \<equiv> wf_tuple (MFOTL.nfv \<phi>) (MFOTL.fv \<phi>) v"

locale splitting_strategy =
  fixes \<phi> :: "'a MFOTL.formula"
  and strategy :: "'a option list \<Rightarrow> 'k :: finite set"
  assumes strategy_nonempty: "ok \<phi> v \<Longrightarrow> strategy v \<noteq> {}"
begin

abbreviation slice_set where
  "slice_set k \<equiv> {v. \<exists>v'. map the v' = v \<and> ok \<phi> v' \<and> k \<in> strategy v'}"

end

subsubsection \<open>Definition 4\<close>

locale MFOTL_monitor =
  monitor "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M for \<phi> M

locale joint_data_slicer = MFOTL_monitor \<phi> M + splitting_strategy \<phi> strategy
  for \<phi> M strategy
begin

definition event_splitter where
  "event_splitter e = (\<Union>(strategy ` {v. ok \<phi> v \<and> MFOTL.matches (map the v) \<phi> e}))"

sublocale event_separable_splitter where event_splitter = event_splitter .

definition joiner where
  "joiner = (\<lambda>s. \<Union>k. s k \<inter> (UNIV :: nat set) \<times> {v. k \<in> strategy v})"

lemma splitter_pslice: "splitter \<pi> k = MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>"
  by transfer (auto simp: event_splitter_def)

subsubsection \<open>Lemma 2\<close>

text \<open>Corresponds to the following theorem @{thm[source] sat_slice_strong} proved in theory
   @{theory MFOTL_Monitor.Abstract_Monitor}:

   @{thm sat_slice_strong[no_vars]}\<close>

subsubsection \<open>Theorem 1\<close>

sublocale joint_monitor: MFOTL_monitor \<phi> "\<lambda>\<pi>. joiner (\<lambda>k. M (splitter \<pi> k))"
proof (unfold_locales, goal_cases mono wf sound complete)
  case (mono \<pi> \<pi>')
  show ?case
    using mono_monitor[OF mono_splitter, OF mono]
    by (auto simp: joiner_def)
next
  case (wf i v \<pi>)
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"  and k: "k \<in> strategy v"
    unfolding joiner_def by (auto split: if_splits)
  then show ?case
    using wf_monitor[OF in_M] by auto
next
  case (sound i v \<pi> \<sigma>)
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"  and k: "k \<in> strategy v"
    unfolding joiner_def by (auto split: if_splits)
  have wf: "ok \<phi> v" and sat: "\<And>\<sigma>. prefix_of (splitter \<pi> k) \<sigma> \<Longrightarrow> MFOTL.sat \<sigma> (map the v) i \<phi>"
    using sound_monitor[OF in_M] wf_monitor[OF in_M] by auto
  then have "MFOTL.sat \<sigma> (map the v) i \<phi>" if "prefix_of \<pi> \<sigma>" for \<sigma>
    using that k
    by (intro iffD2[OF sat_slice_iff[of "map the v" "slice_set k" \<sigma> i \<phi>]])
      (auto simp: wf_tuple_def fvi_less_nfv splitter_pslice intro!: exI[of _ v] prefix_of_pmap_\<Gamma>)
  then show ?case using sound(2) by blast
next
  case (complete \<pi> \<sigma> v i)
  with strategy_nonempty obtain k where k: "k \<in> strategy v" by blast
  have "MFOTL.sat \<sigma>' (map the v) i \<phi>" if "prefix_of (MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>) \<sigma>'" for \<sigma>'
  proof -
    have "MFOTL.sat \<sigma>' (map the v) i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>') (map the v) i \<phi>"
      using complete(2) k by (auto intro!: sat_slice_iff)
    also have "\<dots> = MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) (replace_prefix \<pi> \<sigma>')) (map the v) i \<phi>"
      using that complete k by (subst slice_replace_prefix[symmetric]; simp)
    also have "\<dots> = MFOTL.sat (replace_prefix \<pi> \<sigma>') (map the v) i \<phi>"
      using complete(2) k by (auto intro!: sat_slice_iff[symmetric])
    also have "\<dots>"
      by (rule complete(3)[rule_format], rule prefix_of_replace_prefix[OF that])
    finally show ?thesis .
  qed
  with complete(1-3) obtain \<pi>' where \<pi>':
    "prefix_of \<pi>' (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>)" "(i, v) \<in> M \<pi>'"
    by (atomize_elim, intro complete_monitor[where \<pi>="MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>"])
      (auto simp: splitter_pslice intro!: prefix_of_pmap_\<Gamma>)
  from \<pi>'(1) obtain \<pi>'' where "\<pi>' = MFOTL_slicer.pslice \<phi> (slice_set k) \<pi>''" "prefix_of \<pi>'' \<sigma>"
    by (atomize_elim, rule prefix_of_map_\<Gamma>_D)
  with \<pi>' k show ?case
    by (intro exI[of _ \<pi>'']) (auto simp: joiner_def splitter_pslice intro!: exI[of _ k])
qed

subsubsection \<open>Corollary 1\<close>

sublocale joint_slicer: slicer "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>"
  "\<lambda>\<pi>. joiner (\<lambda>k. M (splitter \<pi> k))" "\<lambda>_. M" splitter joiner
  by standard (auto simp: mono_splitter)

end

subsubsection \<open>Definition 5\<close>

text \<open>Corresponds to locale @{locale sliceable_monitor} defined in theory
  @{theory MFOTL_Monitor.Abstract_Monitor}.\<close>

locale slicable_joint_data_slicer =
  sliceable_monitor "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "relevant_events \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M +
  joint_data_slicer \<phi> M strategy for \<phi> M strategy
begin

lemma monitor_split: "ok \<phi> v \<Longrightarrow> k \<in> strategy v \<Longrightarrow> (i, v) \<in> M (splitter \<pi> k) \<longleftrightarrow> (i, v) \<in> M \<pi>"
  unfolding splitter_pslice
  by (rule sliceable_M)
    (auto simp: wf_tuple_def fvi_less_nfv intro!: mem_restrI[rotated 2, where y="map the v"])

subsubsection \<open>Theorem 2\<close>

sublocale self_slicer "MFOTL.nfv \<phi>" "MFOTL.fv \<phi>" "\<lambda>\<sigma> v i. MFOTL.sat \<sigma> v i \<phi>" M splitter joiner
proof (standard, erule mono_splitter, safe, goal_cases sound complete)
  case (sound \<pi> i v)
  have "ok \<phi> v" using joint_monitor.wf_monitor[OF sound] by auto
  from sound obtain k where "(i, v) \<in> M (splitter \<pi> k)" "k \<in> strategy v"
    unfolding joiner_def by blast
  with \<open>ok \<phi> v\<close> show ?case by (simp add: monitor_split)
next
  case (complete \<pi> i v)
  have "ok \<phi> v" using wf_monitor[OF complete] by auto
  with complete strategy_nonempty obtain k where k: "k \<in> strategy v" by blast
  then have "(i, v) \<in> M (splitter \<pi> k)" using complete \<open>ok \<phi> v\<close> by (simp add: monitor_split)
  with k show ?case unfolding joiner_def by blast
qed

end

subsubsection \<open>Towards Theorem 3\<close>

fun names :: "'a MFOTL.formula \<Rightarrow> MFOTL.name set" where
  "names (MFOTL.Pred e _) = {e}"
| "names (MFOTL.Eq _ _) = {}"
| "names (MFOTL.Neg \<psi>) = names \<psi>"
| "names (MFOTL.Or \<alpha> \<beta>) = names \<alpha> \<union> names \<beta>"
| "names (MFOTL.Exists \<psi>) = names \<psi>"
| "names (MFOTL.Prev I \<psi>) = names \<psi>"
| "names (MFOTL.Next I \<psi>) = names \<psi>"
| "names (MFOTL.Since \<alpha> I \<beta>) = names \<alpha> \<union> names \<beta>"
| "names (MFOTL.Until \<alpha> I \<beta>) = names \<alpha> \<union> names \<beta>"

fun gen_unique :: "'a MFOTL.formula \<Rightarrow> bool" where
  "gen_unique (MFOTL.Pred _ _) = True"
| "gen_unique (MFOTL.Eq (MFOTL.Var _) (MFOTL.Const _)) = False"
| "gen_unique (MFOTL.Eq (MFOTL.Const _) (MFOTL.Var _)) = False"
| "gen_unique (MFOTL.Eq _ _) = True"
| "gen_unique (MFOTL.Neg \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Or \<alpha> \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"
| "gen_unique (MFOTL.Exists \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Prev I \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Next I \<psi>) = gen_unique \<psi>"
| "gen_unique (MFOTL.Since \<alpha> I \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"
| "gen_unique (MFOTL.Until \<alpha> I \<beta>) = (gen_unique \<alpha> \<and> gen_unique \<beta> \<and> names \<alpha> \<inter> names \<beta> = {})"

lemma sat_inter_names_cong: "(\<And>e. e \<in> names \<phi> \<Longrightarrow> {xs. (e, xs) \<in> E} = {xs. (e, xs) \<in> F}) \<Longrightarrow>
  MFOTL.sat (map_\<Gamma> (\<lambda>D. D \<inter> E) \<sigma>) v i \<phi> \<longleftrightarrow> MFOTL.sat (map_\<Gamma> (\<lambda>D. D \<inter> F) \<sigma>) v i \<phi>"
  by (induction \<phi> arbitrary: v i) (auto split: nat.splits)

lemma matches_in_names: "MFOTL.matches v \<phi> x \<Longrightarrow> fst x \<in> names \<phi>"
  by (induction \<phi> arbitrary: v) (auto)

lemma unique_names_matches_absorb: "fst x \<in> names \<alpha> \<Longrightarrow> names \<alpha> \<inter> names \<beta> = {} \<Longrightarrow>
    MFOTL.matches v \<alpha> x \<or> MFOTL.matches v \<beta> x \<longleftrightarrow> MFOTL.matches v \<alpha> x"
  "fst x \<in> names \<beta> \<Longrightarrow> names \<alpha> \<inter> names \<beta> = {} \<Longrightarrow>
    MFOTL.matches v \<alpha> x \<or> MFOTL.matches v \<beta> x \<longleftrightarrow> MFOTL.matches v \<beta> x"
  by (auto dest: matches_in_names)

definition mergeable_envs where
  "mergeable_envs n S \<longleftrightarrow> (\<forall>v1\<in>S. \<forall>v2\<in>S. (\<forall>A B f.
    (\<forall>x\<in>A. x < n \<and> v1 ! x = f x) \<and> (\<forall>x\<in>B. x < n \<and> v2 ! x = f x) \<longrightarrow>
    (\<exists>v\<in>S. \<forall>x\<in>A \<union> B. v ! x = f x)))"

lemma mergeable_envsI:
  assumes "\<And>v1 v2 v. v1 \<in> S \<Longrightarrow> v2 \<in> S \<Longrightarrow> length v = n \<Longrightarrow> \<forall>x < n. v ! x = v1 ! x \<or> v ! x = v2 ! x \<Longrightarrow> v \<in> S"
  shows "mergeable_envs n S"
  unfolding mergeable_envs_def
proof (safe, goal_cases mergeable)
  case [simp]: (mergeable v1 v2 A B f)
  let ?v = "tabulate (\<lambda>x. if x \<in> A \<union> B then f x else v1 ! x) 0 n"
  from assms[of v1 v2 ?v, simplified] show ?case
    by (auto intro!: bexI[of _ ?v])
qed

lemma in_listset_nth: "x \<in> listset As \<Longrightarrow> i < length As \<Longrightarrow> x ! i \<in> As ! i"
  by (induction As arbitrary: x i) (auto simp: set_Cons_def nth_Cons split: nat.split)

lemma all_nth_in_listset: "length x = length As \<Longrightarrow> (\<And>i. i < length As \<Longrightarrow> x ! i \<in> As ! i) \<Longrightarrow> x \<in> listset As"
  by (induction x As rule: list_induct2) (fastforce simp: set_Cons_def nth_Cons)+

lemma mergeable_envs_listset: "mergeable_envs (length As) (listset As)"
  by (rule mergeable_envsI) (auto intro!: all_nth_in_listset elim!: in_listset_nth)

lemma mergeable_envs_Ex: "mergeable_envs n S \<Longrightarrow> MFOTL.nfv \<alpha> \<le> n \<Longrightarrow> MFOTL.nfv \<beta> \<le> n \<Longrightarrow>
  (\<exists>v'\<in>S. \<forall>x\<in>fv \<alpha>. v' ! x = v ! x) \<Longrightarrow> (\<exists>v'\<in>S. \<forall>x\<in>fv \<beta>. v' ! x = v ! x) \<Longrightarrow>
  (\<exists>v'\<in>S. \<forall>x\<in>fv \<alpha> \<union> fv \<beta>. v' ! x = v ! x)"
proof (clarify, goal_cases mergeable)
  case (mergeable v1 v2)
  then show ?case
    by (auto intro: order.strict_trans2[OF fvi_less_nfv[rule_format]]
      elim!: mergeable_envs_def[THEN iffD1, rule_format, of _ _ v1 v2])
qed

lemma in_set_ConsE: "xs \<in> set_Cons A As \<Longrightarrow> (\<And>y ys. xs = y # ys \<Longrightarrow> y \<in> A \<Longrightarrow> ys \<in> As \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding set_Cons_def by blast

lemma mergeable_envs_set_Cons: "mergeable_envs n S \<Longrightarrow> mergeable_envs (Suc n) (set_Cons UNIV S)"
  unfolding mergeable_envs_def
proof (clarify, elim in_set_ConsE, goal_cases mergeable)
  case (mergeable v1 v2 A B f y1 ys1 y2 ys2)
  let ?A = "(\<lambda>x. x - 1) ` (A - {0})"
  let ?B = "(\<lambda>x. x - 1) ` (B - {0})"
  from mergeable(4-9) have "\<exists>v \<in> S. \<forall>x\<in>?A \<union> ?B. v ! x = f (Suc x)"
    by (auto dest!: mergeable(2,3)[rule_format] intro!: mergeable(1)[rule_format, of ys1 ys2])
  then obtain v where "v \<in> S" "\<forall>x\<in>?A \<union> ?B. v ! x = f (Suc x)" by blast
  then show ?case
    by (intro bexI[of _ "f 0 # v"]) (auto simp: nth_Cons' set_Cons_def)
qed

lemma slice_Exists: "MFOTL_slicer.slice (MFOTL.Exists \<phi>) S \<sigma> = MFOTL_slicer.slice \<phi> (set_Cons UNIV S) \<sigma>"
  by (auto simp: set_Cons_def intro: map_\<Gamma>_cong)

lemma image_Suc_fvi: "Suc ` MFOTL.fvi (Suc b) \<phi> = MFOTL.fvi b \<phi> - {0}"
  by (auto simp: image_def Bex_def MFOTL.fvi_Suc dest: gr0_implies_Suc)

lemma nfv_Exists: "MFOTL.nfv (MFOTL.Exists \<phi>) = MFOTL.nfv \<phi> - 1"
  unfolding MFOTL.nfv_def
  by (cases "fv \<phi> = {}") (auto simp add: image_Suc_fvi mono_Max_commute[symmetric] mono_def)

lemma set_Cons_empty_iff[simp]: "set_Cons A Xs = {} \<longleftrightarrow> A = {} \<or> Xs = {}"
  unfolding set_Cons_def by auto

lemma unique_sat_slice_mem: "safe_formula \<phi> \<Longrightarrow> gen_unique \<phi> \<Longrightarrow> S \<noteq> {} \<Longrightarrow>
  mergeable_envs n S \<Longrightarrow> MFOTL.nfv \<phi> \<le> n \<Longrightarrow>
  MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi> \<Longrightarrow> \<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
proof (induction arbitrary: v i S n rule: safe_formula_induct)
  case (1 t1 t2)
  then show ?case by (cases "t2") (auto simp: MFOTL.is_Const_def)
next
  case (2 t1 t2)
  then show ?case by (cases "t1") (auto simp: MFOTL.is_Const_def)
next
  case (3 x y)
  then show ?case by auto
next
  case (4 x y)
  then show ?case by simp
next
  case (5 e ts)
  then obtain v' where "v' \<in> S" and eq: "\<forall>t\<in>set ts. MFOTL.eval_trm v' t = MFOTL.eval_trm v t"
    by auto
  have "\<forall>t\<in>set ts. \<forall>x\<in>fv_trm t. v' ! x = v ! x" proof
    fix t assume "t \<in> set ts"
    with eq have "MFOTL.eval_trm v' t = MFOTL.eval_trm v t" ..
    then show "\<forall>x\<in>fv_trm t. v' ! x = v ! x" by (cases t) (simp_all)
  qed
  with \<open>v' \<in> S\<close> show ?case by auto
next
  case (6 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.And \<phi> \<psi>)\<close>
  have
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And \<phi> \<psi>) S \<sigma>) v i \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v i \<psi>"
    unfolding MFOTL.And_def
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)+
  with 6(1,4-) 6(2,3)[where S=S] show ?case
    unfolding MFOTL.And_def
    by (auto intro!: mergeable_envs_Ex)
next
  case (7 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.And_Not \<phi> \<psi>)\<close>
  have "MFOTL.sat (MFOTL_slicer.slice (MFOTL.And_Not \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    unfolding MFOTL.And_Not_def
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  with 7(1,2,5-) 7(3)[where S=S] have "\<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    unfolding MFOTL.And_Not_def by auto
  with \<open>fv \<psi> \<subseteq> fv \<phi>\<close> show ?case by (auto simp: MFOTL.fvi_And_Not)
next
  case (8 \<phi> \<psi>)
  from \<open>gen_unique (MFOTL.Or \<phi> \<psi>)\<close>
  have
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Or \<phi> \<psi>) S \<sigma>) v i \<phi> = MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Or \<phi> \<psi>) S \<sigma>) v i \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v i \<psi>"
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)+
  with 8(1,4-) 8(2,3)[where S=S] have "\<exists>v'\<in>S. \<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    by (auto simp: \<open>fv \<psi> = fv \<phi>\<close>)
  then show ?case by (auto simp: \<open>fv \<psi> = fv \<phi>\<close>)
next
  case (9 \<phi>)
  then obtain z where sat_\<phi>: "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Exists \<phi>) S \<sigma>) (z # v) i \<phi>"
    by auto
  from "9.prems" sat_\<phi> have "\<exists>v'\<in>set_Cons UNIV S. \<forall>x\<in>fv \<phi>. v' ! x = (z # v) ! x"
    unfolding slice_Exists
    by (intro "9.IH") (auto simp: nfv_Exists intro!: mergeable_envs_set_Cons)
  then show ?case
    by (auto simp: set_Cons_def fvi_Suc Ball_def nth_Cons split: nat.splits)
next
  case (10 I \<phi>)
  then obtain j where "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v j \<phi>"
    by (auto split: nat.splits)
  with 10 show ?case by simp
next
  case (11 I \<phi>)
  then obtain j where "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v j \<phi>"
    by (auto split: nat.splits)
  with 11 show ?case by simp
next
  case (12 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Since \<phi> I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since \<phi> I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 12 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since \<phi> I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 12 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv \<phi> \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (13 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 13 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Since (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 13 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv (MFOTL.Neg \<phi>) \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (14 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Until \<phi> I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until \<phi> I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 14 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until \<phi> I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 14 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv \<phi> \<subseteq> fv \<psi>\<close> show ?case by auto
next
  case (15 \<phi> I \<psi>)
  from \<open>gen_unique (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>)\<close>
  have *:
    "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi> = MFOTL.sat (MFOTL_slicer.slice \<psi> S \<sigma>) v j \<psi>" for j
    by (fastforce simp: unique_names_matches_absorb intro!: sat_inter_names_cong)
  from 15 obtain j where "MFOTL.sat (MFOTL_slicer.slice (MFOTL.Until (MFOTL.Neg \<phi>) I \<psi>) S \<sigma>) v j \<psi>"
    by auto
  with 15 have "\<exists>v'\<in>S. \<forall>x\<in>fv \<psi>. v' ! x = v ! x" using * by auto
  with \<open>fv (MFOTL.Neg \<phi>) \<subseteq> fv \<psi>\<close> show ?case by auto
qed

lemma unique_sat_slice:
  assumes formula: "safe_formula \<phi>" "gen_unique \<phi>"
      and restr: "S \<noteq> {}" "mergeable_envs (MFOTL.nfv \<phi>) S"
      and sat_slice: "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v i \<phi>"
    shows "MFOTL.sat \<sigma> v i \<phi>"
proof -
  obtain v' where "v' \<in> S" and fv_eq: "\<forall>x\<in>fv \<phi>. v' ! x = v ! x"
    using unique_sat_slice_mem[OF formula restr order_refl sat_slice] ..
  with sat_slice have "MFOTL.sat (MFOTL_slicer.slice \<phi> S \<sigma>) v' i \<phi>"
    by (auto iff: sat_fvi_cong)
  then have "MFOTL.sat \<sigma> v' i \<phi>"
    unfolding sat_slice_iff[OF \<open>v' \<in> S\<close>, symmetric] .
  with fv_eq show ?thesis by (auto iff: sat_fvi_cong)
qed

subsubsection \<open>Lemma 3\<close>

lemma (in splitting_strategy) unique_sat_strategy:
  "safe_formula \<phi> \<Longrightarrow> gen_unique \<phi> \<Longrightarrow> slice_set k \<noteq> {} \<Longrightarrow>
  mergeable_envs (MFOTL.nfv \<phi>) (slice_set k) \<Longrightarrow>
  MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>) (map the v) i \<phi> \<Longrightarrow>
  ok \<phi> v \<Longrightarrow> k \<in> strategy v"
  by (drule (3) unique_sat_slice_mem) (auto dest: wf_tuple_cong)

locale skip_inter = joint_data_slicer +
  assumes nonempty: "slice_set k \<noteq> {}"
  and mergeable: "mergeable_envs (MFOTL.nfv \<phi>) (slice_set k)"
begin

subsubsection \<open>Definition of J'\<close>

definition "skip_joiner = (\<lambda>s. \<Union>k. s k)"

subsubsection \<open>Theorem 3\<close>

lemma skip_joiner:
  assumes "safe_formula \<phi>" "gen_unique \<phi>"
  shows "joiner (\<lambda>k. M (splitter \<pi> k)) = skip_joiner (\<lambda>k. M (splitter \<pi> k))"
  (is "?L = ?R")
proof safe
  fix i v
  assume "(i, v) \<in> ?R"
  then obtain k where in_M: "(i, v) \<in> M (splitter \<pi> k)"
  unfolding skip_joiner_def by blast
  from ex_prefix_of obtain \<sigma> where "prefix_of \<pi> \<sigma>" by blast
  with wf_monitor[OF in_M] sound_monitor[OF in_M] have
    "MFOTL.sat (MFOTL_slicer.slice \<phi> (slice_set k) \<sigma>) (map the v) i \<phi>" "ok \<phi> v"
    by (auto simp: splitter_pslice intro!: prefix_of_pmap_\<Gamma>)
  note unique_sat_strategy[OF assms nonempty mergeable this]
  with in_M show "(i, v) \<in> ?L" unfolding joiner_def by blast
qed (auto simp: joiner_def skip_joiner_def)

sublocale skip_joint_monitor: MFOTL_monitor \<phi>
  "\<lambda>\<pi>. (if safe_formula \<phi> \<and> gen_unique \<phi> then skip_joiner else joiner) (\<lambda>k. M (splitter \<pi> k))"
  using joint_monitor.mono_monitor joint_monitor.wf_monitor joint_monitor.sound_monitor joint_monitor.complete_monitor
  by unfold_locales (auto simp: skip_joiner[symmetric] split: if_splits)

end

(*<*)
end
(*>*)


section \<open>Abstract Syntax of PiCore Language\<close>

theory PiCore_Language
imports Main begin

type_synonym 's bexp = "'s set"

type_synonym 's guard = "'s set"

(* 'prog: the type of program command *)
type_synonym ('l,'s,'prog) event' = "'l \<times> ('s guard \<times> 'prog)"

definition guard :: "('l,'s,'prog) event' \<Rightarrow> 's guard" where
  "guard ev \<equiv> fst (snd ev)"

definition body :: "('l,'s,'prog) event' \<Rightarrow> 'prog" where
  "body ev \<equiv> snd (snd ev)"

datatype ('l,'k,'s,'prog) event =
      AnonyEvent "'prog"
    | BasicEvent "('l,'s,'prog) event'"

datatype ('l,'k,'s,'prog) esys =
      EvtSeq "('l,'k,'s,'prog) event" "('l,'k,'s,'prog) esys"
    | EvtSys "('l,'k,'s,'prog) event set"

type_synonym ('l,'k,'s,'prog) paresys = "'k \<Rightarrow> ('l,'k,'s,'prog) esys"

section \<open>Some Lemmas of Abstract Syntax\<close>

primrec is_basicevt :: "('l,'k,'s,'prog) event \<Rightarrow> bool"
  where "is_basicevt (AnonyEvent _) = False" |
        "is_basicevt (BasicEvent _) = True"

primrec is_anonyevt :: "('l,'k,'s,'prog) event \<Rightarrow> bool"
  where "is_anonyevt (AnonyEvent _) = True" |
        "is_anonyevt (BasicEvent _) = False"

lemma basicevt_isnot_anony: "is_basicevt e \<Longrightarrow> \<not> is_anonyevt e"
  by (metis event.exhaust is_anonyevt.simps(2) is_basicevt.simps(1))

lemma anonyevt_isnot_basic: "is_anonyevt e \<Longrightarrow> \<not> is_basicevt e"
  using basicevt_isnot_anony by auto

lemma evtseq_ne_es: "EvtSeq e es \<noteq> es"
  apply(induct es)
  apply auto[1]
  by simp

end


(*  Title:       X86 instruction semantics and basic block symbolic execution
    Authors:     Freek Verbeek, Abhijith Bharadwaj, Joshua Bockenek, Ian Roessle, Timmy Weerwag, Binoy Ravindran
    Year:        2020
    Maintainer:  Freek Verbeek (freek@vt.edu)
*)

section "Memory-related theorems"

theory Memory
  imports BitByte
begin

context
  fixes dummy_type :: "'a::len"
begin

primrec read_bytes :: "('a word \<Rightarrow> 8 word) \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> 8word list"
  where "read_bytes m a 0   = []"
  | "read_bytes m a (Suc n) = m (a + of_nat n) # read_bytes m a n"

text \<open>Read bytes from memory. Memory is represented by a term of @{typ "64 word \<Rightarrow> 8 word"}.
      Given an address @{term [show_types] "a::64 word"} and a size @{term n}, retrieve the bytes in
      the order they are stored in memory.\<close>

definition region_addresses :: "'a word \<Rightarrow> nat \<Rightarrow> 'a word set"
  where "region_addresses a si \<equiv> {a' . \<exists> i < si . a' = a + of_nat (si - i - 1)}"

text \<open>The set of addresses belonging to a region starting at address @{term "a::64 word"} of @{term si} bytes.\<close>

definition region_overflow :: "'a word \<Rightarrow> nat \<Rightarrow> bool"
  where "region_overflow a si \<equiv> unat a + si \<ge> 2^LENGTH('a)"

text \<open>An overflow occurs if the address plus the size is greater equal @{term "2^64"}\<close>

definition enclosed :: "'a word \<Rightarrow> nat \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> bool"
  where "enclosed a' si' a si \<equiv> unat a + si < 2^LENGTH('a) \<and> unat a \<le> unat a' \<and> unat a' + si' \<le> unat a + si"

text \<open>A region is enclosed in another if its @{const region_addresses} is a subset of the other.\<close>

definition separate :: "'a word \<Rightarrow> nat \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> bool"
  where "separate a si a' si' \<equiv> si \<noteq>0 \<and> si' \<noteq> 0 \<and> region_addresses a si \<inter> region_addresses a' si' = {}"

text \<open>A region is separate from another if they do not overlap.\<close>

lemma region_addresses_iff: "a' \<in> region_addresses a si \<longleftrightarrow> unat (a' - a) < si"
  apply (auto simp add: region_addresses_def unsigned_of_nat)
   apply (metis diff_Suc_less le_less_trans less_imp_Suc_add take_bit_nat_less_eq_self zero_less_Suc)
  by (smt (z3) add.commute add_Suc_right add_diff_cancel_left' diff_add_cancel less_add_Suc2 less_imp_Suc_add word_unat.Rep_inverse)

lemma notin_region_addresses:
  assumes "x \<notin> region_addresses a si"
  shows "unat x < unat a \<or> unat a + si \<le> unat x"
  by (metis assms add.commute less_diff_conv2 not_le_imp_less region_addresses_iff unat_sub_if')

lemma notin_region_addresses_sub:
  assumes "x \<notin> region_addresses a si"
  shows "unat (x - a') < unat (a - a') \<or> unat (a - a') + si \<le> unat (x - a')"
  using assms notin_region_addresses region_addresses_iff by auto

lemma region_addresses_eq_empty_iff: "region_addresses a si = {} \<longleftrightarrow> si = 0"
  by (metis region_addresses_iff add_diff_cancel_left' ex_in_conv neq0_conv not_less0 unsigned_0)

lemma length_read_bytes:
  shows "length (read_bytes m a si) = si"
  by (induct si,auto)

lemma nth_read_bytes:
assumes "n < si"
shows "read_bytes m a si ! n = m (a + of_nat (si - 1 - n))"
  using assms
  apply (induct si arbitrary: n,auto)
  subgoal for si n
    by(cases n,auto)
  done

text \<open>Writing to memory occurs via function @{const override_on}.
      In case of enclosure, reading bytes from memory overridden on a set of region addresses can
      be simplified to reading bytes from the overwritten memory only.
      In case of separation, reading bytes from overridden memory can be simplified to reading
      from the original memory.\<close>

lemma read_bytes_override_on_enclosed:
assumes "offset' \<le> offset"
    and "si' \<le> si"
    and "unat offset + si' \<le> si + unat offset'"
  shows "read_bytes (override_on m m' (region_addresses (a - offset) si)) (a - offset') si' = read_bytes m' (a - offset') si'"
proof-
  {
    fix i
    assume 1: "i < si'"
    let ?i = "(si + i + unat offset') - unat offset - si'"

    have "i + unat offset' < si' + unat offset"
      using 1 assms(1)
      by unat_arith
    hence 2: "si + i + unat offset' - (unat offset + si') < si"
      using diff_less[of "(si' + unat offset - i) - unat offset'" si] assms(3)
      by auto
    moreover
    have "of_nat (si' - Suc i) - offset' = of_nat (si - Suc ?i) - offset"
      using assms 1 2 by (auto simp add: of_nat_diff)
    ultimately
    have "\<exists> i' < si. of_nat (si' - Suc i) - offset' = of_nat (si - Suc i') - offset"
      by auto
  }
  note 1 = this
  show ?thesis
    apply (rule nth_equalityI)
    using 1
    by (auto simp add: length_read_bytes nth_read_bytes override_on_def region_addresses_def)
qed

lemmas read_bytes_override_on = read_bytes_override_on_enclosed[where offset=0 and offset'=0,simplified]

lemma read_bytes_override_on_enclosed_plus:
  assumes "unat offset + si' \<le> si"
      and "si \<le> 2^LENGTH('a)"
  shows "read_bytes (override_on m m' (region_addresses a si)) (offset+a) si' = read_bytes m' (offset+a) si'"
proof-
  {
    fix i
    have "i < si' \<Longrightarrow> \<exists> i' < si. offset + (of_nat (si' - Suc i)::'a word) = of_nat (si - Suc i')"
      apply (rule exI[of _"si - si' + i - unat offset"])
      using assms by (auto simp add: of_nat_diff)
  }
  note 1 = this
  show ?thesis
    apply (rule nth_equalityI)
    using assms 1
    by (auto simp add: override_on_def length_read_bytes nth_read_bytes region_addresses_def)
qed

lemma read_bytes_override_on_separate:
assumes "separate a si a' si'"
  shows "read_bytes (override_on m m' (region_addresses a si)) a' si' = read_bytes m a' si'"
  apply (rule nth_equalityI)
  using assms
  by (auto simp add: length_read_bytes nth_read_bytes override_on_def separate_def region_addresses_def)

text\<open>Bytes are are written to memory one-by-one, then read by @{const read_bytes} producing a list of bytes.
    That list is concatenated again using @{const word_rcat}. Writing @{term si} bytes of word @{term w} into
    memory, reading the byte-list and concatenating again produces @{term si} bytes of the original word.\<close>

lemma word_rcat_read_bytes_enclosed:
  fixes w :: "'b::len word"
  assumes "LENGTH('b) \<le> 2^LENGTH('a)"
    and "unat offset + si \<le> 2^LENGTH('a)"
  shows "word_rcat (read_bytes (\<lambda>a'. take_byte (unat (a' - a)) w) (a + offset) si) = \<langle>unat offset * 8,(unat offset + si) * 8\<rangle>w"
  apply (rule word_eqI)
  using assms
  apply (auto simp add: test_bit_rcat word_size length_read_bytes rev_nth nth_read_bytes unat_of_nat nth_takebyte unat_word_ariths )
    apply (auto simp add: take_byte_def nth_ucast nth_takebits take_bit_eq_mod split: if_split_asm)[1]
   apply (auto simp add: nth_takebits split: if_split_asm)[1]
  apply (auto simp add: take_byte_def nth_ucast nth_takebits split: if_split_asm)[1]
  by (auto simp add: rev_nth length_read_bytes take_byte_def nth_ucast nth_takebits nth_read_bytes unat_word_ariths unat_of_nat take_bit_eq_mod split: if_split_asm)

lemmas word_rcat_read_bytes = word_rcat_read_bytes_enclosed[where offset=0,simplified]

text \<open>The following theorems allow reasoning over enclosure and separation, for example as linear arithmetic.\<close>

lemma enclosed_spec:
  assumes enclosed: "enclosed a' si' a si"
      and x_in: "x \<in> region_addresses a' si'"
    shows "x \<in> region_addresses a si"
proof -
  from x_in have "unat (x - a') < si'"
    using region_addresses_iff by blast
  with enclosed have "unat (x - a) < si"
    unfolding enclosed_def by (auto simp add: unat_sub_if' split: if_split_asm)
  then show ?thesis
    using region_addresses_iff by blast
qed

lemma address_in_enclosed_region_as_linarith:
  assumes "enclosed a' si' a si"
      and "x \<in> region_addresses a' si'"
    shows "a \<le> x \<and> a' \<le> x \<and> x < a' + of_nat si' \<and> x < a + of_nat si"
  using assms
  by (auto simp add: enclosed_def region_addresses_def word_le_nat_alt word_less_nat_alt unat_of_nat unat_word_ariths unat_sub_if' take_bit_eq_mod)

lemma address_of_enclosed_region_ge:
  assumes "enclosed a' si' a si"
    shows "a' \<ge> a"
  using assms word_le_nat_alt
  by (auto simp add: enclosed_def)

lemma address_in_enclosed_region:
  assumes "enclosed a' si' a si"
      and "x \<in> region_addresses a' si'"
    shows "unat (x - a) \<ge> unat (a' - a) \<and> unat (a' - a) + si' > unat (x - a) \<and> unat (x - a) < si"
  by (smt (z3) address_in_enclosed_region_as_linarith add_diff_cancel_left' address_of_enclosed_region_ge assms(1) assms(2) diff_diff_add enclosed_spec le_iff_add nat_add_left_cancel_less region_addresses_iff unat_sub_if' word_le_minus_mono_left word_unat.Rep_inverse word_unat_less_le)

lemma enclosed_minus_minus:
  fixes a :: "'a word"
  assumes "offset \<ge> offset'"
      and "unat offset - si \<le> unat offset' - si'"
      and "unat offset' \<ge> si'"
      and "unat offset \<ge> si"
      and "a \<ge> offset"
    shows "enclosed (a - offset') si' (a - offset) si"
proof-
  have "unat offset' \<le> unat a"
    using assms(1,5)
    by unat_arith
  thus ?thesis
    using assms
    apply (auto simp add: enclosed_def unat_sub_if_size word_size)
    apply unat_arith
    using diff_le_mono2[of "unat offset - si" "unat offset' - si'" "unat a"]
    apply (auto simp add: enclosed_def unat_sub_if_size word_size)
     by unat_arith+
qed

lemma enclosed_plus:
  fixes a :: "'a word"
  assumes "si' < si"
      and "unat a + si < 2^LENGTH('a)"
    shows "enclosed a si' a si"
  using assms
  by (auto simp add: enclosed_def)

lemma separate_symm: "separate a si a' si' = separate a' si' a si"
  by (metis inf.commute separate_def)

lemma separate_iff: "separate a si a' si' \<longleftrightarrow> si > 0 \<and> si' > 0 \<and> unat (a' - a) \<ge> si \<and> unat (a - a') \<ge> si'"
proof
  assume assm: "separate a si a' si'"
  have "unat (a' - a) \<ge> si" if "separate a si a' si'" for a si a' si'
  proof (rule ccontr)
    assume "\<not> unat (a' - a) \<ge> si"
    then have "a' \<in> region_addresses a si"
      by (simp add: region_addresses_iff)
    moreover from that have "a' \<in> region_addresses a' si'"
      using region_addresses_iff separate_def by auto
    ultimately have "\<not>separate a si a' si'"
      by (meson disjoint_iff separate_def)
    with that show False
      by blast
  qed
  with assm have "unat (a' - a) \<ge> si" and "unat (a - a') \<ge> si'"
    using separate_symm by auto
  with assm show "si > 0 \<and> si' > 0 \<and> unat (a' - a) \<ge> si \<and> unat (a - a') \<ge> si'"
    using separate_def by auto
next
  assume assm: "si > 0 \<and> si' > 0 \<and> unat (a' - a) \<ge> si \<and> unat (a - a') \<ge> si'"
  then have "unat (x - a') \<ge> si'" if "unat (x - a) < si" for x
    using that apply (auto simp add: unat_sub_if' split: if_split_asm)
     apply (meson Nat.le_diff_conv2 add_increasing le_less_trans less_imp_le_nat unsigned_greater_eq unsigned_less)
    by (smt (z3) Nat.le_diff_conv2 add_leD2 le_less_trans linorder_not_less nat_le_linear unat_lt2p)
  then have "region_addresses a si \<inter> region_addresses a' si' = {}"
    by (simp add: region_addresses_iff disjoint_iff leD)
  with assm show "separate a si a' si'"
    by (simp add: separate_def)
qed

lemma separate_as_linarith:
assumes "\<not>region_overflow a si"
    and "\<not>region_overflow a' si'"
  shows "separate a si a' si' \<longleftrightarrow> 0 < si \<and> 0 < si' \<and> (a + of_nat si \<le> a' \<or> a' + of_nat si' \<le> a)"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs then show ?rhs
   by (meson separate_iff le_less le_plus not_le_imp_less word_of_nat_le)
next
  have *: "separate a si a' si'"
    if "si > 0" and "si' > 0" and "a + of_nat si \<le> a'"
      and "\<not>region_overflow a si" and "\<not>region_overflow a' si'"
    for a si a' si'
  proof -
    from that have "unat a + si < 2^LENGTH('a)" and "unat a' + si' < 2^LENGTH('a)"
      by (meson not_le region_overflow_def)+
    have "x < a + of_nat si" if "x \<in> region_addresses a si" for x
      by (smt (z3) Abs_fnat_hom_add \<open>unat a + si < 2 ^ LENGTH('a)\<close> add.commute dual_order.trans le_add1 less_diff_conv2 not_less region_addresses_iff that unat_of_nat_len unat_sub_if' word_less_iff_unsigned word_unat.Rep_inverse)
    moreover have "x \<ge> a'" if "x \<in> region_addresses a' si'" for x
      using address_in_enclosed_region_as_linarith enclosed_def \<open>unat a' + si' < 2 ^ LENGTH('a)\<close> that by blast
    ultimately show ?thesis
      using separate_def that by fastforce
  qed
  assume ?rhs then show ?lhs
    by (meson "*" assms separate_symm)
qed

text \<open>Compute separation in case the addresses and sizes are immediate values.\<close>
lemmas separate_as_linarith_numeral [simp] =
  separate_as_linarith [of "numeral a::'a word" "numeral si" "numeral a'::'a word" "numeral si'"] for a si a' si'
lemmas separate_as_linarith_numeral_1 [simp] =
  separate_as_linarith [of "numeral a::'a word" "numeral si" "numeral a'::'a word" "Suc 0"] for a si a'
lemmas separate_as_linarith_numeral1_ [simp] =
  separate_as_linarith [of "numeral a::'a word" "Suc 0" "numeral a'::'a word" "numeral si'"] for a a' si'
lemmas separate_as_linarith_numeral11 [simp] =
  separate_as_linarith [of "numeral a::'a word" "Suc 0" "numeral a'::'a word" "Suc 0"] for a a'
lemmas region_overflow_numeral[simp] =
  region_overflow_def [of "numeral a::'a word" "numeral si"] for a si
lemmas region_overflow_numeral1[simp] =
  region_overflow_def [of "numeral a::'a word" "Suc 0"] for a

lemma separate_plus_none:
  assumes "si' \<le> unat offset"
      and "0 < si"
      and "0 < si'"
      and "unat offset + si \<le> 2^LENGTH('a)"
    shows "separate (offset + a) si a si'"
  using assms apply (auto simp add: separate_iff)
  by (smt (z3) Nat.diff_diff_right add.commute add_leD1 diff_0 diff_is_0_eq diff_zero not_gr_zero unat_sub_if' unsigned_0)

lemmas unat_minus = unat_sub_if'[of 0,simplified]

lemma separate_minus_minus':
  assumes "si \<noteq> 0"
      and "si' \<noteq> 0"
      and "unat offset \<ge> si"
      and "unat offset' \<ge> si'"
      and "unat offset - si \<ge> unat offset'"
    shows "separate (a - offset) si (a - offset') si'"
  using assms apply (auto simp add: separate_iff)
   apply (metis Nat.le_diff_conv2 add.commute add_leD2 unat_sub_if')
  by (smt (z3) add.commute add_diff_cancel_right' diff_add_cancel diff_le_self diff_less less_le_trans nat_le_linear not_le unat_sub_if')

lemma separate_minus_minus:
  assumes "si \<noteq> 0"
      and "si' \<noteq> 0"
      and "unat offset \<ge> si"
      and "unat offset' \<ge> si'"
      and "unat offset - si \<ge> unat offset' \<or> unat offset' - si' \<ge> unat offset"
    shows "separate (a - offset) si (a - offset') si'"
  by (meson assms separate_minus_minus' separate_symm)

lemma separate_minus_none:
  assumes "si \<noteq> 0"
      and "si' \<noteq> 0"
      and "unat offset \<ge> si"
      and "si' \<le> 2^LENGTH('a) - unat offset"
    shows "separate (a - offset) si a si'"
proof -
  have "0 < si" and "0 < si'"
    using assms(1,2) by blast+
  moreover have "\<not> offset \<le> 0"
    using assms(1) assms(3) by fastforce
  ultimately show ?thesis
    by (smt (z3) add_diff_cancel_left' assms(3,4) diff_diff_eq2 diff_zero le_add_diff_inverse less_or_eq_imp_le separate_iff unat_sub_if' unsigned_0 unsigned_less word_less_eq_iff_unsigned)
qed

text \<open>The following theorems are used during symbolic execution to determine whether two regions are separate.\<close>

lemmas separate_simps = separate_plus_none separate_minus_none separate_minus_minus

end
end