theory Binary_Operations_Nat
  imports Binary_Operations Primitives Binary_Arithmetic_Nat
          IMP_Minus_To_IMP_Minus_Minus_State_Translations_nat
          IMP_Minus_Max_Constant_Nat
begin

fun com_list_to_seq_nat:: "nat \<Rightarrow> nat" where
  "com_list_to_seq_nat n =
    (if n = 0
     then 0 ## 0
     else 2 ## ((hd_nat n) ## ((com_list_to_seq_nat (tl_nat n)) ## 0))
    )"

fun com_list_to_seq_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "com_list_to_seq_acc acc n =
    (if n = 0
     then acc
     else com_list_to_seq_acc (2 ## ((hd_nat n) ## (acc ## 0))) (tl_nat n)
    )"

lemma com_list_to_seq_induct:
  "com_list_to_seq_nat (append_nat (reverse_nat ys) xs) =
    com_list_to_seq_acc  (com_list_to_seq_nat xs) ys"
  apply(induct ys arbitrary:xs rule: length_nat.induct)
   apply (auto simp only: reverse_nat_0 append_nat.simps)
   apply(subst com_list_to_seq_acc.simps)
   apply(auto simp del:com_list_to_seq_acc.simps com_list_to_seq_nat.simps
      simp add: append_rev_nat)
  apply(subst (2) com_list_to_seq_acc.simps)
  apply(auto simp del:com_list_to_seq_acc.simps com_list_to_seq_nat.simps
      simp add: append_rev_nat)
  apply(subst com_list_to_seq_nat.simps)
  apply(auto simp del:com_list_to_seq_acc.simps com_list_to_seq_nat.simps
      simp add: append_rev_nat cons_Nil hd_cons tl_cons)
  done

lemma com_list_to_seq_rev:
  "com_list_to_seq_nat (append_nat ys xs) =
    com_list_to_seq_acc (com_list_to_seq_nat xs) (reverse_nat ys)"
  using rev_rev_nat com_list_to_seq_induct by metis

definition com_list_to_seq_tail :: "nat \<Rightarrow> nat" where
  "com_list_to_seq_tail ys = com_list_to_seq_acc (0 ## 0) (reverse_nat ys)"

lemma subtail_com_list_to_seq: "com_list_to_seq_nat ys = com_list_to_seq_tail ys"
  using com_list_to_seq_rev[of ys 0] append_nat_0 com_list_to_seq_tail_def
  by auto

definition comm_list_encode :: "IMP_Minus_Minus_com list \<Rightarrow> nat" where
  "comm_list_encode xs = list_encode (map comm_encode xs)"

definition comm_list_decode :: "nat \<Rightarrow> IMP_Minus_Minus_com list" where
  "comm_list_decode xs = map comm_decode (list_decode xs)"

lemma comm_list_id[simp]: "comm_list_decode (comm_list_encode x) = x"
  by (auto simp add:comm_list_encode_def comm_list_decode_def) (metis comm_id comp_def map_idI)

lemma sub_com_list_to_seq:
  "com_list_to_seq_nat (comm_list_encode xs) = comm_encode (com_list_to_seq xs)"
  apply (induct xs)
  apply (subst com_list_to_seq_nat.simps)
   apply (auto simp only: comm_list_encode_def sub_cons cons0)
   apply (simp add: cons0)
  apply (subst com_list_to_seq_nat.simps)
  apply (simp only:list.map cons0 sub_cons sub_hd sub_tl head.simps tail.simps
        com_list_to_seq.simps comm_encode.simps)
  apply auto
  done

fun binary_assign_constant_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"binary_assign_constant_nat n v x = (if n = 0 then cons 0 0 else cons 2 ( cons (cons 1
    (cons (var_bit_to_var_nat(prod_encode (v,n-1))) (cons (nth_bit_nat x (n-1)) 0 )))
  (cons (binary_assign_constant_nat (n-1) v x)0) ) )"

fun binary_assign_constant_acc:: " nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"binary_assign_constant_acc acc diff n v x = (if diff = 0 then acc else
binary_assign_constant_acc  (cons 2 ( cons (cons 1
    (cons (var_bit_to_var_tail(prod_encode (v,n-diff))) (cons (nth_bit_tail x (n-diff)) 0 )))
  (cons acc 0) )) (diff-1) n v x )"

lemma binary_assign_constant_induct:
  "diff \<le>n \<Longrightarrow>
 binary_assign_constant_acc (binary_assign_constant_nat (n- diff) v x)  diff n v x
= binary_assign_constant_nat n v x"
  apply(induct diff)
  apply (auto simp add: subtail_nth_bit subtail_var_bit_to_var)
  done

definition  binary_assign_constant_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"binary_assign_constant_tail n v x = binary_assign_constant_acc (0##0) n n v x "
lemma subtail_binary_assign_constant:
"binary_assign_constant_tail n v x = binary_assign_constant_nat n v x"
  using binary_assign_constant_induct[of n n v x]
  apply (auto simp add:binary_assign_constant_tail_def)
  done

lemma  sub_binary_assign_constant:
"binary_assign_constant_nat n (vname_encode v) x = comm_encode (binary_assign_constant n v x)"
  apply (induct n)
   apply(subst binary_assign_constant_nat.simps)
   apply (simp only: cons0 binary_assign_constant.simps)
   apply simp
  apply(subst binary_assign_constant_nat.simps)
  apply (simp only: cons0 binary_assign_constant.simps sub_cons sub_var_bit_to_var
    comm_encode.simps  flip: vname_nat_encode.simps sub_nth_bit )
  apply auto
  done

fun copy_var_to_operand_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "copy_var_to_operand_nat i op v =
    (if i = 0
      then 0 ## 0
      else
        2 ##
          (3 ## ((var_bit_to_var_nat (prod_encode (v, i - 1))) ## 0)
             ## (1 ## (operand_bit_to_var_nat (prod_encode (op, i - 1))) ## 1 ## 0)
             ## (1 ## (operand_bit_to_var_nat (prod_encode (op, i - 1))) ## 0 ## 0)
             ## 0)
          ## (copy_var_to_operand_nat (i - 1) op v)
          ## 0)"

fun copy_var_to_operand_acc ::"nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
 "copy_var_to_operand_acc acc diff i op v =
  (if diff = 0
   then acc
   else copy_var_to_operand_acc
          (2 ##
            (3 ## ((var_bit_to_var_tail (prod_encode (v, i - diff))) ## 0)
               ## (1 ## (operand_bit_to_var_tail (prod_encode (op, i - diff))) ## 1 ## 0)
               ## (1 ## (operand_bit_to_var_tail (prod_encode (op, i - diff))) ## 0 ## 0)
               ## 0)
             ## acc
             ## 0)
          (diff - 1) i op v)"

lemma copy_var_to_operand_induct :
  "diff \<le> i \<Longrightarrow> copy_var_to_operand_acc (copy_var_to_operand_nat (i - diff) op v) diff i op v
                  = copy_var_to_operand_nat i op v"
  by (induct diff) (auto simp add:subtail_var_bit_to_var subtail_operand_bit_to_var
    simp del: operand_bit_to_var_nat.simps)

definition copy_var_to_operand_tail :: "nat => nat => nat => nat" where
  "copy_var_to_operand_tail i op v = copy_var_to_operand_acc (0 ## 0) i i op v"

lemma subtail_copy_var_to_operand:
  "copy_var_to_operand_tail i op v = copy_var_to_operand_nat i op v"
  using copy_var_to_operand_induct [of i i op v]
  by(auto simp add: copy_var_to_operand_tail_def)

lemma sub_copy_var_to_operand:
  "copy_var_to_operand_nat i (encode_char op) (vname_encode v)
    = comm_encode (copy_var_to_operand i op v)"
  apply (induct i)
   apply (simp add: cons0)
  apply (subst copy_var_to_operand_nat.simps)
  apply (auto simp only: sub_cons cons0 sub_var_bit_to_var  sub_operand_bit_to_var
      copy_var_to_operand.simps comm_encode.simps bit_encode.simps vname_list_encode_def
      simp flip:vname_nat_encode.simps char_nat_encode.simps)
  apply auto
  done

fun copy_const_to_operand_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"copy_const_to_operand_nat i op x = (if i =0 then 0##0 else
2 ## (1 ## (operand_bit_to_var_nat (prod_encode (op,i-1))) ## (nth_bit_nat x (i-1)) ## 0) ## (copy_const_to_operand_nat (i-1) op x ) ## 0
)"

fun copy_const_to_operand_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"copy_const_to_operand_acc acc diff i op x = (if diff =0 then acc  else copy_const_to_operand_acc
(2 ## (1 ## (operand_bit_to_var_tail (prod_encode (op,i-diff))) ## (nth_bit_tail x (i-diff)) ## 0) ## acc ## 0
) (diff-1) i op x )"

lemma copy_const_to_operand_induct:
"diff\<le>i \<Longrightarrow>copy_const_to_operand_acc (copy_const_to_operand_nat (i-diff) op x) diff i op x =
copy_const_to_operand_nat i op x"
  apply(induct diff)
   apply(auto simp add: subtail_operand_bit_to_var subtail_nth_bit)
  done

definition copy_const_to_operand_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"copy_const_to_operand_tail i op x = copy_const_to_operand_acc (0##0) i i op x"

lemma subtail_copy_const_to_operand:
"copy_const_to_operand_tail i op x =
copy_const_to_operand_nat i op x "
  using copy_const_to_operand_induct [of i i op x]
  apply(auto simp add:copy_const_to_operand_tail_def)
  done

lemma sub_copy_const_to_operand:
 "copy_const_to_operand_nat i (encode_char op) x = comm_encode (copy_const_to_operand i op x)  "
 apply (induct i)
   apply (simp add: cons0)
  apply (subst copy_const_to_operand_nat.simps)
  apply (auto simp only: sub_cons cons0 sub_var_bit_to_var  sub_operand_bit_to_var
 copy_const_to_operand.simps comm_encode.simps sub_nth_bit
simp flip:vname_nat_encode.simps char_nat_encode.simps )
  apply auto
  done

definition copy_atom_to_operand_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"copy_atom_to_operand_nat n op a = ( if fst_nat a = 0 then  copy_var_to_operand_nat n op (snd_nat a)
 else copy_const_to_operand_nat n op (snd_nat a))"

definition copy_atom_to_operand_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"copy_atom_to_operand_tail n op a = ( if fst_nat a = 0 then  copy_var_to_operand_tail n op (snd_nat a)
 else copy_const_to_operand_nat n op (snd_nat a))"

lemma subtail_copy_atom_to_operand: "copy_atom_to_operand_tail n op a = copy_atom_to_operand_nat n op a"
  apply (simp only: copy_atom_to_operand_tail_def copy_atom_to_operand_nat_def
subtail_copy_var_to_operand  ) done

lemma sub_copy_atom_to_operand:
"copy_atom_to_operand_nat n (encode_char op) (atomExp_encode a) = comm_encode (copy_atom_to_operand n op a)"
  apply (auto simp only:copy_atom_to_operand_nat_def atomExp_encode.simps sub_fst sub_snd fst_def snd_def
          copy_atom_to_operand_def
sub_copy_const_to_operand sub_copy_var_to_operand split:atomExp.splits )
   apply auto
  done

definition assign_var_carry_nat::
  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_var_carry_nat i v a b c =
2 ## (1 ## (var_bit_to_var_nat(prod_encode (v, i))) ##
(if a + b + c = 1 \<or> a + b + c = 3 then 1 else 0) ## 0 ) ## (1##(vname_encode ''carry'')## (if a + b + c \<ge> 2 then 1 else 0) ## 0) ## 0 "

definition assign_var_carry_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"  where
"assign_var_carry_tail i v a b c =
2 ## (1 ## (var_bit_to_var_tail(prod_encode (v, i))) ##
(if a + b + c = 1 \<or> a + b + c = 3 then 1 else 0) ## 0 ) ## (1##(vname_encode ''carry'')## (if a + b + c \<ge> 2 then 1 else 0) ## 0) ## 0 "

lemma subtail_assign_var_carry:
"assign_var_carry_tail  i v a b c = assign_var_carry_nat  i v a b c"
  apply (auto simp  only: assign_var_carry_tail_def assign_var_carry_nat_def
        subtail_var_bit_to_var)
  done

lemma sub_assign_var_carry:
"assign_var_carry_nat i (vname_encode v) a b c = comm_encode(assign_var_carry i v a b c)"
  apply (auto simp only: assign_var_carry_nat_def sub_var_bit_to_var cons0 sub_cons
    assign_var_carry_def comm_encode.simps bit_encode.simps split:if_splits
 simp flip: vname_nat_encode.simps)
  done

definition full_adder_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"full_adder_nat i v  = (let assign = assign_var_carry_nat i v; op_a = operand_bit_to_var_nat (prod_encode(encode_char(CHR ''a''), i));
  op_b = operand_bit_to_var_nat (prod_encode(encode_char (CHR ''b''), i)) in
3##(op_a ## 0) ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 1 1 1) ## ( assign 1 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 1 0 1) ## ( assign 1 0 0) ## 0))##0)
               ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 0 1 1) ## ( assign 0 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 0 0 1) ## ( assign 0 0 0) ## 0))##0)
## 0
 )"

definition full_adder_tail ::  "nat \<Rightarrow> nat \<Rightarrow> nat"  where
"full_adder_tail i v  = (let assign = assign_var_carry_tail i v; op_a = operand_bit_to_var_tail (prod_encode(encode_char(CHR ''a''), i));
  op_b = operand_bit_to_var_tail (prod_encode(encode_char (CHR ''b''), i)) in
3##(op_a ## 0) ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 1 1 1) ## ( assign 1 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 1 0 1) ## ( assign 1 0 0) ## 0))##0)
               ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 0 1 1) ## ( assign 0 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 0 0 1) ## ( assign 0 0 0) ## 0))##0)
## 0
 )"

lemma subtail_full_adder: "full_adder_tail i v = full_adder_nat i v"
  apply(auto simp only: Let_def full_adder_tail_def
          full_adder_nat_def subtail_assign_var_carry subtail_operand_bit_to_var )
  done

lemma sub_full_adder: "full_adder_nat i (vname_encode v) = comm_encode (full_adder i v)"
  apply (auto simp only:full_adder_nat_def sub_assign_var_carry
 vname_list_encode_def cons0 sub_cons sub_operand_bit_to_var full_adder_def comm_encode.simps
   Let_def simp flip: char_nat_encode.simps)
  apply auto
  done

fun map_adder :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_adder v n = (if n =0 then 0 else (full_adder_nat (hd_nat n) v) ## map_adder v (tl_nat n))"

fun map_adder_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_adder_acc acc v n = (if n =0 then acc else map_adder_acc ((full_adder_tail (hd_nat n) v)##acc)
    v (tl_nat n)) "

lemma sub_map_adder:
  "map_adder v n = map_nat (\<lambda>i. full_adder_nat i v) n"
  apply (induct v n rule:map_adder.induct)
  apply (subst map_adder.simps)
  apply auto
  done

lemma map_adder_append:
"map_adder v (append_nat xs ys) = append_nat (map_adder v xs) (map_adder v ys)"
proof -
  obtain xs' ys' where "xs= list_encode xs'" "ys = list_encode ys'"
    by (metis list_decode_inverse)
  thus ?thesis apply (auto simp add:sub_append sub_map_adder sub_map simp del:map_adder.simps
map_nat.simps) done
qed

lemma map_adder_induct: "
reverse_nat (map_adder v (append_nat xs ys)) =
map_adder_acc (reverse_nat (map_adder v xs)) v ys
  "
  apply(induct ys arbitrary:xs rule:length_nat.induct)
   apply(auto simp add: append_nat_0 append_nat_Suc  simp del: map_adder.simps map_adder_acc.simps)
   apply simp
  apply(subst (2) map_adder_acc.simps)
  apply(auto simp add: map_adder_append
          reverse_append_nat subtail_full_adder  simp del: map_adder.simps map_adder_acc.simps)
  apply(subst map_adder.simps)
 apply(auto simp add:cons_Nil simp del:list_encode.simps map_adder.simps map_adder_acc.simps)
  apply(auto simp add:cons0 sub_hd sub_tl
              simp del:list_encode.simps map_adder.simps map_adder_acc.simps)
   apply(auto simp add: reverse_cons_nat
              simp del: map_adder.simps map_adder_acc.simps)
      apply(subst map_adder.simps)
    apply(auto simp add: reverse_nat_0 append_singleton_nat
              simp del: map_adder.simps map_adder_acc.simps)
  done

definition map_adder_tail  where
"map_adder_tail v n = reverse_nat (map_adder_acc 0 v n) "

lemma subtail_map_adder :
"map_adder_tail v n = map_adder v n"
  using map_adder_induct[of v 0 n]  append_nat_0
  apply (auto simp add: map_adder_tail_def simp  del: map_adder.simps map_adder_acc.simps)
  using rev_rev_nat
  by (metis map_adder.simps reverse_nat_0)

definition adder_nat:: "nat \<Rightarrow> nat  \<Rightarrow> nat" where
  "adder_nat n v =
    2 ## (com_list_to_seq_nat (map_adder v (list_less_nat n)))
      ## (1 ## (vname_encode ''carry'') ## 0 ## 0)
      ## 0"

definition adder_tail:: "nat \<Rightarrow> nat  \<Rightarrow> nat" where
  "adder_tail n v =
    2 ## (com_list_to_seq_tail (map_adder_tail v (list_less_tail n)))
      ## (1 ## (vname_encode ''carry'') ## 0 ## 0)
      ## 0"

lemma subtail_adder: "adder_tail n v = adder_nat n v"
  by(auto simp only: adder_tail_def adder_nat_def subtail_com_list_to_seq subtail_map_adder
      subtail_list_less)

lemma sub_adder: "adder_nat n (vname_encode v) = comm_encode (adder n v)"
  apply (simp only: sub_map_adder adder_nat_def sub_list_less sub_map  cons0 sub_cons sub_com_list_to_seq
      adder_def comm_encode.simps bit_encode.simps sub_full_adder extract_lambda flip: map_map
      comm_list_encode_def)
  done

definition binary_adder_nat:: "nat \<Rightarrow> nat \<Rightarrow>nat\<Rightarrow> nat \<Rightarrow> nat" where
"binary_adder_nat n v a b = 2##(
    copy_atom_to_operand_nat n (encode_char(CHR ''a'')) a)##(
2##( copy_atom_to_operand_nat n (encode_char(CHR ''b'')) b)##(
2##( adder_nat n v)##(
2##(copy_atom_to_operand_nat n (encode_char(CHR ''a'')) (prod_encode(1,0)))##(
  copy_atom_to_operand_nat n (encode_char(CHR ''b'')) (prod_encode(1,0)))##0
)##0
)##0
)##0"

definition binary_adder_tail:: "nat \<Rightarrow> nat \<Rightarrow>nat\<Rightarrow> nat \<Rightarrow> nat" where
"binary_adder_tail n v a b = 2##(
    copy_atom_to_operand_tail n (encode_char(CHR ''a'')) a)##(
2##( copy_atom_to_operand_tail n (encode_char(CHR ''b'')) b)##(
2##( adder_tail n v)##(
2##(copy_atom_to_operand_tail n (encode_char(CHR ''a'')) (prod_encode(1,0)))##(
  copy_atom_to_operand_tail n (encode_char(CHR ''b'')) (prod_encode(1,0)))##0
)##0
)##0
)##0"

lemma subtail_binary_adder:
"binary_adder_tail n v a b  = binary_adder_nat n v a b "
  apply(auto simp only: binary_adder_nat_def binary_adder_tail_def subtail_copy_atom_to_operand
        subtail_adder)
  done

lemma sub_binary_adder:
 "binary_adder_nat n (vname_encode v) (atomExp_encode a) (atomExp_encode b) =
    comm_encode (binary_adder n v a b)"
  apply (auto simp only:binary_adder_nat_def cons0 sub_cons binary_adder_def
         sub_copy_atom_to_operand  comm_encode.simps sub_adder simp flip: atomExp_encode.simps)
  done

definition assign_var_carry_sub_nat::
  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_var_carry_sub_nat i v a b c =
2 ## (1 ## (var_bit_to_var_nat(prod_encode (v, i))) ##
(if b + c = 0 \<or> b + c = 2 then (if a = 1 then 1 else 0)
    else (if b + c = 1 \<and> a = 0 then 1 else 0))  ## 0 ) ##
(1##(vname_encode ''carry'')## (if a < b + c then 1 else 0) ## 0) ## 0 "

definition assign_var_carry_sub_tail::
  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_var_carry_sub_tail i v a b c =
2 ## (1 ## (var_bit_to_var_tail (prod_encode (v, i))) ##
(if b + c = 0 \<or> b + c = 2 then (if a = 1 then 1 else 0)
    else (if b + c = 1 \<and> a = 0 then 1 else 0))  ## 0 ) ##
(1##(vname_encode ''carry'')## (if a < b + c then 1 else 0) ## 0) ## 0 "

lemma subtail_assign_var_carry_sub:
"assign_var_carry_sub_tail i v a b c = assign_var_carry_sub_nat i v a b c"
  apply(auto simp only: assign_var_carry_sub_tail_def assign_var_carry_sub_nat_def
          subtail_var_bit_to_var)
  done

lemma sub_assign_var_carry_sub:
"assign_var_carry_sub_nat i (vname_encode v) a b c = comm_encode(assign_var_carry_sub i v a b c)"
  apply (auto simp only: assign_var_carry_sub_nat_def sub_var_bit_to_var cons0 sub_cons
    assign_var_carry_sub_def comm_encode.simps bit_encode.simps split:if_splits
 simp flip: vname_nat_encode.simps)
  done

definition full_subtractor_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"full_subtractor_nat i v  = (let assign = assign_var_carry_sub_nat i v; op_a = operand_bit_to_var_nat (prod_encode(encode_char(CHR ''a''), i));
  op_b = operand_bit_to_var_nat (prod_encode(encode_char (CHR ''b''), i)) in
3##(op_a ## 0) ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 1 1 1) ## ( assign 1 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 1 0 1) ## ( assign 1 0 0) ## 0))##0)
               ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 0 1 1) ## ( assign 0 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 0 0 1) ## ( assign 0 0 0) ## 0))##0)
## 0
 )"

definition full_subtractor_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"full_subtractor_tail i v  = (let assign = assign_var_carry_sub_tail i v; op_a = operand_bit_to_var_tail (prod_encode(encode_char(CHR ''a''), i));
  op_b = operand_bit_to_var_tail (prod_encode(encode_char (CHR ''b''), i)) in
3##(op_a ## 0) ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 1 1 1) ## ( assign 1 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 1 0 1) ## ( assign 1 0 0) ## 0))##0)
               ##(3##((vname_encode ''carry'') ## 0)## (3 ## (op_b ## 0) ## (assign 0 1 1) ## ( assign 0 1 0) ## 0)##(
                                                       (3 ## (op_b ## 0) ## (assign 0 0 1) ## ( assign 0 0 0) ## 0))##0)
## 0
 )"

lemma subtail_full_subtractor:
"full_subtractor_tail i v = full_subtractor_nat i v"
  apply(auto simp only: full_subtractor_tail_def full_subtractor_nat_def
        subtail_assign_var_carry_sub subtail_operand_bit_to_var Let_def)
  done

lemma sub_full_subtractor: "full_subtractor_nat i (vname_encode v) = comm_encode (full_subtractor i v)"
  apply (auto simp only:full_subtractor_nat_def sub_assign_var_carry_sub
 vname_list_encode_def cons0 sub_cons sub_operand_bit_to_var full_subtractor_def comm_encode.simps
   Let_def simp flip: char_nat_encode.simps)
  apply auto
  done

definition underflow_handler_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"underflow_handler_nat n v = 3##((vname_encode ''carry'')## 0) ## (2##(1##(vname_encode ''carry'')##0##0)##(
binary_assign_constant_nat n v 0
)##0)## (0##0) ## 0"

definition underflow_handler_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"underflow_handler_tail n v = 3##((vname_encode ''carry'')## 0) ## (2##(1##(vname_encode ''carry'')##0##0)##(
binary_assign_constant_tail n v 0
)##0)## (0##0) ## 0"

lemma subtail_underflow_handler:
"underflow_handler_tail n v = underflow_handler_nat n v"
  apply(auto simp only: underflow_handler_tail_def underflow_handler_nat_def
subtail_binary_assign_constant
) done

lemma sub_underflow_handler:
 "underflow_handler_nat n (vname_encode v) = comm_encode (underflow_handler n v) "
  apply (auto simp only:underflow_handler_nat_def cons0 sub_cons underflow_handler_def
      bit_encode.simps comm_encode.simps vname_list_encode_def sub_binary_assign_constant )
  apply auto
  done

fun map_full_subtractor :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_full_subtractor v n = (if n = 0 then 0 else (full_subtractor_nat(hd_nat n) v) ## map_full_subtractor v (tl_nat n))"

lemma submap_full_subtractor:
  "map_full_subtractor v n = map_nat (\<lambda>i. full_subtractor_nat i v) n"
  apply (induct v n rule : map_full_subtractor.induct)
  apply (subst map_full_subtractor.simps)
  apply (auto)
  done

fun map_full_subtractor_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_full_subtractor_acc acc v n = (if n =0 then acc else map_full_subtractor_acc ((full_subtractor_tail (hd_nat n) v)##acc)
    v (tl_nat n)) "

lemma map_full_subtractor_append:
"map_full_subtractor v (append_nat xs ys) = append_nat (map_full_subtractor v xs) (map_full_subtractor v ys)"
proof -
  obtain xs' ys' where "xs= list_encode xs'" "ys = list_encode ys'"
    by (metis list_decode_inverse)
  thus ?thesis apply (auto simp add:sub_append submap_full_subtractor sub_map simp del:map_full_subtractor.simps
map_nat.simps) done
qed

lemma map_full_subtractor_induct: "
reverse_nat (map_full_subtractor v (append_nat xs ys)) =
map_full_subtractor_acc (reverse_nat (map_full_subtractor v xs)) v ys
  "
  apply(induct ys arbitrary:xs rule:length_nat.induct)
   apply(auto simp add: append_nat_0 append_nat_Suc  simp del: map_full_subtractor.simps map_full_subtractor_acc.simps)
   apply simp
  apply(subst (2) map_full_subtractor_acc.simps)
  apply(auto simp add: map_full_subtractor_append
          reverse_append_nat subtail_full_subtractor  simp del: map_full_subtractor.simps map_full_subtractor_acc.simps)
  apply(subst map_full_subtractor.simps)
 apply(auto simp add:cons_Nil simp del:list_encode.simps map_full_subtractor.simps map_full_subtractor_acc.simps)
  apply(auto simp add:cons0 sub_hd sub_tl
              simp del:list_encode.simps map_full_subtractor.simps map_full_subtractor_acc.simps)
   apply(auto simp add: reverse_cons_nat
              simp del: map_full_subtractor.simps map_full_subtractor_acc.simps)
      apply(subst map_full_subtractor.simps)
    apply(auto simp add: reverse_nat_0 append_singleton_nat
              simp del: map_adder.simps map_adder_acc.simps)
  done

definition map_full_subtractor_tail  where
"map_full_subtractor_tail v n = reverse_nat (map_full_subtractor_acc 0 v n) "

lemma subtail_map_full_subtractor :
"map_full_subtractor_tail v n = map_full_subtractor v n"
  using map_full_subtractor_induct[of v 0 n]  append_nat_0
  apply (auto simp add: map_full_subtractor_tail_def simp  del: map_full_subtractor.simps map_full_subtractor_acc.simps)
  using rev_rev_nat
  by (metis map_full_subtractor.simps reverse_nat_0)

definition subtract_handle_underflow_nat::
  "nat \<Rightarrow> nat \<Rightarrow> nat" where
"subtract_handle_underflow_nat n v = 2##
  (com_list_to_seq_nat (map_full_subtractor v (list_less_nat n)))##
  (underflow_handler_nat n v) ## 0"

definition subtract_handle_underflow_tail::
  "nat \<Rightarrow> nat \<Rightarrow> nat" where
"subtract_handle_underflow_tail n v = 2##
  (com_list_to_seq_tail (map_full_subtractor_tail v (list_less_tail n)))##
  (underflow_handler_tail n v) ## 0"

lemma subtail_subtract_handle_underflow:
" subtract_handle_underflow_tail n v =  subtract_handle_underflow_nat n v"
  apply( auto simp only: subtract_handle_underflow_tail_def
          subtract_handle_underflow_nat_def
          subtail_com_list_to_seq subtail_map_full_subtractor subtail_list_less
            subtail_underflow_handler)
  done

lemma sub_subtract_underflow :
"subtract_handle_underflow_nat n (vname_encode v) = comm_encode ( subtract_handle_underflow n v)"
  apply (auto simp only: submap_full_subtractor subtract_handle_underflow_nat_def cons0 sub_cons sub_com_list_to_seq sub_map
sub_list_less sub_full_subtractor extract_lambda sub_underflow_handler
 comm_encode.simps subtract_handle_underflow_def
    simp flip:map_map comm_list_encode_def)
  done

definition binary_subtractor_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>nat" where
"binary_subtractor_nat n v a b =
2 ## (copy_atom_to_operand_nat n (encode_char(CHR ''a'')) a) ## (
2 ## (   copy_atom_to_operand_nat n (encode_char(CHR ''b'')) b) ## (
2 ## (subtract_handle_underflow_nat n v) ##(
2##(copy_atom_to_operand_nat n (encode_char(CHR ''a'')) (prod_encode(1,0)))##(
  copy_atom_to_operand_nat n (encode_char(CHR ''b'')) (prod_encode(1,0)))##0
) ## 0
) ## 0
) ## 0"

definition binary_subtractor_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>nat" where
"binary_subtractor_tail n v a b =
2 ## (copy_atom_to_operand_tail n (encode_char(CHR ''a'')) a) ## (
2 ## (   copy_atom_to_operand_tail n (encode_char(CHR ''b'')) b) ## (
2 ## (subtract_handle_underflow_tail n v) ##(
2##(copy_atom_to_operand_tail n (encode_char(CHR ''a'')) (prod_encode(1,0)))##(
  copy_atom_to_operand_tail n (encode_char(CHR ''b'')) (prod_encode(1,0)))##0
) ## 0
) ## 0
) ## 0"

lemma subtail_binary_subtractor:
"binary_subtractor_tail n v a b = binary_subtractor_nat n v a b  "
  apply(auto simp only: binary_subtractor_tail_def binary_subtractor_nat_def
        subtail_copy_atom_to_operand subtail_subtract_handle_underflow)
  done

lemma sub_binary_subtractor:
"binary_subtractor_nat n (vname_encode v) (atomExp_encode a) (atomExp_encode b) =
    comm_encode (binary_subtractor n v a b)"
  apply (auto simp only:binary_subtractor_nat_def cons0 sub_cons binary_subtractor_def
         sub_copy_atom_to_operand  comm_encode.simps sub_adder sub_subtract_underflow
 simp flip: atomExp_encode.simps)
  done

definition binary_parity_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"binary_parity_nat n v a  = (if fst_nat a \<noteq> 0 then  binary_assign_constant_nat n v (snd_nat a mod 2)
else 2## (3 ## ((var_bit_to_var_nat(prod_encode(snd_nat a, 0))) ## 0) ## (binary_assign_constant_nat n v 1)
 ##( binary_assign_constant_nat n v 0) ## 0)## (
2 ## (copy_atom_to_operand_nat n (encode_char (CHR ''a'')) a) ##
 (copy_atom_to_operand_nat n (encode_char (CHR ''a'')) (prod_encode(1,0))) ## 0
) ## 0 )"

definition binary_parity_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"binary_parity_tail n v a  = (if fst_nat a \<noteq> 0 then  binary_assign_constant_tail n v (snd_nat a mod 2)
else 2## (3 ## ((var_bit_to_var_tail(prod_encode(snd_nat a, 0))) ## 0) ## (binary_assign_constant_tail n v 1)
 ##( binary_assign_constant_tail n v 0) ## 0)## (
2 ## (copy_atom_to_operand_tail n (encode_char (CHR ''a'')) a) ##
 (copy_atom_to_operand_tail n (encode_char (CHR ''a'')) (prod_encode(1,0))) ## 0
) ## 0 )"

lemma subtail_binary_parity:
"binary_parity_tail n v a = binary_parity_nat n v a"
  apply(auto simp only: binary_parity_tail_def binary_parity_nat_def
              subtail_var_bit_to_var subtail_binary_assign_constant
               subtail_copy_atom_to_operand)
  done

lemma sub_binary_parity:
 "binary_parity_nat n (vname_encode v) (atomExp_encode a) = comm_encode(binary_parity n v a) "
  apply (auto simp only: binary_parity_nat_def cons0 sub_cons sub_binary_assign_constant)
  apply (cases a)
    apply (auto simp add: sub_fst sub_snd )[1]
  apply (auto simp only: sub_var_bit_to_var  sub_fst sub_snd snd_def fst_def
 atomExp_encode.simps binary_parity.simps comm_encode.simps sub_copy_atom_to_operand
 simp flip: vname_nat_encode.simps )
  apply (auto simp only: sub_copy_atom_to_operand
        vname_list_encode_def simp flip:atomExp_encode.simps)
  apply auto
  done

fun assign_shifted_bits_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_shifted_bits_nat i v = (if i = 0 then 0##0 else
2##(
3##((operand_bit_to_var_nat(prod_encode (encode_char(CHR ''a''), i)))##0)##(
1## (var_bit_to_var_nat (prod_encode(v, i-1)))## 1 ##0)##(
1## (var_bit_to_var_nat (prod_encode(v, i-1)))## 0 ##0
)##0)## (
assign_shifted_bits_nat (i-1) v
)##0
)"

fun assign_shifted_bits_acc:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_shifted_bits_acc acc diff i v = (if diff  = 0 then acc else assign_shifted_bits_acc (
2##(
3##((operand_bit_to_var_tail (prod_encode (encode_char(CHR ''a''), i-diff +1 )))##0)##(
1## (var_bit_to_var_tail (prod_encode(v, i-diff)))## 1 ##0)##(
1## (var_bit_to_var_tail (prod_encode(v, i-diff)))## 0 ##0
)##0)## (
acc
)##0) (diff-1) i v
)"

lemma assign_shifted_bits_induct:
"diff \<le> i \<Longrightarrow>assign_shifted_bits_acc (assign_shifted_bits_nat (i-diff) v) diff i v =
assign_shifted_bits_nat i v"
  apply(induct diff)
   apply simp
  apply(subst assign_shifted_bits_acc.simps)
  apply(auto simp add: subtail_operand_bit_to_var
subtail_var_bit_to_var
simp del: assign_shifted_bits_acc.simps assign_shifted_bits_nat.simps operand_bit_to_var_nat.simps)
  apply(subst (asm) assign_shifted_bits_nat.simps)
 apply(auto simp add:
simp del: assign_shifted_bits_acc.simps assign_shifted_bits_nat.simps operand_bit_to_var_nat.simps)
  using Suc_diff_Suc Suc_le_lessD apply presburger
  done

definition assign_shifted_bits_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_shifted_bits_tail i v = assign_shifted_bits_acc (0##0) i i v"

lemma subtail_assign_shifted_bits:
"assign_shifted_bits_tail i v =assign_shifted_bits_nat i v "
  apply(auto simp only: assign_shifted_bits_tail_def)
  using assign_shifted_bits_induct[of i i v]
  apply auto
  done

lemma sub_assign_shifted_bits:
"assign_shifted_bits_nat i (vname_encode v) = comm_encode (assign_shifted_bits i v)"
  apply (induct i)
   apply (subst assign_shifted_bits_nat.simps)
   apply  (simp only: cons0 comm_encode.simps assign_shifted_bits.simps)[1]
   apply  simp
    apply (subst assign_shifted_bits_nat.simps)
  apply (auto simp only: cons0 sub_cons comm_encode.simps assign_shifted_bits.simps
  sub_var_bit_to_var sub_operand_bit_to_var vname_list_encode_def
      simp flip: vname_nat_encode.simps char_nat_encode.simps )
  apply auto
  done

definition assign_shifted_bits_and_zero_most_significant_nat::
  "nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_shifted_bits_and_zero_most_significant_nat n v = 2 ## (assign_shifted_bits_nat (n - 1) v)##
  (1 ## (var_bit_to_var_nat (prod_encode(v, n - 1)))##0##0) ## 0"

definition assign_shifted_bits_and_zero_most_significant_tail::
  "nat \<Rightarrow> nat \<Rightarrow> nat" where
"assign_shifted_bits_and_zero_most_significant_tail n v = 2 ## (assign_shifted_bits_tail (n - 1) v)##
  (1 ## (var_bit_to_var_tail (prod_encode(v, n - 1)))##0##0) ## 0"

lemma subtail_assign_shifted_bits_and_zero_most_significant:
" assign_shifted_bits_and_zero_most_significant_tail n v =  assign_shifted_bits_and_zero_most_significant_nat n v "
  apply(auto simp only:  assign_shifted_bits_and_zero_most_significant_nat_def
 assign_shifted_bits_and_zero_most_significant_tail_def
  subtail_var_bit_to_var subtail_assign_shifted_bits)
  done

lemma sub_assign_shifted_bits_and_zero_most_significant:
" assign_shifted_bits_and_zero_most_significant_nat n (vname_encode v) =
  comm_encode (assign_shifted_bits_and_zero_most_significant n v)"
  apply (auto simp only: assign_shifted_bits_and_zero_most_significant_nat_def
       cons0 sub_cons sub_var_bit_to_var sub_assign_shifted_bits comm_encode.simps
  assign_shifted_bits_and_zero_most_significant_def bit_encode.simps
 simp flip: vname_nat_encode.simps )
  done

definition binary_right_shift_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"binary_right_shift_nat n v a = 2 ## (2 ## (copy_atom_to_operand_nat n (encode_char(CHR ''a'')) a) ##
(assign_shifted_bits_and_zero_most_significant_nat n v) ## 0) ##
    (copy_atom_to_operand_nat n (encode_char(CHR ''a'')) (prod_encode(1,0))) ## 0"

definition binary_right_shift_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"binary_right_shift_tail n v a = 2 ## (2 ## (copy_atom_to_operand_tail n (encode_char(CHR ''a'')) a) ##
(assign_shifted_bits_and_zero_most_significant_tail n v) ## 0) ##
    (copy_atom_to_operand_tail n (encode_char(CHR ''a'')) (prod_encode(1,0))) ## 0"

lemma subtail_binary_right_shift:
"binary_right_shift_tail n v a = binary_right_shift_nat n v a"
  apply(auto simp only: binary_right_shift_tail_def  binary_right_shift_nat_def
   subtail_copy_atom_to_operand subtail_assign_shifted_bits_and_zero_most_significant
  )done

lemma sub_binary_right_shift:
  "binary_right_shift_nat n (vname_encode v) (atomExp_encode a) = comm_encode (binary_right_shift n v a)"
  apply (auto simp only: binary_right_shift_nat_def cons0 sub_cons sub_copy_atom_to_operand
 sub_assign_shifted_bits_and_zero_most_significant comm_encode.simps
binary_right_shift_def
 simp flip: atomExp_encode.simps)
  done

definition assignment_to_binary_nat:: "nat \<Rightarrow> nat \<Rightarrow>nat \<Rightarrow> nat" where
"assignment_to_binary_nat n v aexp = (if hd_nat aexp =0 then
   binary_adder_nat n v (nth_nat (Suc 0) aexp) (prod_encode (1,0))
else if hd_nat aexp = 1 then binary_adder_nat n v (nth_nat (Suc 0) aexp) (nth_nat (Suc (Suc 0)) aexp)
else if hd_nat aexp = 2 then binary_subtractor_nat n v (nth_nat (Suc 0) aexp) (nth_nat (Suc (Suc 0)) aexp)
else if hd_nat aexp = 3 then binary_parity_nat n v (nth_nat (Suc 0) aexp)
else  binary_right_shift_nat n v (nth_nat (Suc 0) aexp)
)"

definition assignment_to_binary_tail:: "nat \<Rightarrow> nat \<Rightarrow>nat \<Rightarrow> nat" where
"assignment_to_binary_tail n v aexp = (if hd_nat aexp =0 then
   binary_adder_tail n v (nth_nat (Suc 0) aexp) (prod_encode (1,0))
else if hd_nat aexp = 1 then binary_adder_tail n v (nth_nat (Suc 0) aexp) (nth_nat (Suc (Suc 0)) aexp)
else if hd_nat aexp = 2 then binary_subtractor_tail n v (nth_nat (Suc 0) aexp) (nth_nat (Suc (Suc 0)) aexp)
else if hd_nat aexp = 3 then binary_parity_tail n v (nth_nat (Suc 0) aexp)
else  binary_right_shift_tail n v (nth_nat (Suc 0) aexp)
)"

lemma subtail_assignment_to_binary :
 "assignment_to_binary_tail n v aexp = assignment_to_binary_nat n v aexp"
  apply(auto simp only: assignment_to_binary_tail_def assignment_to_binary_nat_def
    subtail_binary_adder subtail_binary_subtractor subtail_binary_right_shift subtail_binary_parity
) done

lemma sub_assignment_to_binary:
"assignment_to_binary_nat n (vname_encode v) (aexp_encode aexp) =
  comm_encode (assignment_to_binary n v aexp)"
  apply (cases aexp)
      apply (auto simp only: assignment_to_binary_nat_def aexp_encode.simps sub_hd head.simps
                  sub_binary_adder sub_binary_subtractor sub_binary_parity
                  sub_nth nth.simps
        assignment_to_binary_def sub_binary_right_shift
 simp flip: atomExp_encode.simps )
      apply auto
  done

end


(*  Title:      CCL/ex/Stream.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section {* Programs defined over streams *}

theory Stream
imports List
begin

definition iter1 :: "[i\<Rightarrow>i,i]\<Rightarrow>i"
  where "iter1(f,a) == letrec iter x be x$iter(f(x)) in iter(a)"

definition iter2 :: "[i\<Rightarrow>i,i]\<Rightarrow>i"
  where "iter2(f,a) == letrec iter x be x$map(f,iter(x)) in iter(a)"

(*
Proving properties about infinite lists using coinduction:
    Lists(A)  is the set of all finite and infinite lists of elements of A.
    ILists(A) is the set of infinite lists of elements of A.
*)

subsection {* Map of composition is composition of maps *}

lemma map_comp:
  assumes 1: "l:Lists(A)"
  shows "map(f \<circ> g,l) = map(f,map(g,l))"
  apply (eq_coinduct3 "{p. EX x y. p=<x,y> \<and> (EX l:Lists (A) .x=map (f \<circ> g,l) \<and> y=map (f,map (g,l)))}")
   apply (blast intro: 1)
  apply safe
  apply (drule ListsXH [THEN iffD1])
  apply EQgen
   apply fastforce
  done

(*** Mapping the identity function leaves a list unchanged ***)

lemma map_id:
  assumes 1: "l:Lists(A)"
  shows "map(\<lambda>x. x, l) = l"
  apply (eq_coinduct3 "{p. EX x y. p=<x,y> \<and> (EX l:Lists (A) .x=map (\<lambda>x. x,l) \<and> y=l) }")
  apply (blast intro: 1)
  apply safe
  apply (drule ListsXH [THEN iffD1])
  apply EQgen
  apply blast
  done

subsection {* Mapping distributes over append *}

lemma map_append:
  assumes "l:Lists(A)"
    and "m:Lists(A)"
  shows "map(f,l@m) = map(f,l) @ map(f,m)"
  apply (eq_coinduct3
    "{p. EX x y. p=<x,y> \<and> (EX l:Lists (A). EX m:Lists (A). x=map (f,l@m) \<and> y=map (f,l) @ map (f,m))}")
  apply (blast intro: assms)
  apply safe
  apply (drule ListsXH [THEN iffD1])
  apply EQgen
  apply (drule ListsXH [THEN iffD1])
  apply EQgen
  apply blast
  done

subsection {* Append is associative *}

lemma append_assoc:
  assumes "k:Lists(A)"
    and "l:Lists(A)"
    and "m:Lists(A)"
  shows "k @ l @ m = (k @ l) @ m"
  apply (eq_coinduct3
    "{p. EX x y. p=<x,y> \<and> (EX k:Lists (A). EX l:Lists (A). EX m:Lists (A). x=k @ l @ m \<and> y= (k @ l) @ m) }")
  apply (blast intro: assms)
  apply safe
  apply (drule ListsXH [THEN iffD1])
  apply EQgen
   prefer 2
   apply blast
  apply (tactic {* DEPTH_SOLVE (etac (XH_to_E @{thm ListsXH}) 1
    THEN EQgen_tac @{context} [] 1) *})
  done

subsection {* Appending anything to an infinite list doesn't alter it *}

lemma ilist_append:
  assumes "l:ILists(A)"
  shows "l @ m = l"
  apply (eq_coinduct3 "{p. EX x y. p=<x,y> \<and> (EX l:ILists (A) .EX m. x=l@m \<and> y=l)}")
  apply (blast intro: assms)
  apply safe
  apply (drule IListsXH [THEN iffD1])
  apply EQgen
  apply blast
  done

(*** The equivalance of two versions of an iteration function       ***)
(*                                                                    *)
(*        fun iter1(f,a) = a$iter1(f,f(a))                            *)
(*        fun iter2(f,a) = a$map(f,iter2(f,a))                        *)

lemma iter1B: "iter1(f,a) = a$iter1(f,f(a))"
  apply (unfold iter1_def)
  apply (rule letrecB [THEN trans])
  apply simp
  done

lemma iter2B: "iter2(f,a) = a $ map(f,iter2(f,a))"
  apply (unfold iter2_def)
  apply (rule letrecB [THEN trans])
  apply (rule refl)
  done

lemma iter2Blemma:
  "n:Nat \<Longrightarrow>
    map(f) ^ n ` iter2(f,a) = (f ^ n ` a) $ (map(f) ^ n ` map(f,iter2(f,a)))"
  apply (rule_tac P = "\<lambda>x. ?lhs (x) = ?rhs" in iter2B [THEN ssubst])
  apply (simp add: nmapBcons)
  done

lemma iter1_iter2_eq: "iter1(f,a) = iter2(f,a)"
  apply (eq_coinduct3
    "{p. EX x y. p=<x,y> \<and> (EX n:Nat. x=iter1 (f,f^n`a) \<and> y=map (f) ^n`iter2 (f,a))}")
  apply (fast intro!: napplyBzero [symmetric] napplyBzero [symmetric, THEN arg_cong])
  apply (EQgen iter1B iter2Blemma)
  apply (subst napply_f, assumption)
  apply (rule_tac f1 = f in napplyBsucc [THEN subst])
  apply blast
  done

end


(*
    File:        FinCard.thy
    Time-stamp:  <2015-12-12T10:47:26Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory FinCard imports Finite Cardinal begin

lemma Fin_subset2:
  assumes "X: Fin(A)"
      and "X <= B"
    shows "X: Fin(B)"
apply (rule assms(2) [THEN rev_mp])
apply (rule assms(1) [THEN Fin_induct])
apply (rule impI)
apply (rule Fin.emptyI)
apply (rule impI)
apply (erule cons_subsetE)
apply (rule Fin.consI)
apply (drule_tac [2] mp)
apply assumption+
done

lemma Fin_domainI [TC]:
    "X: Fin(A*B) ==> domain(X): Fin(A)"
apply (erule Fin_induct)
apply (erule_tac [2] SigmaE)
apply simp_all
done

lemma Fin_rangeI [TC]:
    "X: Fin(A*B) ==> range(X): Fin(B)"
apply (erule Fin_induct)
apply (erule_tac [2] SigmaE)
apply simp_all
done

lemma Fin_RepFunI [TC]:
    "[| X: Fin(A); !!x. x: A ==> f(x): B |] ==> {f(x). x: X}: Fin(B)"
apply (erule Fin_induct)
apply simp_all
done

lemmas Fin_imp_Finite = Fin_into_Finite
lemmas Finite_imp_Fin = Finite_into_Fin

lemma Finite_imp_card_nat [TC]:
    "Finite(A) ==> |A|: nat"
apply (unfold Finite_def)
apply (erule bexE)
apply (drule cardinal_cong)
apply (erule ssubst)
apply (rule lt_nat_in_nat)
apply (rule Ord_cardinal_le)
apply (erule nat_into_Ord)
apply (erule nat_succI)
done

lemma Fin_complete_induct_lemma:
 "n: nat ==> (ALL X: Fin(A). |X| = n -->
   (ALL x: Fin(A). (ALL y. y: Fin(A) & |y| < |x| --> P(y)) --> P(x))
   --> P(X))"
apply (erule complete_induct)
apply clarsimp
apply (erule bspec [THEN mp])
apply assumption
apply clarsimp
apply (drule ltD)
apply simp
done

lemma Fin_complete_induct:
  assumes major: "X: Fin(A)"
  and indstep: "!!x. [| x: Fin(A);
                       ALL y. y: Fin(A) & |y| < |x| --> P(y)
                     |] ==> P(x)"
  shows "P(X)"
apply (rule major [THEN Fin_into_Finite, THEN Finite_imp_card_nat,
                   THEN Fin_complete_induct_lemma,
                   THEN bspec, THEN mp, THEN mp])
apply ((rule major refl ballI impI indstep) | assumption)+
done

lemma Finite_lepoll_imp_le:
  assumes major: "A lepoll B"
  and prem: "Finite(B)"
  shows "|A| le |B|"
apply (insert lepoll_Finite [OF major prem] prem major)
apply (unfold Finite_def cardinal_def)
apply clarify
apply (rule le_trans)
apply (rule Least_le)
apply (erule eqpoll_sym)
apply (erule nat_into_Ord)
apply (rule_tac P="%x. n le x" in ssubst)
apply (rule Least_equality)
apply (erule eqpoll_sym)
apply (erule nat_into_Ord)
apply (rule notI)
apply (drule eqpoll_trans, assumption)
apply (frule lt_nat_in_nat)
apply assumption
apply (drule nat_eqpoll_iff [THEN iffD1], assumption, assumption)
apply hypsubst
apply (erule lt_irrefl)
apply (rule nat_lepoll_imp_le)
apply assumption+
apply (rule lepoll_trans)
apply (rule eqpoll_sym [THEN eqpoll_imp_lepoll], assumption)
apply (rule lepoll_trans, assumption)
apply (erule eqpoll_imp_lepoll)
done

lemma Finite_cardinal_succ:
    "Finite(A) ==> |succ(A)| = succ(|A|)"
apply (unfold Finite_def)
apply (erule bexE)
apply (rule_tac b="|succ(n)|" in trans)
apply (rule cardinal_cong)
apply (simp only: succ_def)
apply (blast elim!: mem_irrefl intro: cons_eqpoll_cong)
apply (drule cardinal_cong)
apply (simp add: nat_into_Card [THEN Card_cardinal_eq])
done

lemma Finite_cardinal_cons:
  assumes major: "Finite(A)"
  shows "a ~: A ==> |cons(a, A)| = succ(|A|)"
apply (rule major [THEN Finite_cardinal_succ, THEN [2] trans])
apply (rule cardinal_cong)
apply (unfold succ_def)
apply (blast elim!: mem_irrefl intro: eqpoll_refl cons_eqpoll_cong)
done

lemmas FinCard_simps = Finite_cardinal_cons cons_absorb cardinal_0

end


(*  Title:      ZF/Induct/FoldSet.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory

A "fold" functional for finite sets.  For n non-negative we have
fold f e {x1,...,xn} = f x1 (... (f xn e)) where f is at
least left-commutative.
*)

theory FoldSet imports ZF begin

consts fold_set :: "[i, i, [i,i]=>i, i] => i"

inductive
  domains "fold_set(A, B, f,e)" \<subseteq> "Fin(A)*B"
  intros
    emptyI: "e\<in>B ==> <0, e>\<in>fold_set(A, B, f,e)"
    consI:  "[| x\<in>A; x \<notin>C;  <C,y> \<in> fold_set(A, B,f,e); f(x,y):B |]
                ==>  <cons(x,C), f(x,y)>\<in>fold_set(A, B, f, e)"
  type_intros Fin.intros

definition
  fold :: "[i, [i,i]=>i, i, i] => i"  (\<open>fold[_]'(_,_,_')\<close>)  where
   "fold[B](f,e, A) == THE x. <A, x>\<in>fold_set(A, B, f,e)"

definition
   setsum :: "[i=>i, i] => i"  where
   "setsum(g, C) == if Finite(C) then
                     fold[int](%x y. g(x) $+ y, #0, C) else #0"

(** foldSet **)

inductive_cases empty_fold_setE: "<0, x> \<in> fold_set(A, B, f,e)"
inductive_cases cons_fold_setE: "<cons(x,C), y> \<in> fold_set(A, B, f,e)"

(* add-hoc lemmas *)

lemma cons_lemma1: "[| x\<notin>C; x\<notin>B |] ==> cons(x,B)=cons(x,C) \<longleftrightarrow> B = C"
by (auto elim: equalityE)

lemma cons_lemma2: "[| cons(x, B)=cons(y, C); x\<noteq>y; x\<notin>B; y\<notin>C |]
    ==>  B - {y} = C-{x} & x\<in>C & y\<in>B"
apply (auto elim: equalityE)
done

(* fold_set monotonicity *)
lemma fold_set_mono_lemma:
     "<C, x> \<in> fold_set(A, B, f, e)
      ==> \<forall>D. A<=D \<longrightarrow> <C, x> \<in> fold_set(D, B, f, e)"
apply (erule fold_set.induct)
apply (auto intro: fold_set.intros)
done

lemma fold_set_mono: " C<=A ==> fold_set(C, B, f, e) \<subseteq> fold_set(A, B, f, e)"
apply clarify
apply (frule fold_set.dom_subset [THEN subsetD], clarify)
apply (auto dest: fold_set_mono_lemma)
done

lemma fold_set_lemma:
     "<C, x>\<in>fold_set(A, B, f, e) ==> <C, x>\<in>fold_set(C, B, f, e) & C<=A"
apply (erule fold_set.induct)
apply (auto intro!: fold_set.intros intro: fold_set_mono [THEN subsetD])
done

(* Proving that fold_set is deterministic *)
lemma Diff1_fold_set:
     "[| <C-{x},y> \<in> fold_set(A, B, f,e);  x\<in>C; x\<in>A; f(x, y):B |]
      ==> <C, f(x, y)> \<in> fold_set(A, B, f, e)"
apply (frule fold_set.dom_subset [THEN subsetD])
apply (erule cons_Diff [THEN subst], rule fold_set.intros, auto)
done

locale fold_typing =
 fixes A and B and e and f
 assumes ftype [intro,simp]:  "[|x \<in> A; y \<in> B|] ==> f(x,y) \<in> B"
     and etype [intro,simp]:  "e \<in> B"
     and fcomm:  "[|x \<in> A; y \<in> A; z \<in> B|] ==> f(x, f(y, z))=f(y, f(x, z))"

lemma (in fold_typing) Fin_imp_fold_set:
     "C\<in>Fin(A) ==> (\<exists>x. <C, x> \<in> fold_set(A, B, f,e))"
apply (erule Fin_induct)
apply (auto dest: fold_set.dom_subset [THEN subsetD]
            intro: fold_set.intros etype ftype)
done

lemma Diff_sing_imp:
     "[|C - {b} = D - {a}; a \<noteq> b; b \<in> C|] ==> C = cons(b,D) - {a}"
by (blast elim: equalityE)

lemma (in fold_typing) fold_set_determ_lemma [rule_format]:
"n\<in>nat
 ==> \<forall>C. |C|<n \<longrightarrow>
   (\<forall>x. <C, x> \<in> fold_set(A, B, f,e)\<longrightarrow>
           (\<forall>y. <C, y> \<in> fold_set(A, B, f,e) \<longrightarrow> y=x))"
apply (erule nat_induct)
 apply (auto simp add: le_iff)
apply (erule fold_set.cases)
 apply (force elim!: empty_fold_setE)
apply (erule fold_set.cases)
 apply (force elim!: empty_fold_setE, clarify)
(*force simplification of "|C| < |cons(...)|"*)
apply (frule_tac a = Ca in fold_set.dom_subset [THEN subsetD, THEN SigmaD1])
apply (frule_tac a = Cb in fold_set.dom_subset [THEN subsetD, THEN SigmaD1])
apply (simp add: Fin_into_Finite [THEN Finite_imp_cardinal_cons])
apply (case_tac "x=xb", auto)
apply (simp add: cons_lemma1, blast)
txt\<open>case \<^term>\<open>x\<noteq>xb\<close>\<close>
apply (drule cons_lemma2, safe)
apply (frule Diff_sing_imp, assumption+)
txt\<open>* LEVEL 17\<close>
apply (subgoal_tac "|Ca| \<le> |Cb|")
 prefer 2
 apply (rule succ_le_imp_le)
 apply (simp add: Fin_into_Finite Finite_imp_succ_cardinal_Diff
                  Fin_into_Finite [THEN Finite_imp_cardinal_cons])
apply (rule_tac C1 = "Ca-{xb}" in Fin_imp_fold_set [THEN exE])
 apply (blast intro: Diff_subset [THEN Fin_subset])
txt\<open>* LEVEL 24 *\<close>
apply (frule Diff1_fold_set, blast, blast)
apply (blast dest!: ftype fold_set.dom_subset [THEN subsetD])
apply (subgoal_tac "ya = f(xb,xa) ")
 prefer 2 apply (blast del: equalityCE)
apply (subgoal_tac "<Cb-{x}, xa> \<in> fold_set(A,B,f,e)")
 prefer 2 apply simp
apply (subgoal_tac "yb = f (x, xa) ")
 apply (drule_tac [2] C = Cb in Diff1_fold_set, simp_all)
  apply (blast intro: fcomm dest!: fold_set.dom_subset [THEN subsetD])
 apply (blast intro: ftype dest!: fold_set.dom_subset [THEN subsetD], blast)
done

lemma (in fold_typing) fold_set_determ:
     "[| <C, x>\<in>fold_set(A, B, f, e);
         <C, y>\<in>fold_set(A, B, f, e)|] ==> y=x"
apply (frule fold_set.dom_subset [THEN subsetD], clarify)
apply (drule Fin_into_Finite)
apply (unfold Finite_def, clarify)
apply (rule_tac n = "succ (n)" in fold_set_determ_lemma)
apply (auto intro: eqpoll_imp_lepoll [THEN lepoll_cardinal_le])
done

(** The fold function **)

lemma (in fold_typing) fold_equality:
     "<C,y> \<in> fold_set(A,B,f,e) ==> fold[B](f,e,C) = y"
apply (unfold fold_def)
apply (frule fold_set.dom_subset [THEN subsetD], clarify)
apply (rule the_equality)
 apply (rule_tac [2] A=C in fold_typing.fold_set_determ)
apply (force dest: fold_set_lemma)
apply (auto dest: fold_set_lemma)
apply (simp add: fold_typing_def, auto)
apply (auto dest: fold_set_lemma intro: ftype etype fcomm)
done

lemma fold_0 [simp]: "e \<in> B ==> fold[B](f,e,0) = e"
apply (unfold fold_def)
apply (blast elim!: empty_fold_setE intro: fold_set.intros)
done

text\<open>This result is the right-to-left direction of the subsequent result\<close>
lemma (in fold_typing) fold_set_imp_cons:
     "[| <C, y> \<in> fold_set(C, B, f, e); C \<in> Fin(A); c \<in> A; c\<notin>C |]
      ==> <cons(c, C), f(c,y)> \<in> fold_set(cons(c, C), B, f, e)"
apply (frule FinD [THEN fold_set_mono, THEN subsetD])
 apply assumption
apply (frule fold_set.dom_subset [of A, THEN subsetD])
apply (blast intro!: fold_set.consI intro: fold_set_mono [THEN subsetD])
done

lemma (in fold_typing) fold_cons_lemma [rule_format]:
"[| C \<in> Fin(A); c \<in> A; c\<notin>C |]
     ==> <cons(c, C), v> \<in> fold_set(cons(c, C), B, f, e) \<longleftrightarrow>
         (\<exists>y. <C, y> \<in> fold_set(C, B, f, e) & v = f(c, y))"
apply auto
 prefer 2 apply (blast intro: fold_set_imp_cons)
 apply (frule_tac Fin.consI [of c, THEN FinD, THEN fold_set_mono, THEN subsetD], assumption+)
apply (frule_tac fold_set.dom_subset [of A, THEN subsetD])
apply (drule FinD)
apply (rule_tac A1 = "cons(c,C)" and f1=f and B1=B and C1=C and e1=e in fold_typing.Fin_imp_fold_set [THEN exE])
apply (blast intro: fold_typing.intro ftype etype fcomm)
apply (blast intro: Fin_subset [of _ "cons(c,C)"] Finite_into_Fin
             dest: Fin_into_Finite)
apply (rule_tac x = x in exI)
apply (auto intro: fold_set.intros)
apply (drule_tac fold_set_lemma [of C], blast)
apply (blast intro!: fold_set.consI
             intro: fold_set_determ fold_set_mono [THEN subsetD]
             dest: fold_set.dom_subset [THEN subsetD])
done

lemma (in fold_typing) fold_cons:
     "[| C\<in>Fin(A); c\<in>A; c\<notin>C|]
      ==> fold[B](f, e, cons(c, C)) = f(c, fold[B](f, e, C))"
apply (unfold fold_def)
apply (simp add: fold_cons_lemma)
apply (rule the_equality, auto)
 apply (subgoal_tac [2] "\<langle>C, y\<rangle> \<in> fold_set(A, B, f, e)")
  apply (drule Fin_imp_fold_set)
apply (auto dest: fold_set_lemma  simp add: fold_def [symmetric] fold_equality)
apply (blast intro: fold_set_mono [THEN subsetD] dest!: FinD)
done

lemma (in fold_typing) fold_type [simp,TC]:
     "C\<in>Fin(A) ==> fold[B](f,e,C):B"
apply (erule Fin_induct)
apply (simp_all add: fold_cons ftype etype)
done

lemma (in fold_typing) fold_commute [rule_format]:
     "[| C\<in>Fin(A); c\<in>A |]
      ==> (\<forall>y\<in>B. f(c, fold[B](f, y, C)) = fold[B](f, f(c, y), C))"
apply (erule Fin_induct)
apply (simp_all add: fold_typing.fold_cons [of A B _ f]
                     fold_typing.fold_type [of A B _ f]
                     fold_typing_def fcomm)
done

lemma (in fold_typing) fold_nest_Un_Int:
     "[| C\<in>Fin(A); D\<in>Fin(A) |]
      ==> fold[B](f, fold[B](f, e, D), C) =
          fold[B](f, fold[B](f, e, (C \<inter> D)), C \<union> D)"
apply (erule Fin_induct, auto)
apply (simp add: Un_cons Int_cons_left fold_type fold_commute
                 fold_typing.fold_cons [of A _ _ f]
                 fold_typing_def fcomm cons_absorb)
done

lemma (in fold_typing) fold_nest_Un_disjoint:
     "[| C\<in>Fin(A); D\<in>Fin(A); C \<inter> D = 0 |]
      ==> fold[B](f,e,C \<union> D) =  fold[B](f, fold[B](f,e,D), C)"
by (simp add: fold_nest_Un_Int)

lemma Finite_cons_lemma: "Finite(C) ==> C\<in>Fin(cons(c, C))"
apply (drule Finite_into_Fin)
apply (blast intro: Fin_mono [THEN subsetD])
done

subsection\<open>The Operator \<^term>\<open>setsum\<close>\<close>

lemma setsum_0 [simp]: "setsum(g, 0) = #0"
by (simp add: setsum_def)

lemma setsum_cons [simp]:
     "Finite(C) ==>
      setsum(g, cons(c,C)) =
        (if c \<in> C then setsum(g,C) else g(c) $+ setsum(g,C))"
apply (auto simp add: setsum_def Finite_cons cons_absorb)
apply (rule_tac A = "cons (c, C)" in fold_typing.fold_cons)
apply (auto intro: fold_typing.intro Finite_cons_lemma)
done

lemma setsum_K0: "setsum((%i. #0), C) = #0"
apply (case_tac "Finite (C) ")
 prefer 2 apply (simp add: setsum_def)
apply (erule Finite_induct, auto)
done

(*The reversed orientation looks more natural, but LOOPS as a simprule!*)
lemma setsum_Un_Int:
     "[| Finite(C); Finite(D) |]
      ==> setsum(g, C \<union> D) $+ setsum(g, C \<inter> D)
        = setsum(g, C) $+ setsum(g, D)"
apply (erule Finite_induct)
apply (simp_all add: Int_cons_right cons_absorb Un_cons Int_commute Finite_Un
                     Int_lower1 [THEN subset_Finite])
done

lemma setsum_type [simp,TC]: "setsum(g, C):int"
apply (case_tac "Finite (C) ")
 prefer 2 apply (simp add: setsum_def)
apply (erule Finite_induct, auto)
done

lemma setsum_Un_disjoint:
     "[| Finite(C); Finite(D); C \<inter> D = 0 |]
      ==> setsum(g, C \<union> D) = setsum(g, C) $+ setsum(g,D)"
apply (subst setsum_Un_Int [symmetric])
apply (subgoal_tac [3] "Finite (C \<union> D) ")
apply (auto intro: Finite_Un)
done

lemma Finite_RepFun [rule_format (no_asm)]:
     "Finite(I) ==> (\<forall>i\<in>I. Finite(C(i))) \<longrightarrow> Finite(RepFun(I, C))"
apply (erule Finite_induct, auto)
done

lemma setsum_UN_disjoint [rule_format (no_asm)]:
     "Finite(I)
      ==> (\<forall>i\<in>I. Finite(C(i))) \<longrightarrow>
          (\<forall>i\<in>I. \<forall>j\<in>I. i\<noteq>j \<longrightarrow> C(i) \<inter> C(j) = 0) \<longrightarrow>
          setsum(f, \<Union>i\<in>I. C(i)) = setsum (%i. setsum(f, C(i)), I)"
apply (erule Finite_induct, auto)
apply (subgoal_tac "\<forall>i\<in>B. x \<noteq> i")
 prefer 2 apply blast
apply (subgoal_tac "C (x) \<inter> (\<Union>i\<in>B. C (i)) = 0")
 prefer 2 apply blast
apply (subgoal_tac "Finite (\<Union>i\<in>B. C (i)) & Finite (C (x)) & Finite (B) ")
apply (simp (no_asm_simp) add: setsum_Un_disjoint)
apply (auto intro: Finite_Union Finite_RepFun)
done

lemma setsum_addf: "setsum(%x. f(x) $+ g(x),C) = setsum(f, C) $+ setsum(g, C)"
apply (case_tac "Finite (C) ")
 prefer 2 apply (simp add: setsum_def)
apply (erule Finite_induct, auto)
done

lemma fold_set_cong:
     "[| A=A'; B=B'; e=e'; (\<forall>x\<in>A'. \<forall>y\<in>B'. f(x,y) = f'(x,y)) |]
      ==> fold_set(A,B,f,e) = fold_set(A',B',f',e')"
apply (simp add: fold_set_def)
apply (intro refl iff_refl lfp_cong Collect_cong disj_cong ex_cong, auto)
done

lemma fold_cong:
"[| B=B'; A=A'; e=e';
    !!x y. [|x\<in>A'; y\<in>B'|] ==> f(x,y) = f'(x,y) |] ==>
   fold[B](f,e,A) = fold[B'](f', e', A')"
apply (simp add: fold_def)
apply (subst fold_set_cong)
apply (rule_tac [5] refl, simp_all)
done

lemma setsum_cong:
 "[| A=B; !!x. x\<in>B ==> f(x) = g(x) |] ==>
     setsum(f, A) = setsum(g, B)"
by (simp add: setsum_def cong add: fold_cong)

lemma setsum_Un:
     "[| Finite(A); Finite(B) |]
      ==> setsum(f, A \<union> B) =
          setsum(f, A) $+ setsum(f, B) $- setsum(f, A \<inter> B)"
apply (subst setsum_Un_Int [symmetric], auto)
done

lemma setsum_zneg_or_0 [rule_format (no_asm)]:
     "Finite(A) ==> (\<forall>x\<in>A. g(x) $\<le> #0) \<longrightarrow> setsum(g, A) $\<le> #0"
apply (erule Finite_induct)
apply (auto intro: zneg_or_0_add_zneg_or_0_imp_zneg_or_0)
done

lemma setsum_succD_lemma [rule_format]:
     "Finite(A)
      ==> \<forall>n\<in>nat. setsum(f,A) = $# succ(n) \<longrightarrow> (\<exists>a\<in>A. #0 $< f(a))"
apply (erule Finite_induct)
apply (auto simp del: int_of_0 int_of_succ simp add: not_zless_iff_zle int_of_0 [symmetric])
apply (subgoal_tac "setsum (f, B) $\<le> #0")
apply simp_all
prefer 2 apply (blast intro: setsum_zneg_or_0)
apply (subgoal_tac "$# 1 $\<le> f (x) $+ setsum (f, B) ")
apply (drule zdiff_zle_iff [THEN iffD2])
apply (subgoal_tac "$# 1 $\<le> $# 1 $- setsum (f,B) ")
apply (drule_tac x = "$# 1" in zle_trans)
apply (rule_tac [2] j = "#1" in zless_zle_trans, auto)
done

lemma setsum_succD:
     "[| setsum(f, A) = $# succ(n); n\<in>nat |]==> \<exists>a\<in>A. #0 $< f(a)"
apply (case_tac "Finite (A) ")
apply (blast intro: setsum_succD_lemma)
apply (unfold setsum_def)
apply (auto simp del: int_of_0 int_of_succ simp add: int_succ_int_1 [symmetric] int_of_0 [symmetric])
done

lemma g_zpos_imp_setsum_zpos [rule_format]:
     "Finite(A) ==> (\<forall>x\<in>A. #0 $\<le> g(x)) \<longrightarrow> #0 $\<le> setsum(g, A)"
apply (erule Finite_induct)
apply (simp (no_asm))
apply (auto intro: zpos_add_zpos_imp_zpos)
done

lemma g_zpos_imp_setsum_zpos2 [rule_format]:
     "[| Finite(A); \<forall>x. #0 $\<le> g(x) |] ==> #0 $\<le> setsum(g, A)"
apply (erule Finite_induct)
apply (auto intro: zpos_add_zpos_imp_zpos)
done

lemma g_zspos_imp_setsum_zspos [rule_format]:
     "Finite(A)
      ==> (\<forall>x\<in>A. #0 $< g(x)) \<longrightarrow> A \<noteq> 0 \<longrightarrow> (#0 $< setsum(g, A))"
apply (erule Finite_induct)
apply (auto intro: zspos_add_zspos_imp_zspos)
done

lemma setsum_Diff [rule_format]:
     "Finite(A) ==> \<forall>a. M(a) = #0 \<longrightarrow> setsum(M, A) = setsum(M, A-{a})"
apply (erule Finite_induct)
apply (simp_all add: Diff_cons_eq Finite_Diff)
done

end


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

section \<open>Plurality Module\<close>

theory Plurality_Module
  imports "Component_Types/Electoral_Module"
begin

text
\<open>The plurality module implements the plurality voting rule.
The plurality rule elects all modules with the maximum amount of top
preferences among all alternatives, and rejects all the other alternatives.
It is electing and induces the classical plurality (voting) rule
from social-choice theory.\<close>

subsection \<open>Definition\<close>

fun plurality :: "'a Electoral_Module" where
  "plurality A p =
    ({a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a},
     {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a},
     {})"

subsection \<open>Soundness\<close>

theorem plurality_sound[simp]: "electoral_module plurality"
proof -
  have
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    elect \<inter> reject = {}"
    by auto
  hence disjoint:
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    disjoint3 (elect, reject, {})"
    by simp
  have
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    elect \<union> reject = A"
    using not_le_imp_less
    by auto
  hence unity:
    "\<forall>A p.
      let elect = {a \<in> (A::'a set). \<forall>x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a} in
    set_equals_partition A (elect, reject, {})"
    by simp
  from disjoint unity show ?thesis
    by (simp add: electoral_modI)
qed

subsection \<open>Electing\<close>

lemma plurality_electing2: "\<forall>A p.
                              (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow>
                                elect plurality A p \<noteq> {}"
proof (intro allI impI conjI)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    assm0: "A \<noteq> {} \<and> finite_profile A p"
  show
    "elect plurality A p \<noteq> {}"
  proof
    obtain max where
      max: "max = Max(win_count p ` A)"
      by simp
    then obtain a where
      a: "win_count p a = max \<and> a \<in> A"
      using Max_in assm0 empty_is_image
            finite_imageI imageE
      by (metis (no_types, lifting))
    hence
      "\<forall>x \<in> A. win_count p x \<le> win_count p a"
      by (simp add: max assm0)
    moreover have
      "a \<in> A"
      using a
      by simp
    ultimately have
      "a \<in> {a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a}"
      by blast
    hence a_elem:
      "a \<in> elect plurality A p"
      by simp
    assume
      assm1: "elect plurality A p = {}"
    thus "False"
      using a_elem assm1 all_not_in_conv
      by metis
  qed
qed

(*The plurality module is electing.*)
theorem plurality_electing[simp]: "electing plurality"
proof -
  have "electoral_module plurality \<and>
      (\<forall>A p. (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow> elect plurality A p \<noteq> {})"
  proof
    show "electoral_module plurality"
      by simp
  next
    show "(\<forall>A p. (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow> elect plurality A p \<noteq> {})"
      using plurality_electing2
      by metis
  qed
  thus ?thesis
      by (simp add: electing_def)
qed

subsection \<open>Property\<close>

lemma plurality_inv_mono2: "\<forall>A p q a.
                              (a \<in> elect plurality A p \<and> lifted A p q a) \<longrightarrow>
                                (elect plurality A q = elect plurality A p \<or>
                                    elect plurality A q = {a})"
proof (intro allI impI)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a"
  assume asm1:
    "a \<in> elect plurality A p \<and> lifted A p q a"
  have ab1: "\<forall>a b. (a::'a) \<notin> {b} \<or> a = b"
    by force
  have lifted_winner:
    "\<forall>x \<in> A.
      \<forall>i::nat. i < length p \<longrightarrow>
        (above (p!i) x = {x} \<longrightarrow>
          (above (q!i) x = {x} \<or> above (q!i) a = {a}))"
    using asm1 Profile.lifted_def lifted_above_winner
    by (metis (no_types, lifting))
  hence
    "\<forall>i::nat. i < length p \<longrightarrow>
      (above (p!i) a = {a} \<longrightarrow> above (q!i) a = {a})"
    using asm1
    by auto
  hence a_win_subset:
    "{i::nat. i < length p \<and> above (p!i) a = {a}} \<subseteq>
      {i::nat. i < length p \<and> above (q!i) a = {a}}"
    by blast
  moreover have sizes:
    "length p = length q"
    using asm1 Profile.lifted_def
    by metis
  ultimately have win_count_a:
    "win_count p a \<le> win_count q a"
    by (simp add: card_mono)
  have fin_A:
    "finite A"
    using asm1 Profile.lifted_def
    by metis
  hence
    "\<forall>x \<in> A-{a}.
      \<forall>i::nat. i < length p \<longrightarrow>
        (above (q!i) a = {a} \<longrightarrow> above (q!i) x \<noteq> {x})"
    using DiffE Profile.lifted_def above_one2
          asm1 insertCI insert_absorb insert_not_empty
          profile_def sizes
    by metis
  with lifted_winner
  have above_QtoP:
    "\<forall>x \<in> A-{a}.
      \<forall>i::nat. i < length p \<longrightarrow>
        (above (q!i) x = {x} \<longrightarrow> above (p!i) x = {x})"
    using lifted_above_winner3 asm1
          Profile.lifted_def
    by metis
  hence
    "\<forall>x \<in> A-{a}.
      {i::nat. i < length p \<and> above (q!i) x = {x}} \<subseteq>
        {i::nat. i < length p \<and> above (p!i) x = {x}}"
    by (simp add: Collect_mono)
  hence win_count_other:
    "\<forall>x \<in> A-{a}. win_count p x \<ge> win_count q x"
    by (simp add: card_mono sizes)
  show
    "elect plurality A q = elect plurality A p \<or>
      elect plurality A q = {a}"
  proof cases
    assume "win_count p a = win_count q a"
    hence
      "card {i::nat. i < length p \<and> above (p!i) a = {a}} =
        card {i::nat. i < length p \<and> above (q!i) a = {a}}"
      by (simp add: sizes)
    moreover have
      "finite {i::nat. i < length p \<and> above (q!i) a = {a}}"
      by simp
    ultimately have
      "{i::nat. i < length p \<and> above (p!i) a = {a}} =
        {i::nat. i < length p \<and> above (q!i) a = {a}}"
      using a_win_subset
      by (simp add: card_subset_eq)
    hence above_pq:
      "\<forall>i::nat. i < length p \<longrightarrow>
        above (p!i) a = {a} \<longleftrightarrow> above (q!i) a = {a}"
      by blast
    hence above_pq2:
      "\<forall>n. \<not> n < length p \<or>
        (above (p!n) a = {a}) = (above (q!n) a = {a})"
      by presburger
    moreover have
      "\<forall>x \<in> A-{a}.
        \<forall>i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow>
            (above (q!i) x = {x} \<or> above (q!i) a = {a}))"
      using lifted_winner
      by auto
    moreover have
      "\<forall>x \<in> A-{a}.
        \<forall>i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow> above (p!i) a \<noteq> {a})"
    proof (rule ccontr, simp, safe, simp)
      fix
        x :: "'a" and
        i :: "nat"
      assume
        x_in_A: "x \<in> A" and
        i_in_range: "i < length p" and
        abv_x: "above (p!i) x = {x}" and
        abv_a: "above (p!i) a = {a}"
      have not_empty:
        "A \<noteq> {}"
        using x_in_A
        by auto
      have
        "linear_order_on A (p!i)"
        using Profile.lifted_def asm1 i_in_range profile_def
        by (metis (no_types))
      thus "x = a"
        using not_empty abv_a abv_x fin_A
        by (simp add: above_one2)
    qed
    ultimately have above_PtoQ:
      "\<forall>x \<in> A-{a}.
        \<forall>i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow> above (q!i) x = {x})"
      by (simp add: above_pq)
    hence
      "\<forall>x \<in> A.
        card {i::nat. i < length p \<and> above (p!i) x = {x}} =
          card {i::nat. i < length q \<and> above (q!i) x = {x}}"
    proof (safe)
      fix
        x :: "'a"
      assume
        "\<forall>y \<in> A-{a}. \<forall> i<length p.
          above (p!i) y = {y} \<longrightarrow> above (q!i) y = {y}" and
        x_in_A: "x \<in> A"
      show
        "card {i. i < length p \<and> above (p ! i) x = {x}} =
          card {i. i < length q \<and> above (q ! i) x = {x}}"
        using DiffI x_in_A ab1 above_PtoQ above_QtoP above_pq2 sizes
        by (metis (no_types, lifting))
    qed
    hence "\<forall>x \<in> A. win_count p x = win_count q x"
      by simp
    hence
      "{a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a} =
        {a \<in> A. \<forall>x \<in> A. win_count q x \<le> win_count q a}"
      by auto
    thus ?thesis
      by simp
  next
    assume "win_count p a \<noteq> win_count q a"
    hence strict_less:
      "win_count p a < win_count q a"
      using win_count_a
      by auto
    have a_in_win_p:
      "a \<in> {a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a}"
      using asm1
      by auto
    hence "\<forall>x \<in> A. win_count p x \<le> win_count p a"
      by simp
    with strict_less win_count_other
    have less:
      "\<forall>x \<in> A-{a}. win_count q x < win_count q a"
      using DiffD1 antisym dual_order.trans
            not_le_imp_less win_count_a
      by metis
    hence
      "\<forall>x \<in> A-{a}. \<not>(\<forall>y \<in> A. win_count q y \<le> win_count q x)"
      using asm1 Profile.lifted_def not_le
      by metis
    hence
      "\<forall>x \<in> A-{a}.
        x \<notin> {a \<in> A. \<forall>x \<in> A. win_count q x \<le> win_count q a}"
      by blast
    hence
      "\<forall>x \<in> A-{a}. x \<notin> elect plurality A q"
      by simp
    moreover have
      "a \<in> elect plurality A q"
    proof -
      from less
      have
        "\<forall>x \<in> A-{a}. win_count q x \<le> win_count q a"
        using less_imp_le
        by metis
      moreover have
        "win_count q a \<le> win_count q a"
        by simp
      ultimately have
        "\<forall>x \<in> A. win_count q x \<le> win_count q a"
        by auto
      moreover have
        "a \<in> A"
        using a_in_win_p
        by auto
      ultimately have
        "a \<in> {a \<in> A.
            \<forall>x \<in> A. win_count q x \<le> win_count q a}"
        by auto
      thus ?thesis
        by simp
    qed
    moreover have
      "elect plurality A q \<subseteq> A"
      by simp
    ultimately show ?thesis
      by auto
  qed
qed

(*The plurality rule is invariant monotone.*)
theorem plurality_inv_mono[simp]: "invariant_monotonicity plurality"
proof -
  have
    "electoral_module plurality \<and>
      (\<forall>A p q a.
        (a \<in> elect plurality A p \<and> lifted A p q a) \<longrightarrow>
          (elect plurality A q = elect plurality A p \<or>
            elect plurality A q = {a}))"
  proof
    show "electoral_module plurality"
      by simp
  next
    show
      "\<forall>A p q a. (a \<in> elect plurality A p \<and> lifted A p q a) \<longrightarrow>
          (elect plurality A q = elect plurality A p \<or>
            elect plurality A q = {a})"
      using plurality_inv_mono2
      by metis
  qed
  thus ?thesis
    by (simp add: invariant_monotonicity_def)
qed

end


chapter \<open>Deadlock Free Transition Systems\<close>
theory DF_System
imports Main
begin
  text \<open>
    Theories to describe deadlock free transitions system and
    simulations between them.

    We added these locales after the competition, in order to get a cleaner
    solution for Challenge~3. This theory provides not much more than what is
    needed for solving the challenge.
  \<close>

  section \<open>Transition System\<close>
  locale system =
    fixes s\<^sub>0 :: 's
      and lstep :: "'l \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> bool"
  begin
    abbreviation "step s s' \<equiv> \<exists>l. lstep l s s'"
    definition "reachable \<equiv> (step\<^sup>*\<^sup>*) s\<^sub>0"

    definition "can_step l s \<equiv> \<exists>s'. lstep l s s'"

  end

  section \<open>Deadlock Free Transition System\<close>
  locale df_system = system +
    assumes no_deadlock: "reachable s \<Longrightarrow> \<exists>s'. step s s'"
  begin

    paragraph \<open>Runs\<close>
    definition "is_lrun l s \<equiv> s 0 = s\<^sub>0 \<and> (\<forall>i. lstep (l i) (s i) (s (Suc i)))"
    definition "is_run s \<equiv> \<exists>l. is_lrun l s"

    paragraph \<open>Weak Fairness\<close>
    definition "is_lfair ls ss \<equiv> \<forall>l i. \<exists>j\<ge>i. \<not>can_step l (ss j) \<or> ls j = l"
    definition "is_fair_run s \<equiv> \<exists>l. is_lrun l s \<and> is_lfair l s"

    text \<open>Definitions of runs. Used e.g. to clarify TCB of lemmas over systems.\<close>
    lemmas run_definitions = is_lrun_def is_run_def is_lfair_def is_fair_run_def

    lemma is_run_alt: "is_run s \<longleftrightarrow> s 0 = s\<^sub>0 \<and> (\<forall>i. step (s i) (s (Suc i)))"
      unfolding is_run_def is_lrun_def by metis

    definition "rstep l s i \<equiv> lstep l (s i) (s (Suc i))"

    lemma fair_run_is_run: "is_fair_run s \<Longrightarrow> is_run s"
      using is_fair_run_def is_run_def by blast

    text \<open>Weaker fairness criterion, used internally in proofs only.\<close>
    definition "is_fair' s \<equiv> \<forall>l i. \<exists>j\<ge>i. \<not>can_step l (s j) \<or> rstep l s j"

    lemma fair_run_is_fair': "is_fair_run s \<Longrightarrow> is_fair' s"
      unfolding is_fair_run_def is_run_def is_lrun_def is_fair'_def is_lfair_def rstep_def
      by metis

  end

  subsection \<open>Run\<close>
  locale run = df_system +
    fixes s
    assumes RUN: "is_run s"
  begin
    lemma run0[simp]: "s 0 = s\<^sub>0" using RUN
      by (auto simp: is_run_alt)

    lemma run_reachable[simp]: "reachable (s i)"
      apply (induction i)
      using RUN
      apply simp_all
      unfolding is_run_alt reachable_def
      by (auto simp: rtranclp.rtrancl_into_rtrancl)

    lemma run_invar: "is_invar I \<Longrightarrow> I (s i)"
      using run_reachable invar_reachable by blast

    lemma stepE: obtains l where "lstep l (s i) (s (Suc i))"
      using RUN by (auto simp: is_run_alt)

  end

  subsection \<open>Fair Run\<close>
  locale fair_run = df_system +
    fixes s
    assumes FAIR: "is_fair_run s"
  begin
    sublocale run
      apply unfold_locales
      using FAIR fair_run_is_run by blast

    definition "next_step_of l i \<equiv> LEAST j. j\<ge>i \<and> (\<not>can_step l (s j) \<or> rstep l s j)"

    lemma next_step_step:
      fixes i l
      defines "j\<equiv>next_step_of l i"
      shows "j \<ge> i \<and> (\<not>can_step l (s j) \<or> rstep l s j)"
      using fair_run_is_fair'[OF FAIR] unfolding is_fair'_def
      unfolding next_step_of_def j_def
      apply -
      using LeastI_ex[where P="\<lambda>j. j\<ge>i \<and> (\<not>can_step l (s j) \<or> rstep l s j)"]
      by (auto)

    definition "dist_step l i \<equiv> next_step_of l i - i"

    lemma nso_nostep: "\<lbrakk> \<not>rstep l s i; can_step l (s i)\<rbrakk>
      \<Longrightarrow> next_step_of l (Suc i) = next_step_of l i"
      unfolding next_step_of_def
      by (metis (full_types) Suc_leD dual_order.antisym not_less_eq_eq)

    lemma rstep_cases:
      assumes "can_step l (s i)"
      obtains
        (other) l' where "l\<noteq>l'" "\<not>rstep l s i" "rstep l' s i" "dist_step l (Suc i) < dist_step l i"
      | (this) "rstep l s i"
      apply (cases "rstep l s i"; clarsimp)
      apply (drule nso_nostep)
      unfolding dist_step_def using assms
      apply blast
      by (metis RUN diff_commute diff_diff_cancel is_run_alt less_Suc_eq next_step_step rstep_def that(2) zero_less_diff)

  end

  section \<open>Simulation\<close>
  locale simulation =
    A: df_system as\<^sub>0 alstep + C: df_system cs\<^sub>0 clstep
      for as\<^sub>0 :: 'a
      and alstep :: "'l \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
      and cs\<^sub>0 :: 'c
      and clstep :: "'l \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> bool"
  + fixes R
    assumes xfer_reachable_aux: "C.reachable c \<Longrightarrow> \<exists>a. R a c \<and> A.reachable a" (* TODO: Redundant, can be derived from xfer_run. *)
    assumes xfer_run_aux: "C.is_run cs \<Longrightarrow> \<exists>as. (\<forall>i. R (as i) (cs i)) \<and> A.is_run as"
    assumes xfer_fair_run_aux: "C.is_fair_run cs \<Longrightarrow> \<exists>as. (\<forall>i. R (as i) (cs i)) \<and> A.is_fair_run as"
  begin
    lemma xfer_reachable:
      assumes "C.reachable cs"
      obtains as where "R as cs" "A.reachable as"
      using assms xfer_reachable_aux by auto

    lemma xfer_run:
      assumes CRUN: "C.is_run cs"
      obtains as where "A.is_run as" "\<forall>i. R (as i) (cs i)"
      using xfer_run_aux assms by blast

    lemma xfer_fair_run:
      assumes FAIR: "C.is_fair_run cs"
      obtains as where "A.is_fair_run as" "\<forall>i. R (as i) (cs i)"
      using xfer_fair_run_aux assms by blast

  end

  lemma sim_trans:
    assumes "simulation as\<^sub>0 alstep bs\<^sub>0 blstep R\<^sub>1"
    assumes "simulation bs\<^sub>0 blstep cs\<^sub>0 clstep R\<^sub>2"
    shows "simulation as\<^sub>0 alstep cs\<^sub>0 clstep (R\<^sub>1 OO R\<^sub>2)"
    using assms
    unfolding simulation_def simulation_axioms_def
    by (auto simp: OO_def; metis)

  (* Locale to introduce simulation by local argument *)
  locale simulationI =
    A: df_system as\<^sub>0 alstep + C: system cs\<^sub>0 clstep
      for as\<^sub>0 :: 'a
      and alstep :: "'l \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
      and cs\<^sub>0 :: 'c
      and clstep :: "'l \<Rightarrow> 'c \<Rightarrow> 'c \<Rightarrow> bool"
  + fixes R
    assumes sim0: "R as\<^sub>0 cs\<^sub>0"
    assumes sims: "\<lbrakk>A.reachable as; C.reachable cs; R as cs; clstep l cs cs'\<rbrakk>
      \<Longrightarrow> \<exists>as'. R as' cs' \<and> alstep l as as'"
    assumes simb: "\<lbrakk>A.reachable as; C.reachable cs; R as cs; A.can_step l as\<rbrakk> \<Longrightarrow> C.can_step l cs"
  begin

    lemma simb': "\<lbrakk>A.reachable as; C.reachable cs; R as cs\<rbrakk> \<Longrightarrow> C.can_step l cs \<longleftrightarrow> A.can_step l as"
      using simb sims
      by (fastforce simp: A.can_step_def C.can_step_def)

    lemma xfer_reachable_aux2:
      assumes "C.reachable cs"
      obtains as where "R as cs" "A.reachable as"
    proof -
      from assms have "\<exists>as. R as cs \<and> A.reachable as"
        unfolding C.reachable_def
        apply (induction)
        subgoal using sim0 A.reachable0 by blast
        apply clarify
        subgoal for cs cs' l as
          using sims[of as cs l cs']
          by (auto simp: C.reachable_def A.reachable_def intro: rtranclp.rtrancl_into_rtrancl)
        done
      with that show ?thesis by blast
    qed

    sublocale C: df_system cs\<^sub>0 clstep
      apply unfold_locales
      by (metis A.no_deadlock xfer_reachable_aux2 simb system.can_step_def)

    context begin
      private primrec arun where
        "arun cl cs 0 = as\<^sub>0"
      | "arun cl cs (Suc i) = (SOME as. C.rstep (cl i) cs i \<and> alstep (cl i) (arun cl cs i) as  \<and> R as (cs (Suc i)))"

      lemma xfer_lrun_aux2:
        assumes CRUN: "C.is_lrun cl cs"
        obtains as where "A.is_lrun cl as" "\<forall>i. R (as i) (cs i)"
      proof -
        from CRUN have "C.is_run cs" by (auto simp: C.is_run_def)

        interpret C: run cs\<^sub>0 clstep cs
          by unfold_locales fact

        have X1: "alstep (cl i) (arun cl cs i) (arun cl cs (Suc i)) \<and> A.reachable (arun cl cs i) \<and> R (arun cl cs (Suc i)) (cs (Suc i))" for i
        proof (induction i rule: nat_less_induct)
          case (1 i)

          have CR: "C.reachable (cs i)" using C.run_reachable .
          have CS: "clstep (cl i) (cs i) (cs (Suc i))"
            using CRUN by (auto simp: C.is_lrun_def)

          have AX: "A.reachable (arun cl cs i) \<and> R (arun cl cs i) (cs i)"
          proof (cases i)
            case 0
            then show ?thesis by (auto simp: CRUN sim0)
          next
            case [simp]: (Suc i')

            from "1.IH"[THEN spec, of i'] show ?thesis
              by (auto simp del: arun.simps simp: A.reachable_def
                intro: rtranclp.rtrancl_into_rtrancl)
          qed

          from sims[OF _ CR _ CS, of "arun cl cs i"] AX obtain asi where
            "R asi (cs (Suc i))" "alstep (cl i) (arun cl cs i) asi" by auto

          then show ?case
            apply simp
            apply (rule someI2)
            using CS by (auto simp: C.rstep_def AX)
        qed
        hence "R (arun cl cs i) (cs i)" for i
          apply (cases i) using sim0
          by (auto simp: CRUN)
        with X1 show ?thesis
          apply (rule_tac that[of "arun cl cs"])
          by (auto simp: A.is_lrun_def)
      qed
    end

    lemma xfer_run_aux2:
      assumes CRUN: "C.is_run cs"
      obtains as where "A.is_run as" "\<forall>i. R (as i) (cs i)"
      by (meson A.is_run_def C.is_run_def assms xfer_lrun_aux2)

    lemma xfer_fair_run_aux2:
      assumes FAIR: "C.is_fair_run cs"
      obtains as where "A.is_fair_run as" "\<forall>i. R (as i) (cs i)"
    proof -
      from FAIR obtain cl where
        CLRUN: "C.is_lrun cl cs" and
        CFAIR: "C.is_lfair cl cs"
        by (auto simp: C.is_fair_run_def)

      from xfer_lrun_aux2[OF CLRUN] obtain as where
        ALRUN: "A.is_lrun cl as" and SIM: "\<forall>i. R (as i) (cs i)" .

      interpret A: run as\<^sub>0 alstep as
              + C: run cs\<^sub>0 clstep cs
        apply (unfold_locales)
        using ALRUN CLRUN
        by (auto simp: A.is_run_def C.is_run_def)

      have "A.is_lfair cl as"
        unfolding A.is_lfair_def
        by (metis A.run_reachable C.is_lfair_def C.run_reachable CFAIR SIM simb')
      with ALRUN SIM that show ?thesis unfolding A.is_fair_run_def by blast
    qed

    sublocale simulation
      apply unfold_locales
      using xfer_reachable_aux2 apply blast
      using xfer_run_aux2 apply blast
      using xfer_fair_run_aux2 apply blast
      done

  end

end


theory Common
  imports Main "HOL-Library.Mapping"
begin

fun mfold :: "('k :: linorder, 'v) mapping \<Rightarrow> ('k \<times> 'v \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> 'c \<Rightarrow> 'c" where
"mfold m r i =
  (let f = \<lambda>k a. r (k, the (Mapping.lookup m k)) a in foldr f (Mapping.ordered_keys m) i)"
(*
fun mfold :: "('a :: linorder \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> 'c \<Rightarrow> 'c" where
"mfold m f i = (let v = sorted_list_of_set (dom m);
                    z = zip v (map (the \<circ> m) v)
                in fold f z i)"
 *)
(* https://stackoverflow.com/questions/28633353/converting-a-set-to-a-list-in-isabelle *)
definition set_to_list :: "'a set \<Rightarrow> 'a list"
  where "set_to_list s = (SOME l. set l = s)"

lemma  set_set_to_list:
   "finite s \<Longrightarrow> set (set_to_list s) = s"
  unfolding set_to_list_def by (metis (mono_tags) finite_list some_eq_ex)

end


section \<open>Underlying FSM Representation\<close>

text \<open>This theory contains the underlying datatype for (possibly not well-formed) finite state
      machines that is restricted to well-formed finite state machines in later theories.\<close>

theory FSM_Impl
  imports Util Datatype_Order_Generator.Order_Generator
begin

text \<open>A finite state machine (FSM) is represented using its classical definition:\<close>

record ('state, 'input, 'output) fsm_impl =
  initial :: 'state
  nodes :: "'state set"
  inputs  :: "'input set"
  outputs  :: "'output set"
  transitions :: "('state \<times> 'input \<times> 'output \<times> 'state) set"

subsection \<open>Types for Transitions and Paths\<close>

type_synonym ('a,'b,'c) transition = "('a \<times> 'b \<times> 'c \<times> 'a)"
type_synonym ('a,'b,'c) path = "('a,'b,'c) transition list"

abbreviation "t_source (a :: ('a,'b,'c) transition) \<equiv> fst a"
abbreviation "t_input  (a :: ('a,'b,'c) transition) \<equiv> fst (snd a)"
abbreviation "t_output (a :: ('a,'b,'c) transition) \<equiv> fst (snd (snd a))"
abbreviation "t_target (a :: ('a,'b,'c) transition) \<equiv> snd (snd (snd a))"

subsection \<open>Basic Algorithms on FSM\<close>

subsubsection \<open>Reading FSMs from Lists\<close>

fun fsm_impl_from_list :: "'a \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list \<Rightarrow> ('a, 'b, 'c) fsm_impl" where
  "fsm_impl_from_list q [] = \<lparr> initial = q, nodes = {q}, inputs = {}, outputs = {}, transitions = {} \<rparr>" |
  "fsm_impl_from_list q (t#ts) = (let ts' = set (t#ts)
                                   in \<lparr> initial = t_source t
                                      , nodes = (image t_source ts') \<union> (image t_target ts')
                                      , inputs = image t_input ts'
                                      , outputs = image t_output ts'
                                      , transitions = ts' \<rparr>)"

fun fsm_impl_from_list' :: "'a \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) list \<Rightarrow> ('a, 'b, 'c) fsm_impl" where
  "fsm_impl_from_list' q [] = \<lparr> initial = q, nodes = {q}, inputs = {}, outputs = {}, transitions = {} \<rparr>" |
  "fsm_impl_from_list' q (t#ts) = (let tsr = (remdups (t#ts))
                                   in \<lparr> initial = t_source t
                                      , nodes = set (remdups ((map t_source tsr) @ (map t_target tsr)))
                                      , inputs = set (remdups (map t_input tsr))
                                      , outputs = set (remdups (map t_output tsr))
                                      , transitions = set tsr \<rparr>)"

lemma fsm_impl_from_list_code[code] :
  "fsm_impl_from_list q ts = fsm_impl_from_list' q ts"
  by (cases ts; auto)

subsubsection \<open>Changing the initial State\<close>

fun from_FSM :: "('a,'b,'c) fsm_impl \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "from_FSM M q = (if q \<in> nodes M then \<lparr> initial = q, nodes = nodes M, inputs = inputs M, outputs = outputs M, transitions = transitions M \<rparr> else M)"

subsubsection \<open>Product Construction\<close>

fun product :: "('a,'b,'c) fsm_impl \<Rightarrow> ('d,'b,'c) fsm_impl \<Rightarrow> ('a \<times> 'd,'b,'c) fsm_impl" where
  "product A B = \<lparr> initial = (initial A, initial B),
                   nodes   = (nodes A) \<times> (nodes B),
                   inputs  = inputs A \<union> inputs B,
                   outputs  = outputs A \<union> outputs B,
                   transitions = {((qA,qB),x,y,(qA',qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B} \<rparr>"

lemma product_code_naive[code] :
  "product A B = \<lparr> initial = (initial A, initial B),
                   nodes   = (nodes A) \<times> (nodes B) ,
                   inputs  = inputs A \<union> inputs B,
                   outputs  = outputs A \<union> outputs B,
                   transitions = image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) (Set.filter (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . x = x' \<and> y = y') (\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A)))) \<rparr>"
  (is "?P1 = ?P2")
proof -
  have "(\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A))) = {(tA,tB) | tA tB . tA \<in> transitions A \<and> tB \<in> transitions B}"
    by auto
  then have "(Set.filter (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . x = x' \<and> y = y') (\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A)))) = {((qA,x,y,qA'),(qB,x,y,qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
    by auto
  then have "image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) (Set.filter (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . x = x' \<and> y = y') (\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A))))
              = image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) {((qA,x,y,qA'),(qB,x,y,qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
    by auto
  moreover have "image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) {((qA,x,y,qA'),(qB,x,y,qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B} =  {((qA,qB),x,y,(qA',qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
    by force
  ultimately have "transitions ?P1 = transitions ?P2"
    unfolding product.simps by auto
  moreover have "initial ?P1 = initial ?P2" by auto
  moreover have "nodes ?P1 = nodes ?P2" by auto
  moreover have "inputs ?P1 = inputs ?P2" by auto
  moreover have "outputs ?P1 = outputs ?P2" by auto
  ultimately show ?thesis by auto
qed

subsubsection \<open>Filtering Transitions\<close>

fun filter_transitions :: "('a,'b,'c) fsm_impl \<Rightarrow> (('a \<times> 'b \<times> 'c \<times> 'a) \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "filter_transitions M P = \<lparr> initial = initial M
                            , nodes = nodes M
                            , inputs = inputs M
                            , outputs = outputs M
                            , transitions = Set.filter P (transitions M) \<rparr>"

subsubsection \<open>Filtering Nodes\<close>

fun filter_nodes :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "filter_nodes M P = (if P (initial M) then \<lparr> initial = initial M
                                              , nodes = Set.filter P (nodes M)
                                              , inputs = inputs M
                                              , outputs = outputs M
                                              , transitions = Set.filter (\<lambda> t . P (t_source t) \<and> P (t_target t)) (transitions M) \<rparr>
                                         else M)"

subsubsection \<open>Initial Singleton FSM (For Trivial Preamble)\<close>

fun initial_singleton :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "initial_singleton M = \<lparr> initial = initial M,
                           nodes = {initial M},
                           inputs = inputs M,
                           outputs = outputs M,
                           transitions = {} \<rparr>"

subsubsection \<open>Canonical Separator\<close>

abbreviation "shift_Inl t \<equiv> (Inl (t_source t),t_input t, t_output t, Inl (t_target t))"

definition shifted_transitions :: "(('a \<times> 'a) \<times> 'b \<times> 'c \<times> ('a \<times> 'a)) set \<Rightarrow> ((('a \<times> 'a) + 'd) \<times> 'b \<times> 'c \<times> (('a \<times> 'a) + 'd)) set" where
  "shifted_transitions ts = image shift_Inl ts"

definition distinguishing_transitions :: "(('a \<times> 'b) \<Rightarrow> 'c set) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'b set \<Rightarrow> ((('a \<times> 'a) + 'a) \<times> 'b \<times> 'c \<times> (('a \<times> 'a) + 'a)) set" where
  "distinguishing_transitions f q1 q2 nodeSet inputSet = \<Union> (Set.image (\<lambda>((q1',q2'),x) .
                                                                (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr q1)) (f (q1',x) - f (q2',x)))
                                                                \<union> (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr q2)) (f (q2',x) - f (q1',x))))
                                                            (nodeSet \<times> inputSet))"

(* Note: parameter P is added to allow usage of different restricted versions of the product machine *)
fun canonical_separator' :: "('a,'b,'c) fsm_impl \<Rightarrow> (('a \<times> 'a),'b,'c) fsm_impl \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> (('a \<times> 'a) + 'a,'b,'c) fsm_impl" where
  "canonical_separator' M P q1 q2 = (if initial P = (q1,q2)
  then
    (let f'  = set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M));
         f   = (\<lambda>qx . (case f' qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}));
         shifted_transitions' = shifted_transitions (transitions P);
         distinguishing_transitions_lr = distinguishing_transitions f q1 q2 (nodes P) (inputs P);
         ts = shifted_transitions' \<union> distinguishing_transitions_lr
     in

      \<lparr> initial = Inl (q1,q2)
      , nodes = (image Inl (nodes P)) \<union> {Inr q1, Inr q2}
      , inputs = inputs M \<union> inputs P
      , outputs = outputs M \<union> outputs P
      , transitions = ts \<rparr>)
  else \<lparr> initial = Inl (q1,q2), nodes = {Inl (q1,q2)}, inputs = {}, outputs = {}, transitions = {}\<rparr>)"

subsubsection \<open>Generalised Canonical Separator\<close>

text \<open>A variation on the state separator that uses states @{text "L"} and @{text "R"} instead of
      @{text "Inr q1"} and @{text "Inr q2"} to indicate targets of transitions in the
      canonical separator that are available only for the left or right component of a state pair\<close>

text \<open>Note: this definition of a canonical separator might serve as a way to avoid recalculation
            of state separators for different pairs of states, but is currently not fully
            implemented\<close>

datatype LR = Left | Right
derive linorder LR

definition distinguishing_transitions_LR :: "(('a \<times> 'b) \<Rightarrow> 'c set) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'b set \<Rightarrow> ((('a \<times> 'a) + LR) \<times> 'b \<times> 'c \<times> (('a \<times> 'a) + LR)) set" where
  "distinguishing_transitions_LR f nodeSet inputSet = \<Union> (Set.image (\<lambda>((q1',q2'),x) .
                                                                (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr Left)) (f (q1',x) - f (q2',x)))
                                                                \<union> (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr Right)) (f (q2',x) - f (q1',x))))
                                                            (nodeSet \<times> inputSet))"

fun canonical_separator_complete' :: "('a,'b,'c) fsm_impl \<Rightarrow> (('a \<times> 'a) + LR,'b,'c) fsm_impl" where
  "canonical_separator_complete' M =
    (let P = product M M;
         f'  = set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M));
         f   = (\<lambda>qx . (case f' qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}));
         shifted_transitions' = shifted_transitions (transitions P);
         distinguishing_transitions_lr = distinguishing_transitions_LR f (nodes P) (inputs P);
         ts = shifted_transitions' \<union> distinguishing_transitions_lr
     in
      \<lparr> initial = Inl (initial P)
      , nodes = (image Inl (nodes P)) \<union> {Inr Left, Inr Right}
      , inputs = inputs M \<union> inputs P
      , outputs = outputs M \<union> outputs P
      , transitions = ts \<rparr>)"

subsubsection \<open>Adding Transitions\<close>

fun add_transitions :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'a) set \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "add_transitions M ts = (if (\<forall> t \<in> ts . t_source t \<in> nodes M \<and> t_input t \<in> inputs M \<and> t_output t \<in> outputs M \<and> t_target t \<in> nodes M)
    then  M\<lparr> transitions := transitions M \<union> ts\<rparr>
    else M)"

subsubsection \<open>Creating an FSM without transitions\<close>

fun create_unconnected_fsm :: "'a \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "create_unconnected_fsm q ns ins outs = (if (finite ns \<and> finite ins \<and> finite outs)
    then \<lparr> initial = q, nodes = insert q ns, inputs = ins, outputs = outs, transitions = {} \<rparr>
    else \<lparr> initial = q, nodes = {q}, inputs = {}, outputs = {}, transitions = {} \<rparr>)"

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_36
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun takeWhile :: "('a => bool) => 'a list => 'a list" where
"takeWhile x (nil2) = nil2"
| "takeWhile x (cons2 z xs) =
     (if x z then cons2 z (takeWhile x xs) else nil2)"

theorem property0 :(* Similar to TIP_prop_36 *)
  "((takeWhile (% (x :: 'a) => True) xs) = xs)"
  find_proof DInd
  apply (induct xs)(*xs is optional*)
  apply auto
  done

end


theory T180
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end