theory "HoareTripleForMemory"

imports  "../lem/Evm" "Hoare"
 "HoareTripleForInstructions"
 "HoareTripleForStorage"

begin

definition memory :: "w256 \<Rightarrow> w256 \<Rightarrow> state_element set_pred" where
"memory ind w = memory_range ind (word_rsplit w)"

lemma memory_range_elms_cut_memory2 :
  "length lst = unat in_size \<Longrightarrow>
   memory_range_elms in_begin lst \<subseteq> variable_ctx_as_set x1 \<Longrightarrow>
   cut_memory in_begin in_size (vctx_memory x1) = lst"
using memory_range_elms_cut_memory by force

lemma word_length : "length (word_rsplit (w::w256) :: 8 word list) = 32"
apply(rule length_word_rsplit_even_size)
apply(auto simp:word_size)
done

lemma word_32 : "unat (32::w256) = 32"
apply auto
done

lemma memory_word_meaning :
  "memory_range_elms memaddr (word_rsplit (table::w256))
          \<subseteq> variable_ctx_as_set v \<Longrightarrow>
   cut_memory memaddr 32 (vctx_memory v) = word_rsplit table"
apply (rule memory_range_elms_cut_memory2)
apply auto
apply (auto simp:word_length)
done

(*
lemma helper :
  assumes a:" cut_memory_aux (addr+1) x mem @
           cut_memory_aux
            ((addr+1) + word_of_int (int x)) y mem =
           cut_memory_aux (addr+1) (x + y) mem"
  shows "cut_memory_aux (addr + 1) x mem @
       cut_memory_aux
        (addr + word_of_int (1 + int x)) y mem =
       cut_memory_aux (addr + 1) (x + y) mem"
proof -
  have a: "addr + word_of_int (1 + int x) =
       (addr+1) + word_of_int (int x)"
    by (metis (no_types, hide_lams) add.assoc of_nat_Suc word_of_nat)
  show ?thesis by (subst a) (rule assms)
qed

lemma cut_memory_aux_append :
  "cut_memory_aux addr x mem @
   cut_memory_aux (addr+word_of_int (int x)) y mem =
   cut_memory_aux addr (x+y) mem"
apply (induction x arbitrary:addr)
apply(auto simp:cut_memory_aux.simps)
using helper
apply force
done
*)

lemma iota_rev_aux :
"a # iota0 addr y acc = iota0 addr y (acc@[a])"
apply (induction y arbitrary:addr acc)
apply (auto simp add:iota0.simps)
done

lemma iota_rev_aux2 :
"rev acc @ iota0 addr y acc2 = iota0 addr y (acc2@acc)"
apply (induction acc arbitrary:acc2 addr)
apply (simp add:iota0.simps)
apply (simp add:iota0.simps)
  by (metis append.assoc append_Cons append_Nil iota0_non_empty)

lemma iota_rev :
"rev acc @ iota0 addr y [] = iota0 addr y acc"
  using iota_rev_aux2 by auto

lemma iota_append :
"iota0 addr x acc @
 iota0 (addr + word_of_int (int x)) y [] =
 iota0 addr (x + y) acc"
apply (induction x arbitrary:addr acc)
apply (simp add:iota0.simps)
using iota_rev apply force
  by (metis (no_types, hide_lams) add.assoc add.commute add_Suc_right iota0.simps(2) of_nat_Suc one_word.abs_eq word_of_nat)

lemma cut_memory_aux_append :
  "cut_memory_aux_alt addr x mem @
   cut_memory_aux_alt (addr+word_of_int (int x)) y mem =
   cut_memory_aux_alt addr (x+y) mem"
apply(auto simp:cut_memory_aux_alt_def)
using iota_append
  by (metis map_append)

lemma word_of_nat : "word_of_int (int (unat x)) = x"
  by (metis uint_nat word_of_int_uint)

lemma unat_add_smaller : "unat (x+y) \<le> unat x + unat y"
  by (smt add_diff_cancel_right' le_diff_conv trans_le_add2 un_ui_le unat_sub_if_size)

lemma unat_uint_smaller : "uint x \<le> int (unat x)"
  by (simp add: uint_nat)

lemma int_unat_add :
   "int (unat x) + int (unat y) = int (unat x + unat y)"
  by simp

lemma int_inj : "int x = int y \<Longrightarrow> x = y"
apply auto
done

lemma unat_add_aux :
   assumes a:"unat (x::w256) + unat (y::w256) < 2 ^ 256"
   shows "int (unat x + unat y) =
          uint (word_of_int (int (unat x + unat y))::w256)"
proof -
  have b:"uint (word_of_int (int (unat x + unat y))::w256) =
        int (unat x + unat y) mod 2^256"
        by (auto simp:uint_word_of_int)
  have "int (unat x + unat y) < 2^256" using a
    by auto
  then show ?thesis using b
    by (simp add: semiring_numeral_div_class.mod_less)
qed

lemma unat_fold : "int (unat x) = uint x"
apply (auto simp:uint_nat)
done

lemma unat_add :
   "unat (x::w256) + unat (y::w256) < 2^256 \<Longrightarrow>
    unat (x+y) = unat x + unat y"
apply (subst word_add_def)
apply (subst uint_nat)
apply (subst uint_nat)
apply (subst int_unat_add)
apply (rule int_inj)
apply (subst unat_fold)
using unat_add_aux by simp

lemma cut_memory_append :
  "unat x + unat y < 2^256 \<Longrightarrow>
   cut_memory addr x mem @ cut_memory (addr+x) y mem =
   cut_memory addr (x+y) mem"
apply (simp add:cut_memory_def)
apply (subst unat_add [of x y])
apply auto
using cut_memory_aux_append [of addr "unat x" mem "unat y"]
and word_of_nat [of x]
apply force
done

lemma funext : "(\<forall>x. f x = g x) \<Longrightarrow> f = g"
apply(auto)
done

lemma word_of_inc : "word_of_int (1 + x) = 1 + word_of_int x"
  by (metis one_word.abs_eq wi_hom_add)

lemma memory_append :
   "(memory_range x l1 **
      memory_range (x+(word_of_int (int (length l1))::w256)) l2) =
    memory_range x (l1@l2)"
apply (induction l1 arbitrary:x)
apply auto
apply (subst word_of_inc)
  by (metis (no_types, hide_lams) add.assoc)

lemma sep_memory_range2 :
"      unat (len_word :: w256) = length input \<Longrightarrow>
       (rest ** memory_range begin_word input) s =
       ((memory_range_elms begin_word input \<subseteq> s) \<and> rest (s - memory_range_elms begin_word input))
"
using sep_memory_range by force

definition tk :: "byte list \<Rightarrow> byte list" where
"tk lst = take (2^255) lst"

definition memory_ran :: "w256 \<Rightarrow> byte list \<Rightarrow> state_element set_pred" where
"memory_ran addr lst = memory_range addr (tk lst)"

lemma sep_memory [simp] :
  "((rest ** memory a w)) s =
   (memory_range_elms a (word_rsplit w) \<subseteq> s \<and>
   rest (s - memory_range_elms a (word_rsplit w)))"
apply (subst memory_def)
apply (rule sep_memory_range2)
apply (auto simp:word_length)
apply (rule word_32)
done

lemma unat_word_of_nat :
   "x < 2^256 \<Longrightarrow>
    unat (word_of_int (int x)::w256) = x"
proof -
  assume "x < 2 ^ 256"
  then have "int x = uint (word_of_int (int x)::256 word)"
    by (metis (no_types) less_imp_of_nat_less numeral_pow of_nat_0_le_iff of_nat_numeral semiring_numeral_div_class.mod_less word_of_int_mod)
  then show ?thesis
    by (metis (full_types) nat_int.Rep_eqD uint_nat)
qed

lemma sep_memory_ran [simp] :
  "((rest ** memory_ran a w)) s =
   (memory_range_elms a (tk w) \<subseteq> s \<and>
   rest (s - memory_range_elms a (tk w)))"
apply(subst tk_def)
apply(subst tk_def)
apply (subst memory_ran_def)
apply(subst tk_def)
apply (rule sep_memory_range2)
apply (auto simp:word_length)
apply (rule unat_word_of_nat)
apply (auto)
done

lemma sep_memory2 [simp] :
  "(rest ** memory a w) s ==
   memory_range_elms a (word_rsplit w) \<subseteq> s \<and>
   rest (s - memory_range_elms a (word_rsplit w))"
using sep_memory
apply force
done

lemma sep_memory_ran2 [simp] :
  "(rest ** memory_ran a w) s ==
   memory_range_elms a (tk w) \<subseteq> s \<and>
   rest (s - memory_range_elms a (tk w))"
apply auto
done

lemma sep_memory3 [simp] :
  "(memory a w ** rest) s ==
   memory_range_elms a (word_rsplit w) \<subseteq> s \<and>
   rest (s - memory_range_elms a (word_rsplit w))"
using sep_memory
  by (simp add: sep_conj_commute)

lemma sep_memory_ran3 [simp] :
  "(memory_ran a w ** rest) s ==
   memory_range_elms a (tk w) \<subseteq> s \<and>
   rest (s - memory_range_elms a (tk w))"
  by (simp add: sep_conj_commute)

lemma sep_memory4 [simp] :
  "((rest1 ** memory a w ** rest) s) =
   (memory_range_elms a (word_rsplit w) \<subseteq> s \<and>
   (rest1 ** rest) (s - memory_range_elms a (word_rsplit w)))"
proof -
  have a : "rest1 ** memory a w ** rest == (rest1 ** rest) ** memory a w"
    by (simp add: abel_semigroup.commute abel_semigroup.left_commute sep.mult.abel_semigroup_axioms)
  then show ?thesis by
   (subst a) (rule sep_memory)
qed

lemma sep_memory_ran4 [simp] :
  "((rest1 ** memory_ran a w ** rest) s) =
   (memory_range_elms a (tk w) \<subseteq> s \<and>
   (rest1 ** rest) (s - memory_range_elms a (tk w)))"
proof -
  have a : "rest1 ** memory_ran a w ** rest ==
     (rest1 ** rest) ** memory_ran a w"
    by (simp add: abel_semigroup.commute abel_semigroup.left_commute sep.mult.abel_semigroup_axioms)
  then show ?thesis by
   (subst a) (rule sep_memory_ran)
qed

(*
declare memory_range_elms.simps [simp]
declare meter_gas_def [simp del]
*)

lemma mload_inst [simp] :
   "inst_size (Memory MLOAD) = 1"
by (auto simp:inst_size_def inst_code.simps)

lemma get_good_mem_elem_nat_aux :
"(x \<in> memory_range_elms (addr+1)
                 lst \<Longrightarrow>
           \<exists>a. x =
               MemoryElm
                (addr + 1 +
                 word_of_int (int a),
                 lst ! a) \<and>
               a < length lst) \<Longrightarrow>
       x \<in> memory_range_elms (addr + 1)
             lst \<Longrightarrow>
       \<exists>aa. x =
            MemoryElm
             (addr + word_of_int (int aa),
              (a # lst) ! aa) \<and>
            aa < Suc (length lst)"
apply auto
subgoal for aa
apply (rule_tac exI[of _ "aa+1"])
apply auto
  by (simp add: word_of_inc)
done

lemma get_good_mem_elem_nat :
  "x \<in> memory_range_elms addr lst \<Longrightarrow>
   \<exists>a. x = MemoryElm (addr+(word_of_int (int a)::w256), lst!a) \<and>
       a < length lst"
apply (induction lst arbitrary:addr)
apply auto
apply (rule exI[of _ 0])
apply auto
using get_good_mem_elem_nat_aux
apply force
done

lemma get_good_mem_elem :
  assumes a:"x \<in> memory_range_elms addr lst"
    and b:"length lst < 2^256"
  shows "\<exists>a. x = MemoryElm (addr+a, lst!unat a) \<and> unat a < length lst"
proof -
from a have "\<exists>n. x = MemoryElm (addr+(word_of_int (int n)::w256), lst!n)
  \<and> n < length lst"
  using get_good_mem_elem_nat by auto
then obtain n where
   c:"x = MemoryElm (addr+(word_of_int (int n)), lst!n) \<and>
    n < length lst" by auto
then have "n < 2^256" using b by auto
then have "x = MemoryElm (addr + (word_of_int (int n)::w256),
           lst ! unat (word_of_int (int n)::w256)) \<and>
           unat (word_of_int (int n)::w256) < length lst" using b and c
   by (auto simp:unat_word_of_nat)
then show ?thesis by force
qed

(*
lemma memory_not_changed :
  "memory_range_elms memaddr (word_rsplit (w::w256))
       \<subseteq> variable_ctx_as_set x1 \<Longrightarrow>
   xa \<in> memory_range_elms memaddr (word_rsplit (w::w256)) \<Longrightarrow>
   xa \<in> contexts_as_set
           (x1\<lparr>vctx_pc := new_pc,
                 vctx_stack := new_stack,
                 vctx_gas := new_gas,
                 vctx_memory_usage := memu\<rparr>)
           co_ctx"
apply(simp add: contexts_as_set_def variable_ctx_as_set_def
 memory_as_set_def)

done
*)

lemma read_split :
  "read_word_from_bytes 0 (word_rsplit w) = w"
by (auto simp:byte_list_fill_right_def word_length
         read_word_from_bytes_def word_rcat_rsplit)

lemma memory_works :
 assumes a:"memory_range_elms memaddr (word_rsplit (w::w256))
       \<subseteq> variable_ctx_as_set x1"
 shows "read_word_from_bytes 0
        (cut_memory memaddr 32 (vctx_memory x1)) = w"
proof -
   have "length (word_rsplit (w::w256):: byte list) = 32"
     by (auto simp:word_length)
   then have "cut_memory memaddr 32 (vctx_memory x1) =
              word_rsplit w"
     using a memory_range_elms_cut_memory
     by force
   then show ?thesis by (auto simp:read_split)
qed

(*
lemma set_dir1 :
  "vctx_stack x1 = memaddr # t \<Longrightarrow>
   x \<noteq> StackHeightElm (Suc (length t)) \<Longrightarrow>
   x \<noteq> CodeElm (vctx_pc x1, Memory MLOAD) \<Longrightarrow>
       x \<notin> memory_range_elms memaddr
             (word_rsplit v) \<Longrightarrow>
       x \<noteq> StackElm (length t, memaddr) \<Longrightarrow>
       x \<noteq> PcElm (vctx_pc x1) \<Longrightarrow>
       x \<in> contexts_as_set x1 co_ctx \<Longrightarrow>
       x \<noteq>
       MemoryUsageElm
        (vctx_memory_usage x1) \<Longrightarrow>
       x \<noteq> GasElm (vctx_gas x1) \<Longrightarrow>
       x \<noteq> GasElm newgas \<Longrightarrow>
       x \<noteq> ContinuingElm True \<Longrightarrow>
       x \<in> contexts_as_set
             (x1\<lparr>vctx_pc := vctx_pc x1 + 1,
                   vctx_stack := nstack # t,
                   vctx_gas := newgas2,
                   vctx_memory_usage := memu\<rparr>)
             co_ctx"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def)
done

lemma set_dir2 :
  "vctx_stack x1 = memaddr # t \<Longrightarrow>
   memu = memu2 \<Longrightarrow>
   newpc = newpc2 \<Longrightarrow>
   newgas = newgas2 \<Longrightarrow>
   nstack = nstack2 \<Longrightarrow>
   x \<noteq> GasElm newgas  \<Longrightarrow>
   x \<noteq> MemoryUsageElm memu \<Longrightarrow>
       x \<noteq>
       CodeElm
        (vctx_pc x1, Memory MLOAD) \<Longrightarrow>
       x \<noteq> PcElm newpc2 \<Longrightarrow>
       x \<noteq>
       StackHeightElm (Suc (length t)) \<Longrightarrow>
       x \<notin> memory_range_elms memaddr
             (word_rsplit v) \<Longrightarrow>
       x \<noteq> StackElm (length t, nstack2) \<Longrightarrow>
       x \<in> contexts_as_set
             (x1\<lparr>vctx_pc := newpc,
                   vctx_stack :=
                     nstack #
                     t,
                   vctx_gas := newgas2,
                   vctx_memory_usage :=
                     memu2\<rparr>)
             co_ctx \<Longrightarrow>
       x \<noteq> ContinuingElm True \<Longrightarrow>
       x \<noteq> GasElm (vctx_gas x1) \<Longrightarrow>
       x \<in> contexts_as_set x1 co_ctx"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def)
done
*)

context
  includes hoare_bundle hoare_inst_bundle
           sep_crunch_bundle simp_for_triples_bundle

begin

lemma memory_range_elms_conjD:
  "memory_range_elms logged_start data \<subseteq> {x. x \<noteq> v \<and> P x} \<Longrightarrow> v \<notin> range MemoryElm  \<Longrightarrow>
   memory_range_elms logged_start data \<subseteq> {x. P x}"
  by auto

lemma memory_range_elms_disjD:
  "memory_range_elms logged_start data \<subseteq> {x. x = v \<or> P x} \<Longrightarrow> v \<notin> range MemoryElm  \<Longrightarrow>
   memory_range_elms logged_start data \<subseteq> {x. P x}"
  by (induct data arbitrary:logged_start; clarsimp)

lemma move_neq_first:
   "{x. P x \<and> x \<noteq> v} = {x. x \<noteq> v \<and> P x}"
   "{x. P x \<and> x \<noteq> v \<and> Q x} = {x. x \<noteq> v \<and> P x \<and> Q x}"
  by blast+

lemma mload_gas_triple :
  "triple network {OutOfGas}
     (\<langle> h \<le> 1023 \<rangle> **
       stack_topmost h [memaddr] **
       program_counter k **
       memory_usage memu **
       memory memaddr v **
       gas_pred g **
       continuing)
     {(k, Memory MLOAD)}
    (stack_topmost h [v] **
     memory memaddr v **
     memory_usage (M memu memaddr 32) **
     program_counter (k + 1) **
     gas_pred (g - Gverylow + Cmem memu -
               Cmem (M memu memaddr 32)) **
     continuing )"

apply (simp add: triple_def)
apply clarify
  apply (rule_tac x = 1 in exI)
  apply (case_tac presult)
    defer
    apply (simp)
   apply (simp  add:  memory_range_sep )
apply(rename_tac continued)
apply(simp add: memory_inst_numbers.simps sep_memory_range
      sep_memory_range_sep mload_def memory_range_sep
        instruction_result_as_set_def insert_minus_set
vctx_stack_default_def set_diff_expand set_diff_eq )
  apply clarify
  apply (auto simp: move_neq_first create_log_entry_def vctx_returned_bytes_def
              elim: set_mp dest!: memory_range_elms_conjD memory_range_elms_disjD)
  using memory_works apply blast

(*
  apply (drule (1) set_mp)
  apply (rename_tac elm, case_tac elm; simp)
*)

apply (erule_tac P=rest in  back_subst)
  apply(rule Set.equalityI)
 apply clarify
 apply simp
 apply(rename_tac elm; case_tac elm; simp)
   apply(rename_tac st)
   apply(case_tac st; clarsimp)
   apply(erule disjE; clarsimp)
  apply auto[1]
 apply(simp add: vctx_advance_pc_def contexts_as_set_def)
apply(rename_tac elm; case_tac elm; auto)
  using memory_works apply blast
  using memory_works apply blast
  by (simp add: memory_word_meaning read_split)

(*
lemma subtract_gas_environment :
   "subtract_gas x memu res =
     InstructionToEnvironment act v opt \<Longrightarrow>
    res = InstructionToEnvironment act
      (v\<lparr> vctx_gas := vctx_gas v + x, vctx_memory_usage := memu  \<rparr>) opt"
apply(cases res)
apply(auto)
done
*)

(*
lemma sha_env :
  "length (vctx_stack v) \<ge> 2 \<Longrightarrow>
   sha3 v c = InstructionToEnvironment act nv opt \<Longrightarrow>
   act = ContractFail [OutOfGas]"
apply (auto simp:sha3_def)
apply(cases "vctx_stack v")
apply(simp)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(simp)
apply auto
apply (case_tac "\<not> cctx_hash_filter c (cut_memory a aa (vctx_memory v))")
apply auto
done
*)

lemma sha_fail_helper :
  "subtract_gas x memu (sha3 v c) =
     InstructionToEnvironment act nv opt \<Longrightarrow>
   length (vctx_stack v) \<ge> 2 \<Longrightarrow>
   failed_for_reasons {OutOfGas}
        (InstructionToEnvironment act nv opt)"
apply (auto simp:sha3_def)
apply(cases "vctx_stack v")
apply(simp)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(simp)
apply auto
apply (case_tac "\<not> cctx_hash_filter c (cut_memory a aa (vctx_memory v))")
apply auto
done

lemma subtract_gas_continue :
   "subtract_gas x memu res = InstructionContinue v \<Longrightarrow>
    \<exists>memu. res = InstructionContinue
      (v\<lparr> vctx_gas := vctx_gas v + x, vctx_memory_usage := memu  \<rparr>)"
apply(cases res)
apply(auto)
subgoal for x1
apply(rule_tac exI[of _ "vctx_memory_usage x1"])
apply auto
done
done

(*
lemma sha_continue :
  "sha3 v c = InstructionContinue nv \<Longrightarrow>
   nv = vctx_advance_pc c v\<lparr>
      vctx_stack :=
        keccak (cut_memory (hd (vctx_stack v))
            (hd (tl (vctx_stack v))) (vctx_memory v)) #
        tl (tl (vctx_stack v)) \<rparr>"
done
*)

lemma sha_continue_helper :
  "subtract_gas x memu (sha3 v c) = InstructionContinue nv \<Longrightarrow>
   nv = vctx_advance_pc c v\<lparr>
      vctx_gas := vctx_gas v - x,
      vctx_stack :=
        keccak (cut_memory (hd (vctx_stack v))
            (hd (tl (vctx_stack v))) (vctx_memory v)) #
        tl (tl (vctx_stack v)),
      vctx_memory_usage := memu  \<rparr>"
apply (auto simp:sha3_def)
apply(cases "vctx_stack v")
apply(simp)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(simp)
apply auto
apply (case_tac "\<not> cctx_hash_filter c (cut_memory a aa (vctx_memory v))")
apply (auto)
done

lemma sha_special_helper :
  "subtract_gas x memu (sha3 v c) = InstructionContinue nv \<Longrightarrow>
   sha3 v c = InstructionContinue (vctx_advance_pc c v\<lparr>
      vctx_stack :=
        keccak (cut_memory (hd (vctx_stack v))
            (hd (tl (vctx_stack v))) (vctx_memory v)) #
        tl (tl (vctx_stack v))\<rparr>)"
apply (auto simp:sha3_def split:list.split)
apply (case_tac "\<not> cctx_hash_filter c (cut_memory x21 x21a (vctx_memory v))")
apply (auto)
done

lemma rsplit_length :
 "32 = (word_of_int
     (int (length (word_rsplit (w::w256)::byte list)))::w256)"
  using word_length by auto

lemma hash_memory_split :
  "(memory addr table ** memory (addr+32) key) =
   memory_range addr (word_rsplit table @ word_rsplit key)"
apply (simp add:memory_def)
apply (subst rsplit_length)
using memory_append [of addr "word_rsplit table"
                        "word_rsplit key"]
apply auto
done

lemma simp_len [simp] :
   "length ((word_rsplit (table::w256) :: byte list) @
            (word_rsplit (key::w256) :: byte list)) = 64"
apply (auto simp:word_length)
done

lemma tk_simp [simp] :
   "tk (word_rsplit table @ word_rsplit key) =
   word_rsplit (table::w256) @ word_rsplit (key::w256)"
apply (auto simp:tk_def word_length)
done

lemma magic_hash_property :
  "cctx_hash_filter c = magic_filter \<Longrightarrow>
   vctx_stack v = addr # 64 # blah \<Longrightarrow>
   cut_memory addr 64 (vctx_memory v) =
      word_rsplit table @ word_rsplit key \<Longrightarrow>
   sha3 v c = InstructionContinue nv \<Longrightarrow>
   hash2 table key = 0 \<Longrightarrow> False"
apply(auto simp:sha3_def)
apply (case_tac "\<not> cctx_hash_filter c
    (word_rsplit table @ word_rsplit key)")
apply(auto simp:magic_filter_def)
done

lemma cut_memory_works :
  assumes a:"memory_range_elms addr
           (word_rsplit table @ word_rsplit key)
          \<subseteq> variable_ctx_as_set v"
  shows "cut_memory addr 64 (vctx_memory v) =
    word_rsplit (table::w256) @ word_rsplit (key::w256)"
proof -
   have "length (word_rsplit (table::w256) @ word_rsplit (key::w256) :: byte list) = 64"
     by (auto simp:word_length)
   then show ?thesis
     using a memory_range_elms_cut_memory
     by force
qed
(*
lemma many_such_cases :
 "contexts_as_set
           (v\<lparr>vctx_pc := pca, vctx_gas := gasa,
                 vctx_stack := stacka,
                 vctx_memory_usage := memu \<rparr>) c =
  (contexts_as_set v c -
     stack_as_set (vctx_stack v) -
     {PcElm (vctx_pc v),
      GasElm (vctx_gas v),
      MemoryUsageElm (vctx_memory_usage v)})
  \<union> {PcElm pca,
      GasElm gasa,
      MemoryUsageElm memu} \<union> stack_as_set stacka"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def)
done

lemma sort_out_sets_again :
 "vctx_stack x1 = memaddr # 64 # ta \<Longrightarrow>
  stack_new = stack_new2 \<Longrightarrow>
  memu = memu2 \<Longrightarrow>
  newgas = newgas2 \<Longrightarrow>
 vctx_stack x1 = memaddr # 64 # ta \<Longrightarrow>
          contexts_as_set x1 co_ctx -
          {GasElm (vctx_gas x1)} -
          {MemoryUsageElm
            (vctx_memory_usage x1)} -
          {PcElm (vctx_pc x1)} -
          {StackElm (Suc (length ta), memaddr)} -
          {StackHeightElm
            (Suc (Suc (length ta)))} -
          {CodeElm (vctx_pc x1, Arith SHA3)} -
          memory_range_elms memaddr
           memstuff -
          {StackElm (length ta, 64)} =
          insert (PcElm (vctx_pc x1 + 1))
           (insert
             (GasElm  newgas)
             (insert
               (MemoryUsageElm
                 memu)
               (contexts_as_set x1 co_ctx -
                stack_as_set (memaddr # 64 # ta) -
                {PcElm (vctx_pc x1),
                 GasElm (vctx_gas x1),
                 MemoryUsageElm
                  (vctx_memory_usage x1)} \<union>
                stack_as_set
                 (stack_new #
                  ta)))) -
          {StackHeightElm (Suc (length ta))} -
          {PcElm (vctx_pc x1 + 1)} -
          {StackElm
            (length ta, stack_new2)} -
          {CodeElm (vctx_pc x1, Arith SHA3)} -
          memory_range_elms memaddr memstuff -
          {MemoryUsageElm
            memu2} -
          {GasElm newgas2}"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def)
  using le_less_Suc_eq by force
*)

(*** need hoare triple for sha  *)
(*
lemma hash2_gas_triple :
  "triple network {OutOfGas}
     (\<langle> h \<le> 1022 \<rangle> **
       stack (h+1) memaddr **
       stack h 64 **
       stack_height (h+2) **
       program_counter k **
       memory_usage memu **
       memory_ran memaddr
        (word_rsplit table @ word_rsplit key) **
       gas_pred g **
       continuing)
     {(k, Arith SHA3)}
    (\<langle> hash2 table key \<noteq> 0 \<rangle> **
     stack_height (h + 1) **
     stack h (hash2 table key) **
     memory_ran memaddr (word_rsplit table @ word_rsplit key) **
     memory_usage (M memu memaddr 64) **
     program_counter (k + 1) **
     gas_pred (g - Gsha3 - Gsha3word * 2 + Cmem memu -
               Cmem (M memu memaddr 64)) **
     continuing )"
apply(auto simp add: triple_def)
apply(rule_tac x = 1 in exI)
apply(case_tac presult)
defer
apply simp
apply simp
apply simp
apply(case_tac
"subtract_gas
          (meter_gas (Arith SHA3) x1 co_ctx)
(M (vctx_memory_usage x1)
               (vctx_stack_default 0 x1)
               (vctx_stack_default 1 x1))
          (sha3 x1 co_ctx)")
defer
apply simp
using subtract_gas_annotation sha_annotation
apply fastforce
apply simp
using sha_fail_helper apply simp
apply simp
subgoal for co_ctx presult rest x1 x1a
using sha_continue_helper
   [of "(meter_gas (Arith SHA3) x1 co_ctx)"
"(M (vctx_memory_usage x1)
       (vctx_stack_default 0 x1)
       (vctx_stack_default 1 x1))"
       x1 co_ctx x1a]
apply simp
apply(auto simp add: instruction_result_as_set_def)

apply (simp add:cut_memory_works)
apply (rule sym)
apply (rule hash_compat)
apply auto
apply (rule_tac
 magic_hash_property [of co_ctx x1 memaddr _ table key])
apply auto
using cut_memory_works
apply force
using sha_special_helper
apply force
apply (rule_tac
 magic_hash_property [of co_ctx x1 memaddr _ table key])
apply auto
using cut_memory_works
apply force
using sha_special_helper
apply force
apply (simp add:meter_gas_def)
apply(rule leibniz)

 apply blast
apply (simp add:vctx_advance_pc_def many_such_cases)
apply (simp add:meter_gas_def)

apply (rule sort_out_sets_again)

apply auto

apply (simp add:cut_memory_works)
apply (rule sym)
apply (rule hash_compat)
apply auto
apply (rule_tac
 magic_hash_property [of co_ctx x1 memaddr _ table key])
apply auto
using cut_memory_works
apply force
using sha_special_helper
apply force
done
done
*)

(* nothing will work properly because everything is mod 2^256 *)

lemma store_get [simp] :
"unat a < length lst \<Longrightarrow>
 store_byte_list_memory addr lst mem (addr+a) = lst!unat a"
apply (auto simp:store_byte_list_memory_def)
done

lemma memory_contra :
assumes a:"x \<in> memory_range_elms addr (word_rsplit (w::w256))"
and b:"\<forall>a. x \<noteq>
        MemoryElm
         (a, store_byte_list_memory addr (word_rsplit w) mem a)"
shows "False"
proof -
from a have "\<exists>a. x = MemoryElm (addr+a, (word_rsplit w)!unat a) \<and>
                 unat a < 32"
using get_good_mem_elem and word_length by force
then obtain a where
   aa:"x = MemoryElm (addr+a, (word_rsplit w)!unat a) \<and> unat a < 32" by auto
then have "x = MemoryElm (addr+a,
     store_byte_list_memory addr (word_rsplit w) mem (addr+a))"
  using store_get and word_length by force
then show False using b by force
qed

lemma memory_was_changed :
       "x \<in> memory_range_elms memaddr
             (word_rsplit w) \<Longrightarrow>
       x \<notin> contexts_as_set
             (x1\<lparr>vctx_pc := vctx_pc x1 + 1,
                   vctx_stack := ta,
                   vctx_memory :=
                     store_word_memory memaddr w (vctx_memory x1),
                   vctx_gas := gas2,
                   vctx_memory_usage := memu  \<rparr>)
             co_ctx \<Longrightarrow> False"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def store_word_memory_def)
using memory_contra [of x memaddr w "vctx_memory x1"]
 by auto

lemma mstore_inst [simp] :
   "inst_size (Memory MSTORE) = 1"
apply (auto simp:inst_size_def inst_code.simps)
done

declare memory_as_set_def [simp del]

lemma memory_range_at_memory_set [simp]:
   "memory_range_elms memaddr lst
       \<subseteq> variable_ctx_as_set v \<Longrightarrow>
   memory_range_elms memaddr lst \<subseteq> memory_as_set (vctx_memory v)"
by(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def
   account_existence_as_set_def)

lemma memory_at_set [simp]:
   "memory_range_elms memaddr lst \<subseteq> memory_as_set (vctx_memory v)
    \<Longrightarrow> memory_range_elms memaddr lst
       \<subseteq> variable_ctx_as_set v"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def)
done

definition range_elms :: "w256 \<Rightarrow> byte list \<Rightarrow> state_element set" where
"range_elms addr lst =
   {MemoryElm (addr+word_of_int (int i),lst!i)| i. i < length lst}"

(* defining eq for memory_range_elms *)
lemma range_elems_aux :
  "range_elms begin (a # lst) =
   {MemoryElm (begin, a)} \<union> range_elms (begin + 1) lst"
apply (auto simp add:range_elms_def)
  using less_Suc_eq_0_disj word_of_inc apply fastforce
  apply (metis (no_types, hide_lams) Word.word_of_nat less_Suc_eq_0_disj nth_Cons' nth_Cons_Suc of_nat_Suc)
apply (rule exI[of _ 0])
apply simp
  by (metis (no_types, hide_lams) Suc_less_eq2 Word.word_of_nat nth_Cons_Suc of_nat_Suc)

lemma range_elms_eq :
   "memory_range_elms addr lst = range_elms addr lst"
apply (induction lst arbitrary:addr)
apply (simp add:range_elms_def)
apply (auto simp: range_elems_aux)
done

lemma extract_memory_range :
  "MemoryElm (a, v) \<in> range_elms addr lst \<Longrightarrow>
   \<exists>i. addr+word_of_int (int i) = a \<and> i < length lst"
apply (auto simp: range_elms_def)
done

lemma extract_memory_range2 :
  "MemoryElm (a, v) \<in> range_elms addr lst \<Longrightarrow>
   \<exists>i. addr+i = a \<and> unat i < length lst"
apply (auto simp: range_elms_def)
by (metis (no_types, hide_lams) Word.word_of_nat le_unat_uoi less_trans not_less)

lemma extract_memory_range3 :
  "(\<exists>i. (addr::w256)+i = (a::w256) \<and> unat i < length lst) \<Longrightarrow>
   unat (a-addr) < length lst"
apply auto
done

lemma extract_memory_range4 :
  "MemoryElm (a, v) \<notin> range_elms addr lst \<Longrightarrow>
   length lst \<ge> 2^256 \<or> lst ! unat (a-addr) \<noteq> v \<or>
   (unat (a-addr) \<ge> length lst)"
apply (auto simp: range_elms_def)
  by (simp add: word_of_nat not_less)

lemma cut_index_one :
  "mem addr = cut_memory addr 1 mem ! 0"
by (auto simp:cut_memory_def cut_memory_aux_alt_def iota0.simps)

lemma unat_minus :
 "unat (i::w256) \<le> n \<Longrightarrow>
  n < 2^256 \<Longrightarrow>
  unat i + unat ((word_of_int (int n)::w256) - i) = n"
  by (simp add: unat_sub_if' unat_word_of_nat)

lemma unat_minus_one :
 "unat (i::w256) < n \<Longrightarrow>
  n < 2^256 \<Longrightarrow>
  unat (i+1) +
  unat ((word_of_int (int n)::w256) - (i + 1)) = n"
apply (rule unat_minus)
  apply (metis Suc_eq_plus1 add_strict_right_mono less_Suc_eq_le unatSuc unat_0 w256_add_com zero_le)
apply auto
done

lemma unat_inc :
  "unat (i::w256) < n \<Longrightarrow>
   n < 2^256 \<Longrightarrow>
   unat (i+1) = unat i + unat (1::w256)"
apply (rule unat_add)
  by auto

lemma word_minus_plus :
   "(w::w256) - (i::w256) - (1::w256) = (w - (i + (1::w256)))"
apply auto
done

lemma unat_minus_one2 :
assumes  a:"unat (i::w256) < n"
and b:  "n < 2^256"
shows "unat (1::w256) +
  unat ((word_of_int (int n)::w256) - i - (1::w256)) =
   n - unat i"
proof -

have "unat (i+1) +
  unat ((word_of_int (int n)::w256) - (i + 1)) = n"
using unat_minus_one and unat_inc and a and b by force
have "unat i + unat (1::w256) +
  unat ((word_of_int (int n)::w256) - (i + (1::w256))) = n"
using unat_minus_one and unat_inc and a and b by force
then have "unat i + unat (1::w256) +
  unat ((word_of_int (int n)::w256) - i - (1::w256)) = n"
apply (subst word_minus_plus)
apply auto
done
then show ?thesis by auto
qed

lemma cut_aux_length :
   "length (cut_memory_aux addr i mem) = i"
apply (induction i arbitrary:addr mem)
apply (auto simp:cut_memory_aux.simps)
done

lemma iota_length :
   "length (iota0 addr i acc) = i + length acc"
apply (induction i arbitrary:addr acc)
apply (auto simp:iota0.simps)
done

lemma cut_length [simp] :
   "length (cut_memory addr i mem) = unat i"
by (simp add:cut_memory_def cut_memory_aux_alt_def iota_length)

lemma unat_index [simp] :
   "length l1 = unat (i::w256) \<Longrightarrow>
    (l1@l2)!unat i = l2!0"
  by (simp add: nth_append)

lemma cut_index :
  assumes a:"unat (i::w256) < length lst"
  and   b:"length lst < 2^256"
  shows "mem (addr+i) =
         cut_memory addr (word_of_int (int (length lst)))
                    mem ! unat i"
proof -
  have
   "cut_memory addr i mem @
    cut_memory (addr+i)
           ((word_of_int (int (length lst))::w256)-i) mem =
    cut_memory addr (i
    + ((word_of_int (int (length lst))::w256)-i)) mem"
using a and b and unat_minus and cut_memory_append by force
then have s1:
   "cut_memory addr i mem @
    cut_memory (addr+i)
           ((word_of_int (int (length lst))::w256)-i) mem =
    cut_memory addr (word_of_int (int (length lst))::w256) mem"
using a and b and unat_minus and cut_memory_append by force
have
 "cut_memory (addr+i) (1::w256) mem @
  cut_memory ((addr+i)+(1::w256))
           (((word_of_int (int (length lst))::w256)-i)-(1::w256)) mem
= cut_memory (addr+i)
           ((1::w256)+(((word_of_int (int (length lst))::w256)-i)-(1::w256))) mem"
apply (rule cut_memory_append)
using a and b
and unat_minus_one2 [of i "length lst" ]
apply simp
done
then have s2:
 "cut_memory (addr+i) (1::w256) mem @
  cut_memory ((addr+i)+(1::w256))
           (((word_of_int (int (length lst))::w256)-i)-(1::w256)) mem
= cut_memory (addr+i)
           ((word_of_int (int (length lst))::w256)-i) mem"
by auto
from s1 and s2 have
"cut_memory addr (word_of_int (int (length lst))::w256) mem
= cut_memory addr i mem @
 cut_memory (addr+i) (1::w256) mem @
 cut_memory ((addr+i)+(1::w256))
           (((word_of_int (int (length lst))::w256)-i)-(1::w256)) mem
"
by auto
then show ?thesis
apply auto
apply (simp add: nth_append   cut_index_one)
done
qed
(*
using a and b and unat_minus and cut_memory_append by force
*)

lemma stuff_aux :
"cut_memory memaddr 32 (vctx_memory x1) =
  word_rsplit (old_v::w256) \<Longrightarrow>
 ( a = memaddr + word_of_int (int (unat (a-memaddr))) \<and>
        vctx_memory x1 a =
          (word_rsplit (old_v::w256)::byte list) ! (unat (a-memaddr)) \<longrightarrow>
        \<not> (unat (a-memaddr)) <
         length ((word_rsplit old_v)::byte list) ) \<Longrightarrow>
    vctx_memory x1 a \<noteq>
    (word_rsplit (v::w256) :: byte list) ! unat (a - memaddr) \<Longrightarrow>
    x = MemoryElm (a, vctx_memory x1 a) \<Longrightarrow>
    unat (a - memaddr) < 32 \<Longrightarrow> False"

apply (auto simp:word_length)
  apply (simp add: word_of_nat)
using cut_index [of "a - memaddr" "(word_rsplit v::byte list)"
                   "vctx_memory x1" memaddr]
and word_length
apply auto
done

declare memory_range_at_memory_set [simp del]

lemma cut_stuff2 :
"length lst = 32 \<Longrightarrow>
  memory_range_elms memaddr lst \<subseteq>
   variable_ctx_as_set x1 \<Longrightarrow>
  cut_memory memaddr 32 (vctx_memory x1) = lst"
using memory_range_elms_cut_memory
apply auto
done

lemma cut_stuff :
"length lst = 32 \<Longrightarrow>
  memory_range_elms memaddr lst \<subseteq>
   memory_as_set (vctx_memory (x1::variable_ctx)) \<Longrightarrow>
  cut_memory memaddr 32 (vctx_memory x1) = lst"
using memory_at_set [of memaddr lst x1]
apply auto
done

lemma stuff :
"cut_memory memaddr 32 (vctx_memory x1) =
  word_rsplit (old_v::w256) \<Longrightarrow>
 x \<notin> memory_range_elms memaddr (word_rsplit old_v) \<Longrightarrow>
 x \<notin> memory_as_set
      (store_word_memory memaddr v (vctx_memory x1)) \<Longrightarrow>
 x \<in> memory_as_set (vctx_memory x1) \<Longrightarrow>
 False"
apply (simp add:range_elms_eq)
apply (auto simp:memory_as_set_def range_elms_def
  store_word_memory_def  store_byte_list_memory_def)
subgoal for a
apply (cases "unat (a-memaddr) < 32")
apply (auto simp:word_length)
using stuff_aux
apply force
done
done

declare word_length [simp add]
declare unat_word_of_nat [simp add]

(*
lemma memory_lookup :
  "MemoryElm (i,x) \<in> memory_as_set (vctx_memory x1) \<Longrightarrow>
   x = vctx_memory x1 i"
*)

lemma work_on_it2 :
"cut_memory memaddr 32 (vctx_memory x1) =
     (word_rsplit (old_v::w256))  \<Longrightarrow>
    x \<notin> memory_range_elms memaddr
          (word_rsplit old_v) \<Longrightarrow>
    x \<in> memory_range_elms memaddr
          (word_rsplit (new_v::w256)) \<Longrightarrow>
    x \<in> memory_as_set (vctx_memory x1) \<Longrightarrow>
    False"
apply (auto simp:range_elms_eq range_elms_def memory_as_set_def)
subgoal for i
using cut_index [of "word_of_int (int i)"
     "(word_rsplit old_v::byte list)"
                   "vctx_memory x1" memaddr]
apply auto
done
done

declare word_of_nat [simp add]

lemma work_on_it :
"memory_range_elms memaddr
     (word_rsplit (old_v::w256))
    \<subseteq> memory_as_set (vctx_memory x1) \<Longrightarrow>
    x \<notin> memory_range_elms memaddr
          (word_rsplit old_v) \<Longrightarrow>
    x \<in> memory_range_elms memaddr
          (word_rsplit (new_v::w256)) \<Longrightarrow>
    x \<in> memory_as_set (vctx_memory (x1::variable_ctx)) \<Longrightarrow>
    False"
apply (rule work_on_it2[of memaddr x1 old_v])
apply auto
done

lemma one_more_obstacle :
" memory_range_elms memaddr
          (word_rsplit (old_v::w256))
         \<subseteq> memory_as_set (vctx_memory (x1::variable_ctx)) \<Longrightarrow>
  x \<notin> memory_range_elms memaddr (word_rsplit (v::w256)) \<Longrightarrow>
 x \<in> memory_range_elms memaddr
               (word_rsplit old_v) \<Longrightarrow>
         x \<in> memory_as_set
               (store_word_memory memaddr v
                 (vctx_memory x1)) \<Longrightarrow>
         False"
apply (auto simp:range_elms_eq range_elms_def memory_as_set_def
store_word_memory_def)
done

lemma stuff2 :
"memory_range_elms memaddr (word_rsplit (old_v::w256)) \<subseteq>
   memory_as_set (vctx_memory (x1::variable_ctx)) \<Longrightarrow>
 x \<notin> memory_range_elms memaddr (word_rsplit (old_v::w256)) \<Longrightarrow>
 x \<notin> memory_as_set
      (store_word_memory memaddr v (vctx_memory x1)) \<Longrightarrow>
 x \<in> memory_as_set (vctx_memory x1) \<Longrightarrow>
 False"
apply (rule stuff[of memaddr x1 old_v])
apply auto
done

lemma still_left2 :
  "cut_memory memaddr 32 (vctx_memory x1) =
     (word_rsplit (old_v::w256)) \<Longrightarrow>
   x \<notin> memory_range_elms memaddr
               (word_rsplit (v::w256)) \<Longrightarrow>
  x \<notin> memory_as_set
               (vctx_memory x1) \<Longrightarrow>
  x \<in> memory_as_set
               (store_word_memory memaddr v
                 (vctx_memory x1)) \<Longrightarrow>
  False"
apply (simp add:range_elms_eq)
apply (auto simp:memory_as_set_def range_elms_def
  store_word_memory_def  store_byte_list_memory_def)
subgoal for a
apply (cases "unat (a-memaddr) < 32")
apply auto
done
done

lemma still_left :
  "memory_range_elms memaddr
          (word_rsplit (old_v::w256))
         \<subseteq> memory_as_set (vctx_memory x1) \<Longrightarrow>
   x \<notin> memory_range_elms memaddr
               (word_rsplit (v::w256)) \<Longrightarrow>
  x \<notin> memory_as_set
               (vctx_memory x1) \<Longrightarrow>
  x \<in> memory_as_set
               (store_word_memory memaddr v
                 (vctx_memory (x1::variable_ctx))) \<Longrightarrow>
  False"
apply (rule still_left2 [of memaddr x1 old_v])
apply (auto)
done

lemma range_not_in_constant [simp] :
 "x \<in> memory_range_elms memaddr lst \<Longrightarrow>
    x \<in> constant_ctx_as_set co_ctx \<Longrightarrow> False"
apply (induction lst arbitrary:memaddr)
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def)
done

lemma other_similar :
"memory_range_elms memaddr
          (word_rsplit (old_v::w256))
         \<subseteq> memory_as_set (vctx_memory x1) \<Longrightarrow>
         x \<notin> memory_range_elms memaddr
               (word_rsplit old_v) \<Longrightarrow>
         x \<in> contexts_as_set x1 co_ctx \<Longrightarrow>
         x \<in> memory_range_elms memaddr
               (word_rsplit (v::w256)) \<Longrightarrow>
         False"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def account_existence_as_set_def)
apply (rule range_not_in_constant[of x memaddr _ co_ctx])
apply auto
apply (rule work_on_it)
apply auto
done

lemma plz_sort_it_out :
 "vctx_stack x1 = memaddr # v # ta \<Longrightarrow>
  memu = memu2 \<Longrightarrow>
  newmem = store_word_memory memaddr v (vctx_memory x1) \<Longrightarrow>
  newgas = newgas2 \<Longrightarrow>
  new_pc = new_pc2 \<Longrightarrow>
  memory_range_elms memaddr
        (word_rsplit old_v)
       \<subseteq> memory_as_set (vctx_memory x1) \<Longrightarrow>
      contexts_as_set x1 co_ctx - {GasElm (vctx_gas x1)} -
       {MemoryUsageElm (vctx_memory_usage x1)} -
       {PcElm (vctx_pc x1)} -
       {StackElm (length ta, v)} -
       memory_range_elms memaddr (word_rsplit (old_v::w256)) -
       {StackElm (Suc (length ta), memaddr)} -
       {CodeElm (vctx_pc x1, Memory MSTORE)} -
       {StackHeightElm (Suc (Suc (length ta)))} =
       contexts_as_set
        (x1\<lparr>vctx_pc := vctx_pc x1 + 1, vctx_stack := ta,
              vctx_memory := newmem,
              vctx_gas := newgas2,
              vctx_memory_usage := memu2\<rparr>)
        co_ctx -
       {StackHeightElm (length ta)} -
       memory_range_elms memaddr (word_rsplit (v::w256)) -
       {PcElm (vctx_pc x1 + 1)} -
       {CodeElm (vctx_pc x1, Memory MSTORE)} -
       {MemoryUsageElm memu} -
       {GasElm newgas}
"
apply (auto)
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def account_existence_as_set_def)[1]
using le_less_Suc_eq apply fastforce

using stuff2 [of memaddr old_v x1 _ v]
apply force
using other_similar [of memaddr old_v x1 _ co_ctx v]
apply force
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def account_existence_as_set_def)[1]
using still_left [of memaddr old_v x1 _ v]
apply force
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def account_existence_as_set_def)[1]
apply (rule range_not_in_constant[of _ memaddr _ co_ctx])
apply auto
apply (auto simp:range_elms_eq range_elms_def memory_as_set_def
store_word_memory_def)
done

lemma memory_range_fact :
"memory_range_elms memaddr
        (word_rsplit old_v)
       \<subseteq> variable_ctx_as_set x1 \<Longrightarrow>
 x \<in> memory_range_elms memaddr
             (word_rsplit old_v) \<Longrightarrow>
 x \<in> memory_as_set (vctx_memory x1)"
apply(auto simp add: contexts_as_set_def variable_ctx_as_set_def stack_as_set_def ext_program_as_set_def
       balance_as_set_def account_existence_as_set_def)
done

lemma falseness : "False \<Longrightarrow> P"
apply auto
done

lemma mstore_gas_triple :
  "triple network {OutOfGas}
     (\<langle> h \<le> 1022 \<rangle> **
       stack (h+1) memaddr **
       stack h v **
       stack_height (h+2) **
       program_counter k **
       memory_usage memu **
       memory memaddr old_v **
       gas_pred g **
       continuing)
     {(k, Memory MSTORE)}
    (stack_height h **
     memory memaddr v **
     memory_usage (M memu memaddr 32) **
     program_counter (k + 1) **
     gas_pred (g - Gverylow + Cmem memu -
               Cmem (M memu memaddr 32)) **
     continuing )"
apply(auto simp add: triple_def)
apply(rule_tac x = 1 in exI)
apply(case_tac presult;
   auto simp add: meter_gas_def mstore_def
        memory_inst_numbers.simps
        instruction_result_as_set_def vctx_advance_pc_def)
subgoal for co_ctx rest x1 ta x
apply (rule FalseE)
apply (rule memory_was_changed [of x memaddr v "M (vctx_memory_usage x1)
                   memaddr 32"
  "vctx_gas x1 -
                  (3 *
                   M (vctx_memory_usage x1)
                    memaddr 32 +
                   M (vctx_memory_usage x1)
                    memaddr 32 *
                   M (vctx_memory_usage x1)
                    memaddr 32 div
                   512 -
                   (3 * vctx_memory_usage x1 +
                    vctx_memory_usage x1 *
                    vctx_memory_usage x1 div
                    512) +
                   Gverylow)"  "(x1::variable_ctx)" ta co_ctx] )
apply auto
done
apply (erule_tac P=rest in  back_subst)
apply(rule Set.equalityI)
 apply clarify
 apply simp
 apply(rename_tac elm; case_tac elm; simp)

apply auto[1]
  apply (metis cancel_comm_monoid_add_class.diff_cancel le_less_Suc_eq less_SucE nth_Cons')
apply (subgoal_tac "a = Suc (length ta)")
apply auto[1]
  apply (metis cancel_comm_monoid_add_class.diff_cancel le_less_Suc_eq less_SucE nth_Cons')
  apply (metis cancel_comm_monoid_add_class.diff_cancel le_less_Suc_eq less_SucE nth_Cons')
apply (subgoal_tac "a = Suc (length ta)")
apply auto[1]
  apply (metis cancel_comm_monoid_add_class.diff_cancel le_less_Suc_eq less_SucE nth_Cons')
apply auto[1]
subgoal for co_ctx x1 ta a
apply (rule stuff[of memaddr x1 old_v "MemoryElm (a, vctx_memory x1 a)" v])
apply (auto simp add:memory_as_set_def)
done
defer
apply auto[1]
 apply(rename_tac elm; case_tac elm; simp)
apply (case_tac x4; auto)
subgoal for co_ctx x1 ta a
apply (rule still_left[of memaddr old_v x1
 " MemoryElm
     (a, store_word_memory memaddr v (vctx_memory x1) a)
" v])
apply (auto simp add:memory_as_set_def)
 apply(rename_tac elm; case_tac elm; simp)
apply (case_tac x4; auto)
done
 apply(rename_tac elm; case_tac elm; simp)
apply (case_tac x4; auto)
defer
subgoal for co_ctx x1 ta a
apply (rule other_similar [of memaddr old_v x1
  "MemoryElm (a, vctx_memory x1 a)" co_ctx])
apply (auto simp add:memory_as_set_def)
 apply(rename_tac elm; case_tac elm; simp)
apply (case_tac x4; auto)
done
subgoal for co_ctx x1 ta aa
apply (rule one_more_obstacle[of memaddr old_v x1
 " MemoryElm
     (aa, store_word_memory memaddr v (vctx_memory x1) aa)"
 v ])
apply (auto simp add:memory_as_set_def)
 apply(rename_tac elm; case_tac elm; simp)
apply (case_tac x4; auto)
done
done

end

end


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

section "Words of Length 16"

theory Word_16
imports
  More_Word
  Signed_Words
begin

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

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

end


theory "Paulson_strengthened_Yahalom_cert_auto"
imports
  "ESPLogic"
begin

(* section:  Yahalom strengthened by Paulson  *)

(* text:
  Modeled after the model in the SPORE library.

  Notable differences:

    1. Instead of implicit typing, we are using explicit global constants to
       discern messages.

    2. The third message includes the identity of S in plaintext, as it is
       required by role A to lookup the corresponding shared key.

    3. We model longterm shared keys such that k[A,B] = k[B,A]. This extension
       is described in "Provably Repairing the ISO/IEC 9798 Standard for Entity
       Authentication" by Basin, Cremers, and Meier
       (http://people.inf.ethz.ch/cremersc/downloads/download.php?file=papers/BCM2011-iso9798.pdf)

 *)

role A
where "A =
  [ Send ''1'' <| sAV ''A'', sN ''Na'' |>
  , Recv ''3'' <| sMV ''S'', sMV ''Nb'',
                  PEnc <| sC ''3_1'', sMV ''B'', sMV ''Kab'', sN ''Na'' |>
                       ( sKbd (AVar ''A'') (MVar ''S'') ),
                  sMV ''TicketB''
               |>
  , Send ''4'' <| sMV ''TicketB'',
                  PEnc <| sC ''4'', sMV ''Nb'' |> ( sMV ''Kab'' )
               |>
  ]"

role B
where "B =
  [ Recv ''1'' <| sMV ''A'', sMV ''Na'' |>
  , Send ''2'' <| sAV ''B'', sN ''Nb'',
                  PEnc <| sC ''2'', sMV ''A'', sMV ''Na'' |>
                       ( sKbd (AVar ''B'') (AVar ''S'') )
               |>
  , Recv ''4'' <| PEnc <| sC ''3_2'', sMV ''A'', sAV ''B'', sMV ''Kab'',
                          sN ''Nb''
                       |>
                       ( sKbd (AVar ''B'') (AVar ''S'') ),
                  PEnc <| sC ''4'', sN ''Nb'' |> ( sMV ''Kab'' )
               |>
  ]"

role S
where "S =
  [ Recv ''2'' <| sMV ''B'', sMV ''Nb'',
                  PEnc <| sC ''2'', sMV ''A'', sMV ''Na'' |>
                       ( sKbd (MVar ''B'') (AVar ''S'') )
               |>
  , Send ''3'' <| sAV ''S'', sMV ''Nb'',
                  PEnc <| sC ''3_1'', sMV ''B'', sN ''Kab'', sMV ''Na'' |>
                       ( sKbd (MVar ''A'') (AVar ''S'') ),
                  PEnc <| sC ''3_2'', sMV ''A'', sMV ''B'', sN ''Kab'', sMV ''Nb'' |>
                       ( sKbd (MVar ''B'') (AVar ''S'') )
               |>
  ]"

protocol Yahalom
where "Yahalom = { A, B, S }"

locale restricted_Yahalom_state = Yahalom_state +
  assumes different_actors_A_S:
    "!! tid0 tid1.
       [| roleMap r tid0 = Some A; roleMap r tid1 = Some S;
         s(AV ''S'' tid1) = s(AV ''A'' tid0)
       |] ==> False"
  assumes different_actors_B_S:
    "!! tid0 tid1.
       [| roleMap r tid0 = Some B; roleMap r tid1 = Some S;
         s(AV ''S'' tid1) = s(AV ''B'' tid0)
       |] ==> False"

type_invariant Yahalom_msc_typing for Yahalom
where "Yahalom_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((S, ''A''), (SumT (KnownT S_2) AgentT))
  , ((A, ''B''), (SumT (KnownT A_3) AgentT))
  , ((S, ''B''), (KnownT S_2))
  , ((A, ''Kab''), (SumT (KnownT A_3) (NonceT S ''Kab'')))
  , ((B, ''Kab''), (SumT (KnownT B_4) (NonceT S ''Kab'')))
  , ((B, ''Na''), (KnownT B_1))
  , ((S, ''Na''), (SumT (KnownT S_2) (NonceT A ''Na'')))
  , ((A, ''Nb''), (KnownT A_3))
  , ((S, ''Nb''), (KnownT S_2))
  , ((A, ''S''), (KnownT A_3))
  , ((A, ''TicketB''), (KnownT A_3))
  ]"

sublocale Yahalom_state < Yahalom_msc_typing_state
proof -
  have "(t,r,s) : approx Yahalom_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF Yahalom_msc_typing.monoTyp, completeness_cases_rule])
    case (A_3_B t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_3_B
    thus ?case
    proof(sources! "
        Enc {| LC ''3_1'', s(MV ''B'' tid0), s(MV ''Kab'' tid0), LN ''Na'' tid0
            |}
            ( Kbd ( s(AV ''A'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (A_3_Kab t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_3_Kab
    thus ?case
    proof(sources! "
        Enc {| LC ''3_1'', s(MV ''B'' tid0), s(MV ''Kab'' tid0), LN ''Na'' tid0
            |}
            ( Kbd ( s(AV ''A'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (A_3_Nb t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_3_Nb
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_3_S t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_3_S
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_3_TicketB t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_3_TicketB
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_A t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_Na t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_Na
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_4_Kab t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_4_Kab
    thus ?case
    proof(sources! "
        Enc {| LC ''3_2'', s(MV ''A'' tid0), s(AV ''B'' tid0),
               s(MV ''Kab'' tid0), LN ''Nb'' tid0
            |}
            ( Kbd ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_2_A t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_2_A
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', s(MV ''A'' tid0), s(MV ''Na'' tid0) |}
            ( Kbd ( s(AV ''S'' tid0) ) ( s(MV ''B'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_2_B t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_2_B
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_2_Na t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_2_Na
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', s(MV ''A'' tid0), s(MV ''Na'' tid0) |}
            ( Kbd ( s(AV ''S'' tid0) ) ( s(MV ''B'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_2_Nb t r s tid0)
    then interpret state: Yahalom_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_2_Nb
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  qed
  thus "Yahalom_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context Yahalom_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Secrecy Properties  *)

lemma (in restricted_Yahalom_state) S_Kab_secret:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "LN ''Kab'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''Kab'' tid0 ")
  case S_3_Kab note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case S_3_Kab_1 note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_Yahalom_state) A_Kab_secret:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "RLKR(s(MV ''S'' tid0)) ~: reveals t"
    "( tid0, A_3 ) : steps t"
    "s(MV ''Kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3_1'', s(MV ''B'' tid0), s(MV ''Kab'' tid0), LN ''Na'' tid0
                       |}
                       ( Kbd ( s(AV ''A'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_3_enc tid1) note_unified facts = this facts
    hence "Kbd ( s(AV ''S'' tid1) )
               ( s(MV ''A'' tid1) ) = Kbd ( s(AV ''A'' tid0) ) ( s(MV ''S'' tid0) )"
      by simp note facts = this facts
    thus ?thesis proof(cases rule: Kbd_cases)
      case noswap note_unified facts = this facts
      thus ?thesis by (fastforce dest: S_Kab_secret intro: event_predOrdI)
    next
      case swapped note_unified facts = this facts
      thus ?thesis by (fastforce dest: S_Kab_secret intro: event_predOrdI)
    qed (fastforce+)?
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Yahalom_state) B_Kab_secret:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, B_4 ) : steps t"
    "s(MV ''Kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3_2'', s(MV ''A'' tid0), s(AV ''B'' tid0),
                          s(MV ''Kab'' tid0), LN ''Nb'' tid0
                       |}
                       ( Kbd ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_3_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_Kab_secret intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Authentication Properties  *)

(* text:  This is what Paulson proves.  *)

lemma (in restricted_Yahalom_state) B_auth:
  assumes facts:
    "roleMap r tid2 = Some B"
    "RLKR(s(AV ''B'' tid2)) ~: reveals t"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''A'' tid2)) ~: reveals t"
    "( tid2, B_4 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some A &
        s(MV ''B'' tid1) = s(AV ''B'' tid2) &
        s(MV ''Kab'' tid1) = s(MV ''Kab'' tid2))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3_2'', s(MV ''A'' tid2), s(AV ''B'' tid2),
                          s(MV ''Kab'' tid2), LN ''Nb'' tid2
                       |}
                       ( Kbd ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_3_enc_1 tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''4'', LN ''Nb'' tid2 |} ( LN ''Kab'' tid3 ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: S_Kab_secret intro: event_predOrdI)
    next
      case (A_4_enc tid4) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3_1'', s(MV ''B'' tid4), LN ''Kab'' tid3, LN ''Na'' tid4 |}
                           ( Kbd ( s(AV ''A'' tid4) ) ( s(MV ''S'' tid4) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: S_Kab_secret intro: event_predOrdI)
      next
        case (S_3_enc tid5) note_unified facts = this facts
        thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Stonger Authentication Properties  *)

(* text:
We can prove stronger authentication properties. However, they hold only under
the additional assumption that agents running the trusted third party do not
participate in the A or B role of the protocol. This is a reasonable assumption.

Without this assumption, the problem is that due to the swapping of identities
on the keys, the authentication properties below can be attacked. Note that the
proofs list exactly the reasoning steps where the axioms are exploited.
 *)

lemma (in restricted_Yahalom_state) A_strong_auth:
  assumes facts:
    "roleMap r tid1 = Some A"
    "RLKR(s(AV ''A'' tid1)) ~: reveals t"
    "RLKR(s(MV ''B'' tid1)) ~: reveals t"
    "RLKR(s(MV ''S'' tid1)) ~: reveals t"
    "( tid1, A_3 ) : steps t"
  shows
    "(?  tid2.
        (?  tid3.
           roleMap r tid2 = Some B &
           roleMap r tid3 = Some S &
           s(AV ''A'' tid1) = s(MV ''A'' tid2) &
           s(MV ''A'' tid2) = s(MV ''A'' tid3) &
           s(MV ''B'' tid1) = s(AV ''B'' tid2) &
           s(AV ''B'' tid2) = s(MV ''B'' tid3) &
           s(MV ''S'' tid1) = s(AV ''S'' tid2) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           LN ''Na'' tid1 = s(MV ''Na'' tid2) &
           s(MV ''Na'' tid2) = s(MV ''Na'' tid3) &
           s(MV ''Kab'' tid1) = LN ''Kab'' tid3 &
           predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid3, S_2 )) &
           predOrd t (St( tid3, S_2 )) (St( tid3, S_3 )) &
           predOrd t (St( tid3, S_3 )) (St( tid1, A_3 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3_1'', s(MV ''B'' tid1), s(MV ''Kab'' tid1), LN ''Na'' tid1
                       |}
                       ( Kbd ( s(AV ''A'' tid1) ) ( s(MV ''S'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_3_enc tid2) note_unified facts = this facts
    hence "Kbd ( s(AV ''S'' tid2) )
               ( s(MV ''A'' tid2) ) = Kbd ( s(AV ''A'' tid1) ) ( s(MV ''S'' tid1) )"
      by simp note facts = this facts
    thus ?thesis proof(cases rule: Kbd_cases)
      case noswap note_unified facts = this facts
      thus ?thesis by (fastforce dest: different_actors_A_S intro: event_predOrdI)
    next
      case swapped note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''2'', s(AV ''A'' tid1), LN ''Na'' tid1 |}
                           ( Kbd ( s(AV ''S'' tid2) ) ( s(MV ''B'' tid1) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (auto dest!: ltk_secrecy)
      next
        case (B_2_enc tid3) note_unified facts = this facts
        hence "Kbd ( s(AV ''S'' tid2) )
                   ( s(MV ''B'' tid1) ) = Kbd ( s(AV ''B'' tid3) ) ( s(AV ''S'' tid3) )"
          by simp note facts = this facts
        thus ?thesis proof(cases rule: Kbd_cases)
          case noswap note_unified facts = this facts
          thus ?thesis by (fastforce dest: different_actors_B_S intro: event_predOrdI)
        next
          case swapped note_unified facts = this facts
          thus ?thesis proof(sources! " LN ''Na'' tid1 ")
            case A_1_Na note_unified facts = this facts
            thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
          next
            case (S_3_Na tid4) note_unified facts = this facts
            thus ?thesis proof(sources! "
                             Enc {| LC ''2'', s(MV ''A'' tid4), LN ''Na'' tid1 |}
                                 ( Kbd ( s(AV ''S'' tid4) ) ( s(MV ''B'' tid4) ) ) ")
            qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
          qed (safe?, simp_all?, insert facts, (fastforce+)?)
        qed (fastforce+)?
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (fastforce+)?
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Yahalom_state) B_strong_auth:
  assumes facts:
    "roleMap r tid2 = Some B"
    "RLKR(s(AV ''B'' tid2)) ~: reveals t"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''A'' tid2)) ~: reveals t"
    "( tid2, B_4 ) : steps t"
  shows
    "(?  tid1.
        (?  tid3.
           roleMap r tid1 = Some A &
           roleMap r tid3 = Some S &
           s(AV ''A'' tid1) = s(MV ''A'' tid2) &
           s(MV ''A'' tid2) = s(MV ''A'' tid3) &
           s(MV ''B'' tid1) = s(AV ''B'' tid2) &
           s(AV ''B'' tid2) = s(MV ''B'' tid3) &
           s(MV ''S'' tid1) = s(AV ''S'' tid2) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           s(MV ''Nb'' tid1) = LN ''Nb'' tid2 &
           LN ''Nb'' tid2 = s(MV ''Nb'' tid3) &
           s(MV ''Kab'' tid1) = s(MV ''Kab'' tid2) &
           s(MV ''Kab'' tid2) = LN ''Kab'' tid3 &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid3, S_2 )) &
           predOrd t (St( tid3, S_2 )) (St( tid3, S_3 )) &
           predOrd t (St( tid3, S_3 )) (St( tid1, A_3 )) &
           predOrd t (St( tid1, A_3 )) (St( tid1, A_4 )) &
           predOrd t (St( tid1, A_4 )) (St( tid2, B_4 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3_2'', s(MV ''A'' tid2), s(AV ''B'' tid2),
                          s(MV ''Kab'' tid2), LN ''Nb'' tid2
                       |}
                       ( Kbd ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_3_enc_1 tid3) note_unified facts = this facts
    thus ?thesis proof(sources! " LN ''Nb'' tid2 ")
      case B_2_Nb note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''4'', LN ''Nb'' tid2 |} ( LN ''Kab'' tid3 ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: S_Kab_secret intro: event_predOrdI)
      next
        case (A_4_enc tid4) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''3_1'', s(MV ''B'' tid4), LN ''Kab'' tid3, LN ''Na'' tid4 |}
                             ( Kbd ( s(AV ''A'' tid4) ) ( s(MV ''S'' tid4) ) ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (fastforce dest: S_Kab_secret intro: event_predOrdI)
        next
          case (S_3_enc tid5) note_unified facts = this facts
          hence "Kbd ( s(AV ''S'' tid2) )
                     ( s(MV ''A'' tid2) ) = Kbd ( s(AV ''A'' tid4) ) ( s(MV ''S'' tid4) )"
            by simp note facts = this facts
          thus ?thesis proof(cases rule: Kbd_cases)
            case noswap note_unified facts = this facts
            thus ?thesis by (fastforce dest: different_actors_A_S intro: event_predOrdI)
          next
            case swapped note_unified facts = this facts
            thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
          qed (fastforce+)?
        qed (safe?, simp_all?, insert facts, (fastforce+)?)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


section \<open>Misc experiments\<close>

theory Misc imports
  Complex_Main
  (*"HOL-Analysis.Analysis"
  "HOL-Decision_Procs.Approximation"
  "HOL-Computational_Algebra.Primes"
  "HOL-ex.Sketch_and_Explore" *)

begin

lemma
  fixes x::real
  shows "2*x + y = x+y+x"
apply (simp add: )

(*FOR THE LIBRARY?*)

    lemma wellorder_InfI:
      fixes k :: "'a::{wellorder,conditionally_complete_lattice}"
      assumes "k \<in> A" shows "Inf A \<in> A"
      using wellorder_class.LeastI [of "\<lambda>x. x \<in> A" k]
      by (simp add: Least_le assms cInf_eq_minimum)

    lemma wellorder_Inf_le1:
      fixes k :: "'a::{wellorder,conditionally_complete_lattice}"
      assumes "k \<in> A" shows "Inf A \<le> k"
      by (meson Least_le assms bdd_below.I cInf_lower)

    lemma sum_Re_le_cmod: "(\<Sum>i\<in>I. Re (z i)) \<le> cmod (\<Sum>i\<in>I. z i)"
      by (metis Re_sum complex_Re_le_cmod)

    lemma sum_Im_le_cmod: "(\<Sum>i\<in>I. Im (z i)) \<le> cmod (\<Sum>i\<in>I. z i)"
      by (smt (verit, best) Im_sum abs_Im_le_cmod sum.cong)

    lemma cos_gt_neg1:
      assumes "(t::real) \<in> {-pi<..<pi}"
      shows   "cos t > -1"
    proof -
      have "cos t \<ge> -1"
        by simp
      moreover have "cos t \<noteq> -1"
      proof
        assume "cos t = -1"
        then obtain n where n: "t = (2 * of_int n + 1) * pi"
          by (subst (asm) cos_eq_minus1) auto
        from assms have "t / pi \<in> {-1<..<1}"
          by (auto simp: field_simps)
        also from n have "t / pi = of_int (2 * n + 1)"
          by auto
        finally show False
          by auto
      qed
      ultimately show ?thesis by linarith
    qed

(*** COMBINING / BREAKING SEQUENCES INDEXED BY NATURAL NUMBERS (from original Szemeredi development) **)

text \<open>Some tools for combining integer-indexed sequences or splitting them into parts\<close>

lemma less_sum_nat_iff:
  fixes b::nat and k::nat
  shows "b < (\<Sum>i<k. a i) \<longleftrightarrow> (\<exists>j<k. (\<Sum>i<j. a i) \<le> b \<and> b < (\<Sum>i<j. a i) + a j)"
proof (induction k arbitrary: b)
  case (Suc k)
  then show ?case
    by (simp add: less_Suc_eq) (metis not_less trans_less_add1)
qed auto

lemma less_sum_nat_iff_uniq:
  fixes b::nat and k::nat
  shows "b < (\<Sum>i<k. a i) \<longleftrightarrow> (\<exists>!j. j<k \<and> (\<Sum>i<j. a i) \<le> b \<and> b < (\<Sum>i<j. a i) + a j)"
  unfolding less_sum_nat_iff by (meson leD less_sum_nat_iff nat_neq_iff)

definition part :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
  where "part a k b \<equiv> (THE j. j<k \<and> (\<Sum>i<j. a i) \<le> b \<and> b < (\<Sum>i<j. a i) + a j)"

lemma part:
  "b < (\<Sum>i<k. a i) \<longleftrightarrow> (let j = part a k b in j < k \<and> (\<Sum>i < j. a i) \<le> b \<and> b < (\<Sum>i < j. a i) + a j)"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    unfolding less_sum_nat_iff_uniq part_def by (metis (no_types, lifting) theI')
qed (auto simp: less_sum_nat_iff Let_def)

lemma part_Suc: "part a (Suc k) b = (if sum a {..<k} \<le> b \<and> b < sum a {..<k} + a k then k else part a k b)"
  using leD
  by (fastforce simp: part_def less_Suc_eq less_sum_nat_iff conj_disj_distribR cong: conj_cong)

lemma part_eq:
  assumes "i < k" "d < a i"
  shows "part a k (sum a {..<i} + d) = i"
proof -
  have \<section>: "\<And>j. \<lbrakk>sum a {..<j} \<le> sum a {..<i} + d;
              sum a {..<i} + d < sum a {..<j} + a j\<rbrakk> \<Longrightarrow> j = i"
    by (meson \<open>d < a i\<close> leD le_add1 less_sum_nat_iff nat_add_left_cancel_less not_less_iff_gr_or_eq)
  show ?thesis
    unfolding part_def
    using assms
    by (intro the_equality) (auto simp: \<section>)
qed

lemma sum_layers_less:
  fixes d::nat and k::nat
  shows "\<lbrakk>i < k; d < a i\<rbrakk> \<Longrightarrow> sum a {..<i} + d < sum a {..<k}"
  by (meson le_add1 less_sum_nat_iff nat_add_left_cancel_less)

lemma whoops: "\<forall>x. P x \<longrightarrow> P (Suc x) \<Longrightarrow> P x \<Longrightarrow> P y"
  sorry
  by blast

lemma False
  using whoops [of "\<lambda>x. x\<noteq>0" 1 0]
  by auto

lemma
  fixes p::nat
  assumes "prime p"
  obtains q where "p<q" "q < p*p" "prime q"
proof -
  have "p dvd m*n \<longleftrightarrow> p dvd m \<or> p dvd n"
    by (simp add: assms prime_dvd_mult_iff)

  oops

lemma
  fixes p::nat
  assumes "prime p"
  obtains q where "p<q" "q < p*p" "prime q"
proof -
  have "p dvd m*n \<longleftrightarrow> p dvd m \<or> p dvd n" for m n
    by (simp add: assms prime_dvd_mult_iff)

  oops

lemma
  fixes p::nat
  assumes "prime p"
  obtains q where "p<q" "q < p*p" "prime q"
proof -
  have "\<And>m n. p dvd m*n \<longleftrightarrow> p dvd m \<or> p dvd n"
    by (simp add: assms prime_dvd_mult_iff)

  oops

lemma
  assumes "prime p"
  shows "p > 2"

  sorry

lemma "\<lbrakk>0 < N; 0 \<le> x; x < 1\<rbrakk> \<Longrightarrow>  \<lfloor>x * real_of_int N\<rfloor> < N"
  by (simp add: floor_less_iff)

lemma "\<lbrakk>0 < N; 0 \<le> x; x < 1\<rbrakk> \<Longrightarrow> nat \<lfloor>x * real N\<rfloor> < N"
  by (smt (verit) mult_less_cancel_right2 mult_nonneg_nonneg of_nat_0_less_iff of_nat_floor of_nat_less_imp_less)

text \<open>Kevin Buzzard's examples\<close>
lemma
  fixes x::real
  shows "(x+y)*(x+2*y)*(x+3*y) = x^3 + 6*x^2*y + 11*x*y^2 + 6*y^3"
  by (simp add: algebra_simps eval_nat_numeral)

lemma "sqrt 2 + sqrt 3 < sqrt 10"
proof -
  have "(sqrt 2 + sqrt 3)^2 < (sqrt 10)^2"
  proof (simp add: algebra_simps eval_nat_numeral)
    have "(2 * (sqrt 2 * sqrt 3))^2 < 5 ^ 2"
      by (simp add: algebra_simps eval_nat_numeral)
    then show "2 * (sqrt 2 * sqrt 3) < 5"
      by (smt (verit, best) power_mono)
  qed
  then show ?thesis
    by (simp add: real_less_rsqrt)
qed

lemma "sqrt 2 + sqrt 3 < sqrt 10"
  by (approximation 10)

lemma "3.141592635389 < pi"
  by (approximation 30)

lemma "sqrt 2 \<notin> \<rat>"
proof
  assume "sqrt 2 \<in> \<rat>"
  then obtain q::rat where "sqrt 2 = of_rat q"
    using Rats_cases by blast
  then have "q^2 = 2"
    by (metis abs_numeral of_rat_eq_iff of_rat_numeral_eq of_rat_power power2_eq_square real_sqrt_mult_self)
  then obtain m n
    where "coprime m n" "q = of_int m / of_int n"
    by (metis Fract_of_int_quotient Rat_cases)
  then have "of_int m ^ 2 / of_int n ^ 2 = (2::rat)"
    by (metis \<open>q\<^sup>2 = 2\<close> power_divide)
  then have 2: "of_int m ^ 2 = (2::rat) * of_int n ^ 2"
    by (metis division_ring_divide_zero double_eq_0_iff mult_2_right mult_zero_right nonzero_divide_eq_eq)
  then have "2 dvd m"
    by (metis (mono_tags, lifting) even_mult_iff even_numeral of_int_eq_iff of_int_mult of_int_numeral power2_eq_square)
  then obtain r where "m = 2*r"
    by blast
  then have "2 dvd n"
    by (smt (verit) "2" \<open>even m\<close> dvdE even_mult_iff mult.left_commute mult_cancel_left of_int_1 of_int_add of_int_eq_iff of_int_mult one_add_one power2_eq_square)
  then show False
    using \<open>coprime m n\<close> \<open>m = 2 * r\<close> by simp
qed

lemma "\<not> (\<exists>q::rat. q^2 = 2)"
proof
  assume "\<exists>q::rat. q^2 = 2"
  then obtain q::rat and m n
    where "q^2 = 2" "coprime m n" "q = of_int m / of_int n"
    by (meson quotient_of_coprime quotient_of_div surj_pair)
  then have "of_int m ^ 2 / of_int n ^ 2 = (2::rat)"
    by (metis \<open>q\<^sup>2 = 2\<close> power_divide)
  then have 2: "of_int m ^ 2 = (2::rat) * of_int n ^ 2"
    by (metis division_ring_divide_zero double_eq_0_iff mult_2_right mult_zero_right nonzero_divide_eq_eq)
  then have "2 dvd m"
    by (metis (mono_tags, lifting) even_mult_iff even_numeral of_int_eq_iff of_int_mult of_int_numeral power2_eq_square)
  then obtain r where "m = 2*r"
    by blast
  then have "2 dvd n"
    by (smt (verit, ccfv_threshold) "2" Groups.mult_ac(3) dvd_def even_mult_iff mult_cancel_left of_int_1 of_int_add of_int_eq_of_int_power_cancel_iff of_int_mult one_add_one power2_eq_square)
  then show False
    using \<open>coprime m n\<close> \<open>m = 2 * r\<close> by simp
qed

lemma "Nats \<noteq> (Ints :: complex set)"
  by (smt (z3) Ints_minus Nats_altdef1 mem_Collect_eq of_int_eq_iff of_int_minus)

lemma "Nats \<noteq> (Ints :: real set)"
  by (smt (z3) Ints_minus Nats_altdef1 mem_Collect_eq of_int_eq_iff of_int_minus)

thm of_nat_def Int.of_int_def

lemma "Nats \<noteq> (Ints :: 'a::linordered_idom set)"
  by (metis Ints_1 Ints_minus Nats_induct neg_0_le_iff_le not_one_le_zero of_nat_0_le_iff)

lemma "m * 2^(2*m) \<le> 2^(2^m)"
  oops

lemma
  fixes a::real
  shows "(a*b + b * c + c*a)^3 \<le> (a^2 + a * b + b^2) * (b^2 + b * c + c^2) * (c^2 + c*a + a^2)"
  by sos

subsection \<open>Possible library additions\<close>

lemma mono_on_compose: "mono_on f (g ` S) \<Longrightarrow> mono_on g S \<Longrightarrow> mono_on (f \<circ> g) S"
  by (simp add: mono_on_def)

thm of_int_less_iff
context linordered_idom
begin

lemma of_nat_nat_eq_iff: "of_nat (nat i) = of_int i \<longleftrightarrow> 0 \<le> i"
  using local.of_int_le_iff by fastforce

end

lemma inv_into_subset_eq:
  assumes "inj_on f A" "B \<subseteq> A" "b \<in> f ` B"
  shows "inv_into A f b = inv_into B f b"
  using assms inj_on_subset by fastforce

lemma B:
  fixes f :: "'a::linorder \<Rightarrow> 'b::linorder"
  assumes "strict_mono_on f S"
  shows "bij_betw (inv_into S f) (f ` S) S"
  by (meson assms bij_betw_imageI strict_mono_on_imp_inj_on assms bij_betw_inv_into)

lemma C'':
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes "strict_mono_on f {a..b}"  "continuous_on {a..b} f"  "a \<le> b"
    and g: "\<And>x. \<lbrakk>a \<le> x; x \<le> b\<rbrakk> \<Longrightarrow> g (f x) = x"
  shows "strict_mono_on g {f a..f b}"
  by (smt (verit, del_insts) IVT' assms atLeastAtMost_iff le_less linorder_not_le strict_mono_on_def)

lemma C:
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes "strict_mono_on f {a..b}"  "continuous_on {a..b} f"  "a \<le> b"
   shows "strict_mono_on (inv_into {a..b} f) {f a..f b}"
    by (metis assms strict_mono_image_endpoints strict_mono_on_inv_into)

lemma C':
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes sm: "strict_mono_on f {a..}" and "continuous_on {a..} f" and "b \<ge> a"
  shows "strict_mono_on (inv_into {a..} f) {f a..f b}"
  by (smt (verit, ccfv_threshold) C'' Icc_subset_Ici_iff assms(2) assms(3) atLeastAtMost_iff atLeast_iff continuous_on_subset dual_order.refl inv_into_f_f sm strict_mono_on_def strict_mono_on_imp_inj_on)

lemma X:
  fixes a::real
  assumes "strict_mono_on f {0..a}" and f: "(f has_integral I) {0..a}"
    and "a \<ge> 0"
  shows "I \<le> a * f a"
proof -
  have "((\<lambda>x. f a) has_integral a * f a) {0..a}"
    using has_integral_const_real [of "f a" 0 a] \<open>a \<ge> 0\<close>
    by simp
  then show ?thesis
    using has_integral_le [OF f]
    by (metis assms(1) assms(3) atLeastAtMost_iff order_refl strict_mono_on_leD)
qed

thm strict_mono_inv_on_range
lemma strict_mono_on_inv_into:
  fixes f :: "'a::linorder \<Rightarrow> 'b::order"
  assumes "strict_mono_on f S"
  shows "strict_mono_on (inv_into S f) (f ` S)"
  using assms
  unfolding strict_mono_on_def
  by (metis f_inv_into_f inv_into_into less_asym' neqE)

(*DUPLICATE FROM YOUNG'S*)

lemma strict_mono_image_endpoints:
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes "strict_mono_on f {a..b}" and f: "continuous_on {a..b} f" and "a \<le> b"
  shows "f ` {a..b} = {f a..f b}"
proof
  show "f ` {a..b} \<subseteq> {f a..f b}"
    using assms(1) strict_mono_on_leD by fastforce
  show "{f a..f b} \<subseteq> f ` {a..b}"
    using assms IVT'[OF _ _ _ f] by (force simp: Bex_def)
qed

lemma strict_mono_continuous_inv:
  fixes f :: "real \<Rightarrow> real"
  assumes "strict_mono_on f {a..b}" and "continuous_on {a..b} f" and "a \<le> b"
  shows "continuous_on {f a..f b} (inv_into {a..b} f)"
  by (metis strict_mono_image_endpoints assms compact_interval continuous_on_inv inv_into_f_eq strict_mono_on_imp_inj_on)

lemma BB:
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes "strict_mono_on f {a..b}"  "a \<le> b"
    and g: "\<And>x. \<lbrakk>a \<le> x; x \<le> b\<rbrakk> \<Longrightarrow> g (f x) = x"
  shows "continuous_on (f ` {a..b}) g"
proof -
  have "strict_mono_on g (f ` {a..b})"
    by (smt (verit) assms(1) atLeastAtMost_iff g imageE linorder_not_le strict_mono_on_def strict_mono_on_leD)
  show ?thesis

    sorry
  by (smt (verit, del_insts) IVT' assms atLeastAtMost_iff le_less linorder_not_le strict_mono_on_def)

end


section \<open>\isaheader{Maps from Naturals by Arrays}\<close>
theory ArrayMapImpl
imports
  "../spec/MapSpec"
  "../gen_algo/MapGA"
  "../../Lib/Diff_Array"
begin
  text_raw \<open>\label{thy:ArrayMapImpl}\<close>

(*@impl Map
  @type 'v iam
  @abbrv iam,im
  Maps of natural numbers implemented by arrays.
*)

  type_synonym 'v iam = "'v option array"

  subsection \<open>Definitions\<close>
  definition iam_\<alpha> :: "'v iam \<Rightarrow> nat \<rightharpoonup> 'v" where
    "iam_\<alpha> a i \<equiv> if i < array_length a then array_get a i else None"

  abbreviation (input) iam_invar :: "'v iam \<Rightarrow> bool"
    where "iam_invar \<equiv> \<lambda>_. True"

  definition iam_empty :: "unit \<Rightarrow> 'v iam"
    where "iam_empty \<equiv> \<lambda>_::unit. array_of_list []"

  definition iam_lookup :: "nat \<Rightarrow> 'v iam \<rightharpoonup> 'v"
    where [code_unfold]: "iam_lookup k a \<equiv> iam_\<alpha> a k"

  definition "iam_increment (l::nat) idx \<equiv>
    max (idx + 1 - l) (2 * l + 3)"

  lemma incr_correct: "\<not> idx < l \<Longrightarrow> idx < l + iam_increment l idx"
    unfolding iam_increment_def by auto

  definition iam_update :: "nat \<Rightarrow> 'v \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
    where "iam_update k v a \<equiv> let
    l = array_length a;
    a = if k < l then a else array_grow a (iam_increment l k) None
  in
    array_set a k (Some v)
    "

  lemma [code]: "iam_update k v a \<equiv> array_set_oo
    (\<lambda>_. array_set
           (array_grow a (iam_increment (array_length a) k) None) k (Some v))
    a k (Some v)
    "
    unfolding iam_update_def array_set_oo_def
    apply (rule eq_reflection)
    apply (auto simp add: Let_def)
    done

  definition "iam_update_dj \<equiv> iam_update"

  definition iam_delete :: "nat \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
    where "iam_delete k a \<equiv>
    if k<array_length a then array_set a k None else a"

  lemma [code]: "iam_delete k a \<equiv> array_set_oo (\<lambda>_. a) a k None"
    unfolding iam_delete_def array_set_oo_def by auto

  fun iam_rev_iterateoi_aux
    :: "nat \<Rightarrow> ('v iam) \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> (nat \<times> 'v\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where
      "iam_rev_iterateoi_aux 0 a c f \<sigma> = \<sigma>"
    | "iam_rev_iterateoi_aux i a c f \<sigma> = (
        if c \<sigma> then
          iam_rev_iterateoi_aux (i - 1) a c f (
            case array_get a (i - 1) of None \<Rightarrow> \<sigma> | Some x \<Rightarrow> f (i - 1, x) \<sigma>
          )
        else \<sigma>)"

  definition iam_rev_iterateoi :: "'v iam \<Rightarrow> (nat \<times> 'v,'\<sigma>) set_iterator" where
    "iam_rev_iterateoi a \<equiv> iam_rev_iterateoi_aux (array_length a) a"

  function iam_iterateoi_aux
    :: "nat \<Rightarrow> nat \<Rightarrow> ('v iam) \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> (nat \<times> 'v\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where
      "iam_iterateoi_aux i len a c f \<sigma> =
        (if i \<ge> len \<or> \<not> c \<sigma> then \<sigma> else let
            \<sigma>' = (case array_get a i of
              None \<Rightarrow> \<sigma>
            | Some x \<Rightarrow> f (i,x) \<sigma>)
          in iam_iterateoi_aux (i + 1) len a c f \<sigma>')"
    by pat_completeness auto
  termination
    by (relation "measure (\<lambda>(i,l,_). l - i)") auto

  declare iam_iterateoi_aux.simps[simp del]

  lemma iam_iterateoi_aux_csimps:
    "i \<ge> len \<Longrightarrow> iam_iterateoi_aux i len a c f \<sigma> = \<sigma>"
    "\<not> c \<sigma> \<Longrightarrow> iam_iterateoi_aux i len a c f \<sigma> = \<sigma>"
    "\<lbrakk> i< len; c \<sigma> \<rbrakk> \<Longrightarrow> iam_iterateoi_aux i len a c f \<sigma> =
      (case array_get a i of
        None \<Rightarrow> iam_iterateoi_aux (i + 1) len a c f \<sigma>
      | Some x \<Rightarrow> iam_iterateoi_aux (i + 1) len a c f (f (i,x) \<sigma>))"
    apply (subst iam_iterateoi_aux.simps, simp)
    apply (subst iam_iterateoi_aux.simps, simp)
    apply (subst iam_iterateoi_aux.simps)
    apply (auto split: option.split_asm option.split)
    done

  definition iam_iterateoi :: "'v iam \<Rightarrow> (nat \<times> 'v,'\<sigma>) set_iterator" where
    "iam_iterateoi a = iam_iterateoi_aux 0 (array_length a) a"

  lemma iam_empty_impl: "map_empty iam_\<alpha> iam_invar iam_empty"
    apply unfold_locales
    unfolding iam_\<alpha>_def[abs_def] iam_empty_def
    by auto

  lemma iam_lookup_impl: "map_lookup iam_\<alpha> iam_invar iam_lookup"
    apply unfold_locales
    unfolding iam_\<alpha>_def[abs_def] iam_lookup_def
    by auto

  lemma array_get_set_iff: "i<array_length a \<Longrightarrow>
    array_get (array_set a i x) j = (if i=j then x else array_get a j)"
    by (auto simp: array_get_array_set_other)

  lemma iam_update_impl: "map_update iam_\<alpha> iam_invar iam_update"
    apply unfold_locales
    unfolding iam_\<alpha>_def[abs_def] iam_update_def
    apply (rule ext)
    apply (auto simp: Let_def array_get_set_iff incr_correct)
    done

  lemma iam_update_dj_impl: "map_update_dj iam_\<alpha> iam_invar iam_update_dj"
    apply (unfold iam_update_dj_def)
    apply (rule update_dj_by_update)
    apply (rule iam_update_impl)
    done

  lemma iam_delete_impl: "map_delete iam_\<alpha> iam_invar iam_delete"
    apply unfold_locales
    unfolding iam_\<alpha>_def[abs_def] iam_delete_def
    apply (rule ext)
    apply (auto simp: Let_def array_get_set_iff)
    done

  lemma iam_rev_iterateoi_aux_foldli_conv :
    "iam_rev_iterateoi_aux n a =
     foldli (List.map_filter (\<lambda>n. map_option (\<lambda>v. (n, v)) (array_get a n)) (rev [0..<n]))"
  by (induct n) (auto simp add: List.map_filter_def fun_eq_iff)

  lemma iam_rev_iterateoi_foldli_conv :
    "iam_rev_iterateoi a =
     foldli (List.map_filter
       (\<lambda>n. map_option (\<lambda>v. (n, v)) (array_get a n))
       (rev [0..<(array_length a)]))"
    unfolding iam_rev_iterateoi_def iam_rev_iterateoi_aux_foldli_conv by simp

  lemma iam_rev_iterateoi_correct :
  fixes m::"'a option array"
  defines "kvs \<equiv> List.map_filter
    (\<lambda>n. map_option (\<lambda>v. (n, v)) (array_get m n)) (rev [0..<(array_length m)])"
  shows "map_iterator_rev_linord (iam_rev_iterateoi m) (iam_\<alpha> m)"
  proof (rule map_iterator_rev_linord_I [of kvs])
    show "iam_rev_iterateoi m = foldli kvs"
      unfolding iam_rev_iterateoi_foldli_conv kvs_def by simp
  next
    define al where "al = array_length m"
    show dist_kvs: "distinct (map fst kvs)" and "sorted (rev (map fst kvs))"
      unfolding kvs_def al_def[symmetric]
      apply (induct al)
      apply (simp_all
        add: List.map_filter_simps set_map_filter image_iff sorted_append
        split: option.split)
    done

    from dist_kvs
    have "\<And>i. map_of kvs i = iam_\<alpha> m i"
      unfolding kvs_def
      apply (case_tac "array_get m i")
      apply (simp_all
        add: iam_\<alpha>_def map_of_eq_None_iff set_map_filter image_iff)
    done
    thus "iam_\<alpha> m = map_of kvs" by auto
  qed

  lemma iam_rev_iterateoi_impl:
    "poly_map_rev_iterateoi iam_\<alpha> iam_invar iam_rev_iterateoi"
    apply unfold_locales
    apply (simp add: iam_\<alpha>_def[abs_def] dom_def)
    apply (simp add: iam_rev_iterateoi_correct)
    done

  lemma iam_iteratei_impl:
    "poly_map_iteratei iam_\<alpha> iam_invar iam_rev_iterateoi"
  proof -
    interpret aux: poly_map_rev_iterateoi iam_\<alpha> iam_invar iam_rev_iterateoi
      by (rule iam_rev_iterateoi_impl)

    show ?thesis
      apply unfold_locales
      apply (rule map_rev_iterator_linord_is_it)
      by (rule aux.list_rev_it_correct)
  qed

  lemma iam_iterateoi_aux_foldli_conv :
    "iam_iterateoi_aux n (array_length a) a c f \<sigma> =
     foldli (List.map_filter (\<lambda>n. map_option (\<lambda>v. (n, v)) (array_get a n))
       ([n..<array_length a])) c f \<sigma>"
    thm iam_iterateoi_aux.induct
    apply (induct n "array_length a" a c f \<sigma> rule: iam_iterateoi_aux.induct)
    apply (subst iam_iterateoi_aux.simps)
    apply (auto split: option.split simp: map_filter_simps)
    apply (subst (2) upt_conv_Cons)
    apply simp
    apply (simp add: map_filter_simps)
    apply (subst (2) upt_conv_Cons)
    apply simp
    apply (simp add: map_filter_simps)
    done

  lemma iam_iterateoi_foldli_conv :
    "iam_iterateoi a =
     foldli (List.map_filter
       (\<lambda>n. map_option (\<lambda>v. (n, v)) (array_get a n))
       ([0..<(array_length a)]))"
    apply (intro ext)
    unfolding iam_iterateoi_def iam_iterateoi_aux_foldli_conv
    by simp

  (* TODO: Move to Misc *)
  lemmas [simp] = map_filter_simps
  lemma map_filter_append[simp]: "List.map_filter f (la@lb)
    = List.map_filter f la @ List.map_filter f lb"
    by (induct la) (auto split: option.split)

  lemma iam_iterateoi_correct:
  fixes m::"'a option array"
  defines "kvs \<equiv> List.map_filter
    (\<lambda>n. map_option (\<lambda>v. (n, v)) (array_get m n)) ([0..<(array_length m)])"
  shows "map_iterator_linord (iam_iterateoi m) (iam_\<alpha> m)"
  proof (rule map_iterator_linord_I [of kvs])
    show "iam_iterateoi m = foldli kvs"
      unfolding iam_iterateoi_foldli_conv kvs_def by simp
  next
    define al where "al = array_length m"
    show dist_kvs: "distinct (map fst kvs)" and "sorted (map fst kvs)"
      unfolding kvs_def al_def[symmetric]
      apply (induct al)
      apply (simp_all
        add: set_map_filter image_iff sorted_append
        split: option.split)
    done

    from dist_kvs
    have "\<And>i. map_of kvs i = iam_\<alpha> m i"
      unfolding kvs_def
      apply (case_tac "array_get m i")
      apply (simp_all
        add: iam_\<alpha>_def map_of_eq_None_iff set_map_filter image_iff)
    done
    thus "iam_\<alpha> m = map_of kvs" by auto
  qed

  lemma iam_iterateoi_impl:
    "poly_map_iterateoi iam_\<alpha> iam_invar iam_iterateoi"
    apply unfold_locales
    apply (simp add: iam_\<alpha>_def[abs_def] dom_def)
    apply (simp add: iam_iterateoi_correct)
    done

  definition iam_basic_ops :: "(nat,'a,'a iam) omap_basic_ops"
    where [icf_rec_def]: "iam_basic_ops \<equiv> \<lparr>
    bmap_op_\<alpha> = iam_\<alpha>,
    bmap_op_invar = \<lambda>_. True,
    bmap_op_empty = iam_empty,
    bmap_op_lookup = iam_lookup,
    bmap_op_update = iam_update,
    bmap_op_update_dj = iam_update_dj,
    bmap_op_delete = iam_delete,
    bmap_op_list_it = iam_rev_iterateoi,
    bmap_op_ordered_list_it = iam_iterateoi,
    bmap_op_rev_list_it = iam_rev_iterateoi
    \<rparr>"

  setup Locale_Code.open_block
  interpretation iam_basic: StdBasicOMap iam_basic_ops
    apply (rule StdBasicOMap.intro)
    apply (rule StdBasicMap.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule iam_empty_impl iam_lookup_impl iam_update_impl
      iam_update_dj_impl iam_delete_impl iam_iteratei_impl
      iam_iterateoi_impl iam_rev_iterateoi_impl)+
    done
  setup Locale_Code.close_block

  definition [icf_rec_def]: "iam_ops \<equiv> iam_basic.dflt_oops"

  setup Locale_Code.open_block
  interpretation iam: StdOMap iam_ops
    unfolding iam_ops_def
    by (rule iam_basic.dflt_oops_impl)
  interpretation iam: StdMap_no_invar iam_ops
    by unfold_locales (simp add: icf_rec_unf)
  setup Locale_Code.close_block
  setup \<open>ICF_Tools.revert_abbrevs "iam"\<close>

  lemma pi_iam[proper_it]:
    "proper_it' iam_iterateoi iam_iterateoi"
    apply (rule proper_it'I)
    unfolding iam_iterateoi_foldli_conv
    by (rule icf_proper_iteratorI)

  lemma pi_iam_rev[proper_it]:
    "proper_it' iam_rev_iterateoi iam_rev_iterateoi"
    apply (rule proper_it'I)
    unfolding iam_rev_iterateoi_foldli_conv
    by (rule icf_proper_iteratorI)

  interpretation pi_iam: proper_it_loc iam_iterateoi iam_iterateoi
    apply unfold_locales by (rule pi_iam)

  interpretation pi_iam_rev: proper_it_loc iam_rev_iterateoi iam_rev_iterateoi
    apply unfold_locales by (rule pi_iam_rev)

text \<open>Code generator test\<close>
definition "test_codegen \<equiv> (
  iam.add ,
  iam.add_dj ,
  iam.ball ,
  iam.bex ,
  iam.delete ,
  iam.empty ,
  iam.isEmpty ,
  iam.isSng ,
  iam.iterate ,
  iam.iteratei ,
  iam.iterateo ,
  iam.iterateoi ,
  iam.list_it ,
  iam.lookup ,
  iam.max ,
  iam.min ,
  iam.restrict ,
  iam.rev_iterateo ,
  iam.rev_iterateoi ,
  iam.rev_list_it ,
  iam.reverse_iterateo ,
  iam.reverse_iterateoi ,
  iam.sel ,
  iam.size ,
  iam.size_abort ,
  iam.sng ,
  iam.to_list ,
  iam.to_map ,
  iam.to_rev_list ,
  iam.to_sorted_list ,
  iam.update ,
  iam.update_dj)"

export_code test_codegen checking SML

end