\<^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--_To_SAS++/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


(*  File:       Profile.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Preference Profile\<close>

theory Profile
  imports Preference_Relation
begin

text
\<open>Preference profiles denote the decisions made by the individual voters on
the eligible alternatives. They are represented in the form of one preference
relation (e.g., selected on a ballot) per voter, collectively captured in a
list of such preference relations.
Unlike a the common preference profiles in the social-choice sense, the
profiles described here considers only the (sub-)set of alternatives that are
received.\<close>

subsection \<open>Definition\<close>

(*A profile contains one ballot for each voter.*)
type_synonym 'a Profile = "('a Preference_Relation) list"

(*
   A profile on a finite set of alternatives A contains only ballots that are
   linear orders on A.
*)
definition profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "profile A p \<equiv> \<forall>i::nat. i < length p \<longrightarrow> linear_order_on A (p!i)"

lemma profile_set : "profile A p \<equiv> (\<forall>b \<in> (set p). linear_order_on A b)"
  by (simp add: all_set_conv_all_nth profile_def)

abbreviation finite_profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "finite_profile A p \<equiv> finite A \<and> profile A p"

subsection \<open>Preference Counts and Comparisons\<close>

(*
   The win count for an alternative a in a profile p is
   the amount of ballots in p that rank alternative a in first position.
*)
fun win_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count p a =
    card {i::nat. i < length p \<and> above (p!i) a = {a}}"

fun win_count_code :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count_code Nil a = 0" |
  "win_count_code (p#ps) a =
      (if (above p a = {a}) then 1 else 0) + win_count_code ps a"

lemma win_count_equiv[code]: "win_count p x = win_count_code p x"
proof (induction p rule: rev_induct, simp)
  case (snoc a p)
  fix
    a :: "'a Preference_Relation" and
    p :: "'a Profile"
  assume
    base_case:
    "win_count p x = win_count_code p x"
  have size_one: "length [a] = 1"
    by simp
  have p_pos_in_ps:
    "\<forall>i<length p. p!i = (p@[a])!i"
    by (simp add: nth_append)
  have
    "win_count [a] x =
      (let q = [a] in
        card {i::nat. i < length q \<and>
              (let r = (q!i) in (above r x = {x}))})"
    by simp
  hence one_ballot_equiv:
    "win_count [a] x = win_count_code [a] x"
    using size_one
    by (simp add: nth_Cons')
  have pref_count_induct:
    "win_count (p@[a]) x =
      win_count p x + win_count [a] x"
  proof (simp)
    have
      "{i. i = 0 \<and> (above ([a]!i) x = {x})} =
        (if (above a x = {x}) then {0} else {})"
      by (simp add: Collect_conv_if)
    hence shift_idx_a:
      "card {i. i = length p \<and> (above ([a]!0) x = {x})} =
        card {i. i = 0 \<and> (above ([a]!i) x = {x})}"
      by simp
    have set_prof_eq:
      "{i. i < Suc (length p) \<and> (above ((p@[a])!i) x = {x})} =
        {i. i < length p \<and> (above (p!i) x = {x})} \<union>
          {i. i = length p \<and> (above ([a]!0) x = {x})}"
    proof (safe, simp_all)
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xa \<noteq> length p" and
        "xaa \<in> above (p!xa) x"
      thus "xaa = x"
        using less_antisym p_pos_in_ps singletonD
        by metis
    next
      fix
        xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xa \<noteq> length p"
      thus "x \<in> above (p!xa) x"
        using less_antisym insertI1 p_pos_in_ps
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x"
      thus "xa < length p"
        using less_antisym nth_append_length
              p_pos_in_ps singletonD
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a" and
        xb :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x" and
        "xb \<in> above (p!xa) x"
      thus "xb = x"
        using less_antisym p_pos_in_ps
              nth_append_length singletonD
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x"
      thus "x \<in> above (p!xa) x"
        using insertI1 less_antisym nth_append
              nth_append_length singletonD
        by metis
    next
      fix
        xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x"
      thus "xa < length p"
        using insertI1 less_antisym nth_append_length
        by metis
    next
      fix
        xa :: nat and
        xb :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x" and
        "xb \<in> above (p!xa) x"
      thus "xb = x"
        using insertI1 less_antisym nth_append_length
              p_pos_in_ps singletonD
        by metis
    next
      fix
        xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x"
      thus "x \<in> above (p!xa) x"
        using insertI1 less_antisym nth_append_length p_pos_in_ps
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < length p" and
        "above (p!xa) x = {x}" and
        "xaa \<in> above ((p@[a])!xa) x"
      thus "xaa = x"
        by (simp add: nth_append)
    next
      fix
        xa :: nat
      assume
        "xa < length p" and
        "above (p!xa) x = {x}"
      thus "x \<in> above ((p@[a])!xa) x"
        by (simp add: nth_append)
    qed
    have f1:
      "finite {n. n < length p \<and> (above (p!n) x = {x})}"
      by simp
    have f2:
      "finite {n. n = length p \<and> (above ([a]!0) x = {x})}"
      by simp
    have
      "card ({i. i < length p \<and> (above (p!i) x = {x})} \<union>
        {i. i = length p \<and> (above ([a]!0) x = {x})}) =
          card {i. i < length p \<and> (above (p!i) x = {x})} +
            card {i. i = length p \<and> (above ([a]!0) x = {x})}"
      using f1 f2 card_Un_disjoint
      by blast
    thus
      "card {i. i < Suc (length p) \<and> (above ((p@[a])!i) x = {x})} =
        card {i. i < length p \<and> (above (p!i) x = {x})} +
          card {i. i = 0 \<and> (above ([a]!i) x = {x})}"
      using set_prof_eq shift_idx_a
      by auto
  qed
  have pref_count_code_induct:
    "win_count_code (p@[a]) x =
      win_count_code p x + win_count_code [a] x"
  proof (induction p, simp)
    fix
      aa :: "'a Preference_Relation" and
      p :: "'a Profile"
    assume
      "win_count_code (p@[a]) x =
        win_count_code p x + win_count_code [a] x"
    thus
      "win_count_code ((aa#p)@[a]) x =
        win_count_code (aa#p) x + win_count_code [a] x"
      by simp
  qed
  show "win_count (p@[a]) x = win_count_code (p@[a]) x"
    using pref_count_code_induct pref_count_induct
          base_case one_ballot_equiv
    by presburger
qed

fun prefer_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "prefer_count p x y =
      card {i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"

fun prefer_count_code :: "'a Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "prefer_count_code Nil x y = 0" |
  "prefer_count_code (p#ps) x y =
      (if y \<preceq>\<^sub>p x then 1 else 0) + prefer_count_code ps x y"

lemma pref_count_equiv[code]: "prefer_count p x y = prefer_count_code p x y"
proof (induction p rule: rev_induct, simp)
  case (snoc a p)
  fix
    a :: "'a Preference_Relation" and
    p :: "'a Profile"
  assume
    base_case:
    "prefer_count p x y = prefer_count_code p x y"
  have size_one: "length [a] = 1"
    by simp
  have p_pos_in_ps:
    "\<forall>i<length p. p!i = (p@[a])!i"
    by (simp add: nth_append)
  have
    "prefer_count [a] x y =
      (let q = [a] in
        card {i::nat. i < length q \<and>
              (let r = (q!i) in (y \<preceq>\<^sub>r x))})"
    by simp
  hence one_ballot_equiv:
    "prefer_count [a] x y = prefer_count_code [a] x y"
    using size_one
    by (simp add: nth_Cons')
  have pref_count_induct:
    "prefer_count (p@[a]) x y =
      prefer_count p x y + prefer_count [a] x y"
  proof (simp)
    have
      "{i. i = 0 \<and> (y, x) \<in> [a]!i} =
        (if ((y, x) \<in> a) then {0} else {})"
      by (simp add: Collect_conv_if)
    hence shift_idx_a:
      "card {i. i = length p \<and> (y, x) \<in> [a]!0} =
        card {i. i = 0 \<and> (y, x) \<in> [a]!i}"
      by simp
    have set_prof_eq:
      "{i. i < Suc (length p) \<and> (y, x) \<in> (p@[a])!i} =
        {i. i < length p \<and> (y, x) \<in> p!i} \<union>
          {i. i = length p \<and> (y, x) \<in> [a]!0}"
    proof (safe, simp_all)
      fix
        xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "xa \<noteq> length p"
      thus "(y, x) \<in> p!xa"
        using less_antisym p_pos_in_ps
        by metis
    next
      fix
        xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "(y, x) \<notin> a"
      thus "xa < length p"
        using less_antisym nth_append_length
        by metis
    next
      fix
        xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "(y, x) \<notin> a"
      thus "(y, x) \<in> p!xa"
        using less_antisym nth_append_length p_pos_in_ps
        by metis
    next
      fix
        xa :: nat
      assume
        "xa < length p" and
        "(y, x) \<in> p!xa"
      thus "(y, x) \<in> (p@[a])!xa"
        using less_antisym p_pos_in_ps
        by metis
    qed
    have f1:
      "finite {n. n < length p \<and> (y, x) \<in> p!n}"
      by simp
    have f2:
      "finite {n. n = length p \<and> (y, x) \<in> [a]!0}"
      by simp
    have
      "card ({i. i < length p \<and> (y, x) \<in> p!i} \<union>
        {i. i = length p \<and> (y, x) \<in> [a]!0}) =
          card {i. i < length p \<and> (y, x) \<in> p!i} +
            card {i. i = length p \<and> (y, x) \<in> [a]!0}"
      using f1 f2 card_Un_disjoint
      by blast
    thus
      "card {i. i < Suc (length p) \<and> (y, x) \<in> (p@[a])!i} =
        card {i. i < length p \<and> (y, x) \<in> p!i} +
          card {i. i = 0 \<and> (y, x) \<in> [a]!i}"
      using set_prof_eq shift_idx_a
      by auto
  qed
  have pref_count_code_induct:
    "prefer_count_code (p@[a]) x y =
      prefer_count_code p x y + prefer_count_code [a] x y"
  proof (simp, safe)
    assume
      assm: "(y, x) \<in> a"
    show
      "prefer_count_code (p@[a]) x y = Suc (prefer_count_code p x y)"
    proof (induction p, simp_all)
      show "(y, x) \<in> a"
        using assm
        by simp
    qed
  next
    assume
      assm: "(y, x) \<notin> a"
    show
      "prefer_count_code (p@[a]) x y = prefer_count_code p x y"
    proof (induction p, simp_all, safe)
      assume
        "(y, x) \<in> a"
      thus "False"
        using assm
        by simp
    qed
  qed
  show "prefer_count (p@[a]) x y = prefer_count_code (p@[a]) x y"
    using pref_count_code_induct pref_count_induct
          base_case one_ballot_equiv
    by presburger
qed

lemma set_compr: "{ f x | x . x \<in> S } = f ` S"
  by auto

lemma pref_count_set_compr: "{prefer_count p x y | y . y \<in> A-{x}} =
          (prefer_count p x) ` (A-{x})"
  by auto

lemma pref_count:
  assumes prof: "profile A p"
  assumes x_in_A: "x \<in> A"
  assumes y_in_A: "y \<in> A"
  assumes neq: "x \<noteq> y"
  shows "prefer_count p x y = (length p) - (prefer_count p y x)"
proof -
  have 00: "card {i::nat. i < length p} = length p"
    by simp
  have 10:
    "{i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p} -
          {i::nat. i < length p \<and> \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"
    by auto
  have 0: "\<forall> i::nat . i < length p \<longrightarrow> linear_order_on A (p!i)"
    using prof profile_def
    by metis
  hence "\<forall> i::nat . i < length p \<longrightarrow> connex A (p!i)"
    by (simp add: lin_ord_imp_connex)
  hence 1: "\<forall> i::nat . i < length p \<longrightarrow>
              \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x)) \<longrightarrow> (let r = (p!i) in (x \<preceq>\<^sub>r y))"
    using connex_def x_in_A y_in_A
    by metis
  from 0 have
    "\<forall> i::nat . i < length p \<longrightarrow> antisym  (p!i)"
    using lin_imp_antisym
    by metis
  hence "\<forall> i::nat . i < length p \<longrightarrow> ((y, x) \<in> (p!i) \<longrightarrow> (x, y) \<notin> (p!i))"
    using antisymD neq
    by metis
  hence "\<forall> i::nat . i < length p \<longrightarrow>
          ((let r = (p!i) in (y \<preceq>\<^sub>r x)) \<longrightarrow> \<not> (let r = (p!i) in (x \<preceq>\<^sub>r y)))"
    by simp
  with 1 have
    "\<forall> i::nat . i < length p \<longrightarrow>
      \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x)) = (let r = (p!i) in (x \<preceq>\<^sub>r y))"
    by metis
  hence 2:
    "{i::nat. i < length p \<and> \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}"
    by metis
  hence 20:
    "{i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p} -
          {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}"
    using "10" "2"
    by simp
  have
    "{i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))} \<subseteq>
        {i::nat. i < length p}"
    by (simp add: Collect_mono)
  hence 30:
    "card ({i::nat. i < length p} -
        {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}) =
      (card {i::nat. i < length p}) -
        card({i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    by (simp add: card_Diff_subset)
  have "prefer_count p x y =
          card {i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"
    by simp
  also have
    "... = card({i::nat. i < length p} -
            {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    using "20"
    by simp
  also have
    "... = (card {i::nat. i < length p}) -
              card({i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    using "30"
    by metis
  also have
    "... = length p - (prefer_count p y x)"
    by simp
  finally show ?thesis
    by (simp add: "20" "30")
qed

lemma pref_count_sym:
    assumes p1: "prefer_count p a x \<ge> prefer_count p x b"
    assumes prof: "profile A p"
    assumes a_in_A: "a \<in> A"
    assumes b_in_A: "b \<in> A"
    assumes x_in_A: "x \<in> A"
    assumes neq1: "a \<noteq> x"
    assumes neq2: "x \<noteq> b"
    shows "prefer_count p b x \<ge> prefer_count p x a"
proof -
  from prof a_in_A x_in_A neq1 have 0:
    "prefer_count p a x = (length p) - (prefer_count p x a)"
    using pref_count
    by metis
  moreover from prof x_in_A b_in_A neq2 have 1:
    "prefer_count p x b = (length p) - (prefer_count p b x)"
    using pref_count
    by (metis (mono_tags, lifting))
  hence 2: "(length p) - (prefer_count p x a) \<ge>
              (length p) - (prefer_count p b x)"
    using calculation p1
    by auto
  hence 3: "(prefer_count p x a) - (length p) \<le>
              (prefer_count p b x) - (length p)"
    using a_in_A diff_is_0_eq diff_le_self neq1
          pref_count prof x_in_A
    by (metis (no_types))
  hence "(prefer_count p x a) \<le> (prefer_count p b x)"
    using "1" "3" calculation p1
    by linarith
  thus ?thesis
    by linarith
qed

lemma empty_prof_imp_zero_pref_count:
  assumes "p = []"
  shows "\<forall> x y. prefer_count p x y = 0"
  using assms
  by simp

lemma empty_prof_imp_zero_pref_count_code:
  assumes "p = []"
  shows "\<forall> x y. prefer_count_code p x y = 0"
  using assms
  by simp

lemma pref_count_code_incr:
  assumes
    "prefer_count_code ps x y = n" and
    "y \<preceq>\<^sub>p x"
  shows "prefer_count_code (p#ps) x y = n+1"
  using assms
  by simp

lemma pref_count_code_not_smaller_imp_constant:
  assumes
    "prefer_count_code ps x y = n" and
    "\<not>(y \<preceq>\<^sub>p x)"
  shows "prefer_count_code (p#ps) x y = n"
  using assms
  by simp

fun wins :: "'a \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "wins x p y =
    (prefer_count p x y > prefer_count p y x)"

(* Alternative a wins against b implies that b does not win against a. *)
lemma wins_antisym:
  assumes "wins a p b"
  shows "\<not> wins b p a"
  using assms
  by simp

lemma wins_irreflex: "\<not> wins w p w"
  using wins_antisym
  by metis

subsection \<open>Condorcet Winner\<close>

fun condorcet_winner :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "condorcet_winner A p w =
      (finite_profile A p \<and>  w \<in> A \<and> (\<forall>x \<in> A - {w} . wins w p x))"

lemma cond_winner_unique:
  assumes winner_c: "condorcet_winner A p c" and
          winner_w: "condorcet_winner A p w"
  shows "w = c"
proof (rule ccontr)
  assume
    assumption: "w \<noteq> c"
  from winner_w
  have "wins w p c"
    using assumption insert_Diff insert_iff winner_c
    by simp
  hence "\<not> wins c p w"
    by (simp add: wins_antisym)
  moreover from winner_c
  have
    c_wins_against_w: "wins c p w"
    using Diff_iff assumption
          singletonD winner_w
    by simp
  ultimately show False
    by simp
qed

lemma cond_winner_unique2:
  assumes winner: "condorcet_winner A p w" and
          not_w:  "x \<noteq> w" and
          in_A:   "x \<in> A"
        shows "\<not> condorcet_winner A p x"
  using not_w cond_winner_unique winner
  by metis

lemma cond_winner_unique3:
  assumes "condorcet_winner A p w"
  shows "{a \<in> A. condorcet_winner A p a} = {w}"
proof (safe, simp_all, safe)
  fix
    x :: "'a"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    x_in_A: "x \<in> A" and
    x_wins:
      "\<forall>xa \<in> A - {x}.
        card {i. i < length p \<and> (x, xa) \<in> p!i} <
          card {i. i < length p \<and> (xa, x) \<in> p!i}"
  from assms have assm:
    "finite_profile A p \<and>  w \<in> A \<and>
      (\<forall>x \<in> A - {w}.
        card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
          card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  hence
    "(\<forall>x \<in> A - {w}.
      card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
        card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  hence w_beats_x:
    "x \<noteq> w \<Longrightarrow>
      card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
        card {i::nat. i < length p \<and> (x, w) \<in> p!i}"
    using x_in_A
    by simp
  also from assm have
    "finite_profile A p"
    by simp
  moreover from assm have
    "w \<in> A"
    by simp
  hence x_beats_w:
    "x \<noteq> w \<Longrightarrow>
      card {i. i < length p \<and> (x, w) \<in> p!i} <
        card {i. i < length p \<and> (w, x) \<in> p!i}"
    using x_wins
    by simp
  from w_beats_x x_beats_w show
    "x = w"
    by linarith
next
  fix
    x :: "'a"
  from assms show "w \<in> A"
    by simp
next
  fix
    x :: "'a"
  from assms show "finite A"
    by simp
next
  fix
    x :: "'a"
  from assms show "profile A p"
    by simp
next
  fix
    x :: "'a"
  from assms show "w \<in> A"
    by simp
next
  fix
    x :: "'a" and
    xa :: "'a"
  assume
    xa_in_A: "xa \<in> A" and
    w_wins:
      "\<not> card {i. i < length p \<and> (w, xa) \<in> p!i} <
        card {i. i < length p \<and> (xa, w) \<in> p!i}"
  from assms have
    "finite_profile A p \<and>  w \<in> A \<and>
      (\<forall>x \<in> A - {w} .
        card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
          card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  thus "xa = w"
    using xa_in_A w_wins insert_Diff insert_iff
    by (metis (no_types, lifting))
qed

subsection \<open>Limited Profile\<close>

(*
   This function restricts a profile p to a set A and
   keeps all of A's preferences.
*)
fun limit_profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile" where
  "limit_profile A p = map (limit A) p"

lemma limit_prof_trans:
  assumes
    "B \<subseteq> A" and
    "C \<subseteq> B" and
    "finite_profile A p"
  shows "limit_profile C p = limit_profile C (limit_profile B p)"
  using assms
  by auto

lemma limit_profile_sound:
  assumes
    profile: "finite_profile S p" and
    subset: "A \<subseteq> S"
  shows "finite_profile A (limit_profile A p)"
proof (simp)
  from profile
  show "finite_profile A (map (limit A) p)"
    using length_map limit_presv_lin_ord nth_map
          profile_def subset infinite_super
    by metis
qed

lemma limit_prof_presv_size:
  assumes f_prof: "finite_profile S p" and
          subset:  "A \<subseteq> S"
  shows "length p = length (limit_profile A p)"
  by simp

subsection \<open>Lifting Property\<close>

definition equiv_prof_except_a :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile \<Rightarrow>
                                        'a \<Rightarrow> bool" where
  "equiv_prof_except_a A p q a \<equiv>
    finite_profile A p \<and> finite_profile A q \<and>
      a \<in> A \<and> length p = length q \<and>
      (\<forall>i::nat.
        i < length p \<longrightarrow>
          equiv_rel_except_a A (p!i) (q!i) a)"

(*
   An alternative gets lifted from one profile to another iff
   its ranking increases in at least one ballot, and nothing else changes.
*)
definition lifted :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "lifted A p q a \<equiv>
    finite_profile A p \<and> finite_profile A q \<and>
      a \<in> A \<and> length p = length q \<and>
      (\<forall>i::nat.
        (i < length p \<and> \<not>Preference_Relation.lifted A (p!i) (q!i) a) \<longrightarrow>
          (p!i) = (q!i)) \<and>
      (\<exists>i::nat. i < length p \<and> Preference_Relation.lifted A (p!i) (q!i) a)"

lemma lifted_imp_equiv_prof_except_a:
  assumes lifted: "lifted A p q a"
  shows "equiv_prof_except_a A p q a"
proof -
  have
    "\<forall>i::nat. i < length p \<longrightarrow>
      equiv_rel_except_a A (p!i) (q!i) a"
  proof
    fix i :: nat
    show
      "i < length p \<longrightarrow>
        equiv_rel_except_a A (p!i) (q!i) a"
    proof
      assume i_ok: "i < length p"
      show "equiv_rel_except_a A (p!i) (q!i) a"
        using lifted_def i_ok lifted profile_def trivial_equiv_rel
              lifted_imp_equiv_rel_except_a
        by metis
    qed
  qed
  thus ?thesis
    using lifted_def lifted equiv_prof_except_a_def
    by metis
qed

lemma negl_diff_imp_eq_limit_prof:
  assumes
    change: "equiv_prof_except_a S p q a" and
    subset: "A \<subseteq> S" and
    notInA: "a \<notin> A"
  shows "limit_profile A p = limit_profile A q"
proof -
  have
    "\<forall>i::nat. i < length p \<longrightarrow>
      equiv_rel_except_a S (p!i) (q!i) a"
    using change equiv_prof_except_a_def
    by metis
  hence "\<forall>i::nat. i < length p \<longrightarrow> limit A (p!i) = limit A (q!i)"
    using notInA negl_diff_imp_eq_limit subset
    by metis
  hence "map (limit A) p = map (limit A) q"
    using change equiv_prof_except_a_def
          length_map nth_equalityI nth_map
    by (metis (mono_tags, lifting))
  thus ?thesis
    by simp
qed

lemma limit_prof_eq_or_lifted:
  assumes
    lifted: "lifted S p q a" and
    subset: "A \<subseteq> S"
  shows
    "limit_profile A p = limit_profile A q \<or>
        lifted A (limit_profile A p) (limit_profile A q) a"
proof cases
  assume inA: "a \<in> A"
  have
    "\<forall>i::nat. i < length p \<longrightarrow>
        (Preference_Relation.lifted S (p!i) (q!i) a \<or> (p!i) = (q!i))"
    using lifted_def lifted
    by metis
  hence one:
    "\<forall>i::nat. i < length p \<longrightarrow>
         (Preference_Relation.lifted A (limit A (p!i)) (limit A (q!i)) a \<or>
           (limit A (p!i)) = (limit A (q!i)))"
    using limit_lifted_imp_eq_or_lifted subset
    by metis
  thus ?thesis
  proof cases
    assume "\<forall>i::nat. i < length p \<longrightarrow> (limit A (p!i)) = (limit A (q!i))"
    thus ?thesis
      using lifted_def length_map lifted
            limit_profile.simps nth_equalityI nth_map
      by (metis (mono_tags, lifting))
  next
    assume assm:
      "\<not>(\<forall>i::nat. i < length p \<longrightarrow> (limit A (p!i)) = (limit A (q!i)))"
    let ?p = "limit_profile A p"
    let ?q = "limit_profile A q"
    have "profile A ?p \<and> profile A ?q"
      using lifted_def lifted limit_profile_sound subset
      by metis
    moreover have "length ?p = length ?q"
      using lifted_def lifted
      by fastforce
    moreover have
      "\<exists>i::nat. i < length ?p \<and> Preference_Relation.lifted A (?p!i) (?q!i) a"
      using assm lifted_def length_map lifted
            limit_profile.simps nth_map one
      by (metis (no_types, lifting))
    moreover have
      "\<forall>i::nat.
        (i < length ?p \<and> \<not>Preference_Relation.lifted A (?p!i) (?q!i) a) \<longrightarrow>
          (?p!i) = (?q!i)"
      using lifted_def length_map lifted
            limit_profile.simps nth_map one
      by metis
    ultimately have "lifted A ?p ?q a"
      using lifted_def inA lifted rev_finite_subset subset
      by (metis (no_types, lifting))
    thus ?thesis
      by simp
  qed
next
  assume "a \<notin> A"
  thus ?thesis
    using lifted negl_diff_imp_eq_limit_prof subset
          lifted_imp_equiv_prof_except_a
    by metis
qed

end


theory Dom_Merge
  imports "../Dominant" "../../Lifter/Lifter_Instances"
begin

locale dominant2_merge_lr_sig =
  fixes l1 :: "('a1, 'b1, 'c :: Pord) lifting"
  fixes t1 :: "'a \<Rightarrow> 'a1"
  fixes S :: "'a1 \<Rightarrow> 'c set"
  fixes l2 :: "('a2, 'b2, 'c :: Pord) lifting"
  fixes t2 :: "'a \<Rightarrow> 'a2"
  fixes X :: "'a set"
  fixes l_other :: "('a1, 'b3, 'c :: Pord) lifting"
  fixes S_other :: "'a1 \<Rightarrow> 'c set"

locale dominant2_merge_left =
  dominant2_merge_lr_sig +
  dominant2 +
  V_other : lifting_valid l_other S_other +
  Orth : l_ortho l1 S l_other S_other

sublocale dominant2_merge_left \<subseteq> out :
  dominant2 "merge_l l1 l_other" t1 "l2" t2 X
proof

  fix a1_3 :: "('b * 'g)"
  fix a2
  fix b :: "'c"
  fix x
  assume Xin : "x \<in> X"
  (*assume Bin : "b \<in> S x \<inter> S_other x"

  then have Bin1 : "b \<in> S x" and Bin3 : "b \<in> S_other x"
    by auto
*)

  obtain a1 a3 where A1_3 : "a1_3 = (a1, a3)"
    by(cases a1_3; auto)

  have 1 : "LUpd l2 (t2 x) a2 b <[ LUpd l1 (t1 x) a1 b"
    using dominant_leq[OF Xin]
    by auto

  have 2: "LUpd l1 (t1 x) a1 b <[ LUpd l_other (t1 x) a3 (LUpd l1 (t1 x) a1 b)"
    using V_other.get_put
    by auto

  have 3 : "LUpd l_other (t1 x) a3 (LUpd l1 (t1 x) a1 b) = LUpd l1 (t1 x) a1 (LUpd l_other (t1 x) a3 b)"
    using Orth.compat
    by simp

  show " LUpd l2 (t2 x) a2 b <[ LUpd (merge_l l1 l_other) (t1 x) a1_3 b"
    using leq_trans[OF 1 2] 3 A1_3
    by(auto simp add: merge_l_def leq_refl)
qed

lemma (in dominant2_merge_left) ax :
  shows "dominant2 (merge_l l1 l_other) t1 l2 t2 X"
  using out.dominant2_axioms
  by auto

locale dominant2_merge_right =
  dominant2_merge_lr_sig +
  dominant2 +
  V_other : lifting_valid l_other S_other +
  Orth : l_ortho l1 S l_other S_other

sublocale dominant2_merge_right \<subseteq> out : dominant2 "merge_l l_other l1" t1 "l2" t2 X
proof

  fix a3_1 :: "('g * 'b)"
  fix a2
  fix b :: "'c"
  fix x
  assume Xin : "x \<in> X"

  obtain a1 a3 where A3_1 : "a3_1 = (a3, a1)"
    by(cases a3_1; auto)

  have 1 : "LUpd l2 (t2 x) a2 b <[ LUpd l1 (t1 x) a1 b"
    using dominant_leq[OF Xin]
    by auto

  have 2: "LUpd l1 (t1 x) a1 b <[ LUpd l_other (t1 x) a3 (LUpd l1 (t1 x) a1 b)"
    using V_other.get_put
    by auto

  show "LUpd l2 (t2 x) a2 b <[ LUpd (merge_l l_other l1) (t1 x) a3_1 b"
    using leq_trans[OF 1 2] A3_1
    by(simp add: merge_l_def)
qed

lemma (in dominant2_merge_right) ax :
  shows "dominant2 (merge_l l_other l1) t1 l2 t2 X"
  using out.dominant2_axioms
  by auto

(* this third one does not actually hold in general
 * however, perhaps in a the specific cases we need it will work.
 *)
(*
locale dominant2_merge_both_sig =
  fixes l1 :: "('a, 'b1, 'c :: Pord) lifting"
  fixes l2 :: "('a, 'b2, 'c :: Pord) lifting"
  fixes l3 :: "('a, 'b3, 'c :: Pord) lifting"
  fixes S3 :: "'a \<Rightarrow> 'c set"
  fixes X :: "'a set"
  fixes l_other :: "('a, 'b3, 'c :: Pord) lifting"
  fixes S_other :: "'a \<Rightarrow> 'c set"

locale dominant2_merge_both =
  dominant2_merge_both_sig +
  dom3_1 : dominant2 "l3" "l1" "S3" "X" +
  dom3_2 : dominant2 "l3" "l2" "S3" "X"

sublocale dominant2_merge_both \<subseteq> dominant2 "l3" "merge_l l1 l2" S3 X
proof
  fix a1_2 :: "'b * 'd"
  fix a3
  fix b :: 'c
  fix x

  assume Xin : "x \<in> X"
  assume Bin : "b \<in> S3 x"

  obtain a1 a2 where A1_2 : "a1_2 = (a1, a2)"
    by(cases a1_2; auto)

  show "LUpd (merge_l l1 l2) x a1_2 b <[ LUpd l3 x a3 b"
    using A1_2
    apply(simp add: merge_l_def)
    term "a1_2"
*)
end


section \<open>Combining independent secret sources\<close>

text \<open>This theory formalizes the discussion about considering
combined sources of secrets from \<^cite>\<open>\<open>Appendix E\<close> in "cosmedis-SandP2017"\<close>.
\<close>

theory Independent_Secrets
imports Bounded_Deducibility_Security.BD_Security_TS
begin

locale Abstract_BD_Security_Two_Secrets =
  One: Abstract_BD_Security validSystemTrace V1 O1 B1 TT1
+ Two: Abstract_BD_Security validSystemTrace V2 O2 B2 TT2
for
  validSystemTrace :: "'traces \<Rightarrow> bool"
and
  V1 :: "'traces \<Rightarrow> 'values1"
and
  O1 :: "'traces \<Rightarrow> 'observations1"
and (* declassification bound: *)
  B1 :: "'values1 \<Rightarrow> 'values1 \<Rightarrow> bool"
and (* declassification trigger: *)
  TT1 :: "'traces \<Rightarrow> bool"
and
  V2 :: "'traces \<Rightarrow> 'values2"
and
  O2 :: "'traces \<Rightarrow> 'observations2"
and (* declassification bound: *)
  B2 :: "'values2 \<Rightarrow> 'values2 \<Rightarrow> bool"
and (* declassification trigger: *)
  TT2 :: "'traces \<Rightarrow> bool"
+
fixes
  O :: "'traces \<Rightarrow> 'observations"
assumes
  O1_O: "O1 tr = O1 tr' \<Longrightarrow> validSystemTrace tr \<Longrightarrow> validSystemTrace tr' \<Longrightarrow> O tr = O tr'"
and
  O2_O: "O2 tr = O2 tr' \<Longrightarrow> validSystemTrace tr \<Longrightarrow> validSystemTrace tr' \<Longrightarrow> O tr = O tr'"
and
  O1_V2: "O1 tr = O1 tr' \<Longrightarrow> validSystemTrace tr \<Longrightarrow> validSystemTrace tr' \<Longrightarrow> B1 (V1 tr) (V1 tr') \<Longrightarrow> V2 tr = V2 tr'"
and
  O2_V1: "O2 tr = O2 tr' \<Longrightarrow> validSystemTrace tr \<Longrightarrow> validSystemTrace tr' \<Longrightarrow> B2 (V2 tr) (V2 tr') \<Longrightarrow> V1 tr = V1 tr'"
and
  O1_TT2: "O1 tr = O1 tr' \<Longrightarrow> validSystemTrace tr \<Longrightarrow> validSystemTrace tr' \<Longrightarrow> B1 (V1 tr) (V1 tr') \<Longrightarrow> TT2 tr = TT2 tr'"
begin

definition "V tr = (V1 tr, V2 tr)"
definition "B vl vl' = (B1 (fst vl) (fst vl') \<and> B2 (snd vl) (snd vl'))"
definition "TT tr = (TT1 tr \<and> TT2 tr)"

sublocale Abstract_BD_Security validSystemTrace V O B TT .

theorem two_secure:
assumes "One.secure" and "Two.secure"
shows "secure"
unfolding secure_def
proof (intro allI impI, elim conjE)
  fix tr vl vl'
  assume tr: "validSystemTrace tr" and TT: "TT tr" and B: "B vl vl'" and V_tr: "V tr = vl"
  then obtain vl1' vl2' where vl: "vl = (V1 tr, V2 tr)" and vl': "vl' = (vl1', vl2')"
    by (cases vl, cases vl') (auto simp: V_def)
  obtain tr' where tr': "validSystemTrace tr'" and O1: "O1 tr' = O1 tr" and V1: "V1 tr' = vl1'"
    using assms(1) tr TT B by (auto elim: One.secureE simp: TT_def B_def V_def vl vl')
  then have O': "O tr' = O tr" and V2': "V2 tr = V2 tr'" and TT2': "TT2 tr = TT2 tr'"
    using B tr V1 by (auto intro: O1_O O1_V2 simp: O1_TT2 B_def vl vl')
  obtain tr'' where tr'': "validSystemTrace tr''" and O2: "O2 tr'' = O2 tr'" and V2: "V2 tr'' = vl2'"
    using assms(2) tr' TT2' TT B V2'
    by (elim Two.secureE[of tr' vl2']) (auto simp: TT_def B_def vl vl')
  moreover then have "O tr'' = O tr'" and "V1 tr' = V1 tr''"
    using B tr' V2 by (auto intro: O2_O O2_V1 simp: B_def V2' vl vl')
  ultimately show "\<exists>tr1. validSystemTrace tr1 \<and> O tr1 = O tr \<and> V tr1 = vl'"
    unfolding V_def V1 vl' O' by auto
qed

end

locale BD_Security_TS_Two_Secrets =
  One: BD_Security_TS istate validTrans srcOf tgtOf \<phi>1 f1 \<gamma>1 g1 T1 B1
+ Two: BD_Security_TS istate validTrans srcOf tgtOf \<phi>2 f2 \<gamma>2 g2 T2 B2
for istate :: 'state and validTrans :: "'trans \<Rightarrow> bool"
and srcOf :: "'trans \<Rightarrow> 'state" and tgtOf :: "'trans \<Rightarrow> 'state"
and \<phi>1 :: "'trans \<Rightarrow> bool" and f1 :: "'trans \<Rightarrow> 'val1"
and \<gamma>1 :: "'trans \<Rightarrow> bool" and g1 :: "'trans \<Rightarrow> 'obs1"
and T1 :: "'trans \<Rightarrow> bool" and B1 :: "'val1 list \<Rightarrow> 'val1 list \<Rightarrow> bool"
and \<phi>2 :: "'trans \<Rightarrow> bool" and f2 :: "'trans \<Rightarrow> 'val2"
and \<gamma>2 :: "'trans \<Rightarrow> bool" and g2 :: "'trans \<Rightarrow> 'obs2"
and T2 :: "'trans \<Rightarrow> bool" and B2 :: "'val2 list \<Rightarrow> 'val2 list \<Rightarrow> bool"
+
fixes \<gamma> :: "'trans \<Rightarrow> bool" and g :: "'trans \<Rightarrow> 'obs"
assumes \<gamma>_\<gamma>12: "\<And>tr trn. One.validFrom istate (tr ## trn) \<Longrightarrow> \<gamma> trn \<Longrightarrow> \<gamma>1 trn \<and> \<gamma>2 trn"
and O1_\<gamma>: "\<And>tr tr' trn trn'. One.O tr = One.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>1 trn \<Longrightarrow> \<gamma>1 trn' \<Longrightarrow> g1 trn = g1 trn' \<Longrightarrow> \<gamma> trn = \<gamma> trn'"
and O1_g: "\<And>tr tr' trn trn'. One.O tr = One.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>1 trn \<Longrightarrow> \<gamma>1 trn' \<Longrightarrow> g1 trn = g1 trn' \<Longrightarrow> \<gamma> trn \<Longrightarrow> \<gamma> trn' \<Longrightarrow> g trn = g trn'"
and O2_\<gamma>: "\<And>tr tr' trn trn'. Two.O tr = Two.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>2 trn \<Longrightarrow> \<gamma>2 trn' \<Longrightarrow> g2 trn = g2 trn' \<Longrightarrow> \<gamma> trn = \<gamma> trn'"
and O2_g: "\<And>tr tr' trn trn'. Two.O tr = Two.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>2 trn \<Longrightarrow> \<gamma>2 trn' \<Longrightarrow> g2 trn = g2 trn' \<Longrightarrow> \<gamma> trn \<Longrightarrow> \<gamma> trn' \<Longrightarrow> g trn = g trn'"
and \<phi>2_\<gamma>1: "\<And>tr trn. One.validFrom istate (tr ## trn) \<Longrightarrow> \<phi>2 trn \<Longrightarrow> \<gamma>1 trn"
and \<gamma>1_\<phi>2: "\<And>tr tr' trn trn'. One.O tr = One.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>1 trn \<Longrightarrow> \<gamma>1 trn' \<Longrightarrow> g1 trn = g1 trn' \<Longrightarrow> \<phi>2 trn = \<phi>2 trn'"
and g1_f2: "\<And>tr tr' trn trn'. One.O tr = One.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>1 trn \<Longrightarrow> \<gamma>1 trn' \<Longrightarrow> g1 trn = g1 trn' \<Longrightarrow> \<phi>2 trn \<Longrightarrow> \<phi>2 trn' \<Longrightarrow> f2 trn = f2 trn'"
and \<phi>1_\<gamma>2: "\<And>tr trn. One.validFrom istate (tr ## trn) \<Longrightarrow> \<phi>1 trn \<Longrightarrow> \<gamma>2 trn"
and \<gamma>2_\<phi>1: "\<And>tr tr' trn trn'. Two.O tr = Two.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>2 trn \<Longrightarrow> \<gamma>2 trn' \<Longrightarrow> g2 trn = g2 trn' \<Longrightarrow> \<phi>1 trn = \<phi>1 trn'"
and g2_f1: "\<And>tr tr' trn trn'. Two.O tr = Two.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>2 trn \<Longrightarrow> \<gamma>2 trn' \<Longrightarrow> g2 trn = g2 trn' \<Longrightarrow> \<phi>1 trn \<Longrightarrow> \<phi>1 trn' \<Longrightarrow> f1 trn = f1 trn'"
and T2_\<gamma>1: "\<And>tr trn. One.validFrom istate (tr ## trn) \<Longrightarrow> never T2 tr \<Longrightarrow> T2 trn \<Longrightarrow> \<gamma>1 trn"
and \<gamma>1_T2: "\<And>tr tr' trn trn'. One.O tr = One.O tr' \<Longrightarrow> One.validFrom istate (tr ## trn) \<Longrightarrow> One.validFrom istate (tr' ## trn') \<Longrightarrow> \<gamma>1 trn \<Longrightarrow> \<gamma>1 trn' \<Longrightarrow> g1 trn = g1 trn' \<Longrightarrow> T2 trn = T2 trn'"
begin

definition "O tr = map g (filter \<gamma> tr)"

lemma O_Nil_never: "O tr = [] \<longleftrightarrow> never \<gamma> tr" unfolding O_def by (induction tr) auto
lemma Nil_O_never: "[] = O tr \<longleftrightarrow> never \<gamma> tr" unfolding O_def by (induction tr) auto
lemma O_append: "O (tr @ tr') = O tr @ O tr'" unfolding O_def by auto

lemma never_\<gamma>12_never_\<gamma>: "One.validFrom istate (tr @ tr') \<Longrightarrow> never \<gamma>1 tr' \<or> never \<gamma>2 tr' \<Longrightarrow> never \<gamma> tr'"
proof (induction tr' rule: rev_induct)
  case (snoc trn tr')
  then show ?case using \<gamma>_\<gamma>12[of "tr @ tr'" trn] by (auto simp: One.validFrom_append)
qed auto

lemma never_\<gamma>1_never_\<phi>2: "One.validFrom istate (tr @ tr') \<Longrightarrow> never \<gamma>1 tr' \<Longrightarrow> never \<phi>2 tr'"
proof (induction tr' rule: rev_induct)
  case (snoc trn tr')
  then show ?case using \<phi>2_\<gamma>1[of "tr @ tr'" trn] by (auto simp: One.validFrom_append)
qed auto

lemma never_\<gamma>2_never_\<phi>1: "One.validFrom istate (tr @ tr') \<Longrightarrow> never \<gamma>2 tr' \<Longrightarrow> never \<phi>1 tr'"
proof (induction tr' rule: rev_induct)
  case (snoc trn tr')
  then show ?case using \<phi>1_\<gamma>2[of "tr @ tr'" trn] by (auto simp: One.validFrom_append)
qed auto

lemma never_\<gamma>1_never_T2: "One.validFrom istate (tr @ tr') \<Longrightarrow> never T2 tr \<Longrightarrow> never \<gamma>1 tr' \<Longrightarrow> never T2 tr'"
proof (induction tr' rule: rev_induct)
  case (snoc trn tr')
  then show ?case using T2_\<gamma>1[of "tr @ tr'" trn] by (auto simp: One.validFrom_append)
qed auto

sublocale Abstract_BD_Security_Two_Secrets "One.validFrom istate" One.V One.O B1 "never T1" Two.V Two.O B2 "never T2" O
proof
  fix tr tr'
  assume "One.O tr = One.O tr'" "One.validFrom istate tr" "One.validFrom istate tr'"
  then show "O tr = O tr'"
  proof (induction "One.O tr" arbitrary: tr tr' rule: rev_induct)
    case (Nil tr tr')
    then have tr: "O tr = []" using never_\<gamma>12_never_\<gamma>[of "[]" tr] by (auto simp: O_Nil_never One.O_Nil_never)
    show "O tr = O tr'" using Nil never_\<gamma>12_never_\<gamma>[of "[]" tr'] by (auto simp: tr Nil_O_never One.Nil_O_never)
  next
    case (snoc obs obsl tr tr')
    obtain tr1 trn tr2 where tr: "tr = tr1 @ [trn] @ tr2" and trn: "\<gamma>1 trn" "g1 trn = obs"
                         and tr1: "One.O tr1 = obsl" and tr2: "never \<gamma>1 tr2"
      using snoc(2) One.O_eq_RCons[of tr obsl obs] by auto
    obtain tr1' trn' tr2' where tr': "tr' = tr1' @ [trn'] @ tr2'" and trn': "\<gamma>1 trn'" "g1 trn' = obs"
                          and tr1': "One.O tr1' = obsl" and tr2': "never \<gamma>1 tr2'"
      using snoc(2,3) One.O_eq_RCons[of tr' obsl obs] by auto
    have "O tr1 = O tr1'" using snoc(1)[of tr1 tr1'] tr1 tr1' snoc(4,5) unfolding tr tr'
      by (auto simp: One.validFrom_append)
    moreover have "O [trn] = O [trn']" using O1_\<gamma>[of tr1 tr1' trn trn'] O1_g[of tr1 tr1' trn trn']
      using snoc(4,5) tr1 tr1' trn trn' by (auto simp: tr tr' O_def One.validFrom_append One.validFrom_Cons)
    moreover have "O tr2 = []" and "O tr2' = []" using tr2 tr2'
      using never_\<gamma>12_never_\<gamma>[of "tr1 ## trn" tr2] never_\<gamma>12_never_\<gamma>[of "tr1' ## trn'" tr2']
      using snoc(4,5) unfolding tr tr' by (auto simp: O_Nil_never)
    ultimately show "O tr = O tr'" unfolding tr tr' O_append by auto
  qed
next
  fix tr tr'
  assume "Two.O tr = Two.O tr'" "One.validFrom istate tr" "One.validFrom istate tr'"
  then show "O tr = O tr'"
  proof (induction "Two.O tr" arbitrary: tr tr' rule: rev_induct)
    case (Nil tr tr')
    then have tr: "O tr = []" using never_\<gamma>12_never_\<gamma>[of "[]" tr] by (auto simp: O_Nil_never Two.O_Nil_never)
    show "O tr = O tr'" using Nil never_\<gamma>12_never_\<gamma>[of "[]" tr'] by (auto simp: tr Nil_O_never Two.Nil_O_never)
  next
    case (snoc obs obsl tr tr')
    obtain tr1 trn tr2 where tr: "tr = tr1 @ [trn] @ tr2" and trn: "\<gamma>2 trn" "g2 trn = obs"
                         and tr1: "Two.O tr1 = obsl" and tr2: "never \<gamma>2 tr2"
      using snoc(2) Two.O_eq_RCons[of tr obsl obs] by auto
    obtain tr1' trn' tr2' where tr': "tr' = tr1' @ [trn'] @ tr2'" and trn': "\<gamma>2 trn'" "g2 trn' = obs"
                          and tr1': "Two.O tr1' = obsl" and tr2': "never \<gamma>2 tr2'"
      using snoc(2,3) Two.O_eq_RCons[of tr' obsl obs] by auto
    have "O tr1 = O tr1'" using snoc(1)[of tr1 tr1'] tr1 tr1' snoc(4,5) unfolding tr tr'
      by (auto simp: One.validFrom_append)
    moreover have "O [trn] = O [trn']" using O2_\<gamma>[of tr1 tr1' trn trn'] O2_g[of tr1 tr1' trn trn']
      using snoc(4,5) tr1 tr1' trn trn' by (auto simp: tr tr' O_def One.validFrom_append One.validFrom_Cons)
    moreover have "O tr2 = []" and "O tr2' = []" using tr2 tr2'
      using never_\<gamma>12_never_\<gamma>[of "tr1 ## trn" tr2] never_\<gamma>12_never_\<gamma>[of "tr1' ## trn'" tr2']
      using snoc(4,5) unfolding tr tr' by (auto simp: O_Nil_never)
    ultimately show "O tr = O tr'" unfolding tr tr' O_append by auto
  qed
next
  fix tr tr'
  assume "One.O tr = One.O tr'" "One.validFrom istate tr" "One.validFrom istate tr'"
  then show "Two.V tr = Two.V tr'"
  proof (induction "One.O tr" arbitrary: tr tr' rule: rev_induct)
    case (Nil tr tr')
    then have tr: "Two.V tr = []" using never_\<gamma>1_never_\<phi>2[of "[]" tr]
      unfolding Two.V_Nil_never One.Nil_O_never by auto
    show "Two.V tr = Two.V tr'" using never_\<gamma>1_never_\<phi>2[of "[]" tr'] using Nil
      unfolding tr Two.Nil_V_never One.O_Nil_never[symmetric] by auto
  next
    case (snoc obs obsl tr tr')
    obtain tr1 trn tr2 where tr: "tr = tr1 @ [trn] @ tr2" and trn: "\<gamma>1 trn" "g1 trn = obs"
                         and tr1: "One.O tr1 = obsl" and tr2: "never \<gamma>1 tr2"
      using snoc(2) One.O_eq_RCons[of tr obsl obs] by auto
    obtain tr1' trn' tr2' where tr': "tr' = tr1' @ [trn'] @ tr2'" and trn': "\<gamma>1 trn'" "g1 trn' = obs"
                          and tr1': "One.O tr1' = obsl" and tr2': "never \<gamma>1 tr2'"
      using snoc(2,3) One.O_eq_RCons[of tr' obsl obs] by auto
    have "Two.V tr1 = Two.V tr1'" using snoc(1)[of tr1 tr1'] tr1 tr1' snoc(4,5) unfolding tr tr'
      by (auto simp: One.validFrom_append)
    moreover have "Two.V [trn] = Two.V [trn']" using \<gamma>1_\<phi>2[of tr1 tr1' trn trn'] g1_f2[of tr1 tr1' trn trn']
      using snoc(4,5) tr1 tr1' trn trn' unfolding tr tr' Two.V_map_filter
      by (auto simp: One.validFrom_append One.validFrom_Cons)
    moreover have "Two.V tr2 = []" and "Two.V tr2' = []" using tr2 tr2'
      using never_\<gamma>1_never_\<phi>2[of "tr1 ## trn" tr2] never_\<gamma>1_never_\<phi>2[of "tr1' ## trn'" tr2']
      using snoc(4,5) unfolding tr tr' by (auto simp: Two.V_Nil_never)
    ultimately show "Two.V tr = Two.V tr'" unfolding tr tr' Two.V_append by auto
  qed
next
  fix tr tr'
  assume "Two.O tr = Two.O tr'" "One.validFrom istate tr" "One.validFrom istate tr'"
  then show "One.V tr = One.V tr'"
  proof (induction "Two.O tr" arbitrary: tr tr' rule: rev_induct)
    case (Nil tr tr')
    then have tr: "One.V tr = []" using never_\<gamma>2_never_\<phi>1[of "[]" tr]
      unfolding One.V_Nil_never Two.Nil_O_never by auto
    show "One.V tr = One.V tr'" using never_\<gamma>2_never_\<phi>1[of "[]" tr'] using Nil
      unfolding tr One.Nil_V_never Two.O_Nil_never[symmetric] by auto
  next
    case (snoc obs obsl tr tr')
    obtain tr1 trn tr2 where tr: "tr = tr1 @ [trn] @ tr2" and trn: "\<gamma>2 trn" "g2 trn = obs"
                         and tr1: "Two.O tr1 = obsl" and tr2: "never \<gamma>2 tr2"
      using snoc(2) Two.O_eq_RCons[of tr obsl obs] by auto
    obtain tr1' trn' tr2' where tr': "tr' = tr1' @ [trn'] @ tr2'" and trn': "\<gamma>2 trn'" "g2 trn' = obs"
                          and tr1': "Two.O tr1' = obsl" and tr2': "never \<gamma>2 tr2'"
      using snoc(2,3) Two.O_eq_RCons[of tr' obsl obs] by auto
    have "One.V tr1 = One.V tr1'" using snoc(1)[of tr1 tr1'] tr1 tr1' snoc(4,5) unfolding tr tr'
      by (auto simp: One.validFrom_append)
    moreover have "One.V [trn] = One.V [trn']" using \<gamma>2_\<phi>1[of tr1 tr1' trn trn'] g2_f1[of tr1 tr1' trn trn']
      using snoc(4,5) tr1 tr1' trn trn' unfolding tr tr' Two.V_map_filter
      by (auto simp: One.validFrom_append One.validFrom_Cons)
    moreover have "One.V tr2 = []" and "One.V tr2' = []" using tr2 tr2'
      using never_\<gamma>2_never_\<phi>1[of "tr1 ## trn" tr2] never_\<gamma>2_never_\<phi>1[of "tr1' ## trn'" tr2']
      using snoc(4,5) unfolding tr tr' by (auto simp: One.V_Nil_never)
    ultimately show "One.V tr = One.V tr'" unfolding tr tr' One.V_append by auto
  qed
next
  fix tr tr'
  assume "One.O tr = One.O tr'" "One.validFrom istate tr" "One.validFrom istate tr'"
  then show "never T2 tr = never T2 tr'"
  proof (induction "One.O tr" arbitrary: tr tr' rule: rev_induct)
    case (Nil tr tr')
    then have tr: "never T2 tr" using never_\<gamma>1_never_T2[of "[]" tr]
      unfolding Two.V_Nil_never One.Nil_O_never by auto
    then show "never T2 tr = never T2 tr'" using never_\<gamma>1_never_T2[of "[]" tr'] using Nil
      unfolding tr Two.Nil_V_never One.O_Nil_never[symmetric] by auto
  next
    case (snoc obs obsl tr tr')
    obtain tr1 trn tr2 where tr: "tr = tr1 @ [trn] @ tr2" and trn: "\<gamma>1 trn" "g1 trn = obs"
                         and tr1: "One.O tr1 = obsl" and tr2: "never \<gamma>1 tr2"
      using snoc(2) One.O_eq_RCons[of tr obsl obs] by auto
    obtain tr1' trn' tr2' where tr': "tr' = tr1' @ [trn'] @ tr2'" and trn': "\<gamma>1 trn'" "g1 trn' = obs"
                          and tr1': "One.O tr1' = obsl" and tr2': "never \<gamma>1 tr2'"
      using snoc(2,3) One.O_eq_RCons[of tr' obsl obs] by auto
    have "never T2 tr1 = never T2 tr1'" using snoc(1)[of tr1 tr1'] tr1 tr1' snoc(4,5) unfolding tr tr'
      by (auto simp: One.validFrom_append)
    moreover have "T2 trn = T2 trn'" using \<gamma>1_T2[of tr1 tr1' trn trn']
      using snoc(4,5) tr1 tr1' trn trn' unfolding tr tr' Two.V_map_filter
      by (auto simp: One.validFrom_append One.validFrom_Cons)
    moreover have "never T2 (tr1 ## trn) \<longrightarrow> never T2 tr2"
              and "never T2 (tr1' ## trn') \<longrightarrow> never T2 tr2'"
      using never_\<gamma>1_never_T2[of "tr1 ## trn" tr2] never_\<gamma>1_never_T2[of "tr1' ## trn'" tr2']
      using tr2 tr2' snoc(4,5) unfolding tr tr' by (auto simp: Two.V_Nil_never)
    ultimately show "never T2 tr = never T2 tr'" unfolding tr tr' by auto
  qed
qed

end

end