theory Invariants
imports "TrTermination" "PathInvariant"
begin

definition basic_inv :: "global0 \<Rightarrow> bool" where
"basic_inv g = (memu_invariant g \<and> gas_invariant g \<and>
   total_balance (g_orig g) < 2^256 \<and> balance_inv g)"

lemma orig_balance :
  "total_balance (g_orig g) < 2^256 \<Longrightarrow>
   balance_inv g \<Longrightarrow>
   total_balance (g_current g) < 2^256"
  using inv_orig_current by fastforce

type_synonym 'a rel = "'a Relation.rel"

definition tr :: "network \<Rightarrow> global0 rel" where
"tr net = {(a,b) | a b. Continue b = next0 net (Continue a) }"

lemma basic_invariant :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   basic_inv st1 \<Longrightarrow>
   basic_inv st2"
apply (simp add:tr_def)
  by (metis basic_inv_def gas_next memu_next orig_balance tr_balance_continue tr_orig)

(* call stack changes *)

lemma stack_changes :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st1, g_stack st2) \<in> push_pop"
by (auto simp add:next0_def tr_def tlR_def push_pop_def Let_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(* account existence *)

lemma exist_return :
  "account_exists (update_return st1 addr2 x32 addr) =
   account_exists (st1 addr)"
by (auto simp add:update_return_def update_world_def)

lemma exist_call :
  "account_exists (update_call st1 addr2 x32 addr) =
   account_exists (st1 addr)"
by (auto simp add:update_call_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma exist_transfer :
  "account_exists (transfer_balance st1 addr2 x32 v addr) =
   account_exists (st1 addr)"
by (auto simp add:update_call_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma exist_update :
  "account_exists (update_world st1 addr2 acc addr) =
   ( if addr2 = addr then account_exists acc
     else account_exists (st1 addr))"
by (auto simp add:update_call_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma exist_nonce :
  "account_exists (update_nonce st1 addr2 addr) =
   account_exists (st1 addr)"
by (auto simp add:update_nonce_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma exist_same :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = g_stack st1 \<Longrightarrow>
   account_exists (g_current st1 addr) =
   account_exists (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def
  exist_return
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(*
lemma tl_wf : "(tl x22 = a # x22) = False"
by (auto simp add:tl_def split:list.splits)
*)

lemma exist_push :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_exists (g_current st2 addr)"
by (auto simp add:tr_def tlR_def next0_def Let_def
  exist_return exist_call exist_transfer
  exist_update exist_nonce
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma exist_pop :
  "(st1, st2) \<in> tr net \<Longrightarrow>
(*   (g_stack st1, g_stack st2) \<in> tlR \<Longrightarrow> *)
   hd (g_stack st1) = (a,b,c,d)  \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_exists (a addr) \<Longrightarrow>
   account_exists (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def tlR_def
  exist_return exist_call exist_transfer
  exist_update exist_nonce (* weird_weird weird_weird2 *)
  create_account_def
  set_account_code_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma exist_push2 :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = (a,b,c,d) # g_stack st1 \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_exists (a addr)"
by (auto simp add:next0_def Let_def
  exist_return exist_call exist_transfer
  exist_update exist_nonce tr_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma exist_push3 :
   "(st1, st2) \<in> tr net \<Longrightarrow>
       g_stack st2 =
       (a, aa, ab, b) # g_stack st1 \<Longrightarrow>
       account_exists (a addr) \<Longrightarrow>
       account_exists (g_current st2 addr)"
by (auto simp add:next0_def Let_def
  exist_return exist_call exist_transfer
  exist_update exist_nonce tr_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

fun stack_hint :: "world_state * variable_ctx * constant_ctx * stack_hint \<Rightarrow> stack_hint" where
"stack_hint (a,b,c,d) = d"

fun stack_cctx :: "world_state * variable_ctx * constant_ctx * stack_hint \<Rightarrow> constant_ctx" where
"stack_cctx (a,b,c,d) = c"

fun stack_vctx :: "world_state * variable_ctx * constant_ctx * stack_hint \<Rightarrow> variable_ctx" where
"stack_vctx (a,b,c,d) = b"

fun stack_state :: "world_state * variable_ctx * constant_ctx * stack_hint \<Rightarrow> world_state" where
"stack_state (a,b,c,d) = a"

definition states_t :: "global0 \<Rightarrow> world_state * world_state list" where
"states_t g = (g_current g, map stack_state (g_stack g))"

lemma exist_mono :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (states_t st1, states_t st2) \<in> mono_rules
      (\<lambda>st. account_exists (st addr))"
apply (cases "g_stack st1 = g_stack st2")
apply (subgoal_tac "(states_t st1, states_t st2)
    \<in> mono_same (\<lambda>st. account_exists (st addr))")
apply (simp add:mono_rules_def)
apply (clarsimp simp add:mono_same_def states_t_def)
  apply (simp add: exist_same)
apply (cases "(g_stack st1,g_stack st2) \<in> tlR")
apply (subgoal_tac "(states_t st1, states_t st2)
    \<in> mono_pop (\<lambda>st. account_exists (st addr))")
apply (simp add:mono_rules_def)
apply (clarsimp simp add:mono_pop_def states_t_def tlR_def)
  apply (simp add: exist_pop)
apply (cases "(g_stack st2,g_stack st1) \<in> tlR")
apply (subgoal_tac "(states_t st1, states_t st2)
    \<in> mono_push (\<lambda>st. account_exists (st addr))")
apply (simp add:mono_rules_def)
apply (auto simp add:mono_push_def states_t_def tlR_def)
  using exist_push2 apply blast
  using exist_push3 apply blast
using stack_changes [of st1 st2 net]
apply (simp add:push_pop_def tlR_def)
done

lemma can_exit :
  "Finished st2 = next0 net (Continue st1) \<Longrightarrow>
   length (g_stack st1) = 0 \<or>
   length (g_stack st1) = 1 \<and> g_create st1"
by (auto simp add:next0_def Let_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma create_const :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_create st1 = g_create st2"
by (auto simp add:next0_def Let_def tr_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(* code changes *)
lemma code_return :
  "account_code0 (update_return st1 addr2 x32 addr) =
   account_code0 (st1 addr)"
by (auto simp add:update_return_def update_world_def)

lemma code_call :
  "account_code0 (update_call st1 addr2 x32 addr) =
   account_code0 (st1 addr)"
by (auto simp add:update_call_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma code_transfer :
  "account_code0 (transfer_balance st1 addr2 x32 v addr) =
   account_code0 (st1 addr)"
by (auto simp add:update_call_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma code_update :
  "account_code0 (update_world st1 addr2 acc addr) =
   ( if addr2 = addr then account_code0 acc
     else account_code0 (st1 addr))"
by (auto simp add:update_call_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma code_nonce :
  "account_code0 (update_nonce st1 addr2 addr) =
   account_code0 (st1 addr)"
by (auto simp add:update_nonce_def transfer_balance_def
   add_balance_def sub_balance_def Let_def update_world_def)

lemma code_stay :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = g_stack st1 \<Longrightarrow>
   account_code0 (g_current st1 addr) =
   account_code0 (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def
  code_return
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(* separate cases for fail etc. *)
lemma code_fail :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 = InstructionToEnvironment (ContractFail lst) v1 hint \<Longrightarrow>
   hd (g_stack st1) = (a,b,c,d) \<Longrightarrow>
   account_code0 (a addr) =
   account_code0 (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def
  code_return
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma code_suicide :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 = InstructionToEnvironment (ContractSuicide lst) v1 hint \<Longrightarrow>
   stack_hint (hd (g_stack st1)) \<noteq> CreateAddress addr \<Longrightarrow>
   account_code0 (g_current st1 addr) =
   account_code0 (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def
  code_return code_update create_account_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma code_ret :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 = InstructionToEnvironment (ContractReturn lst) v1 hint \<Longrightarrow>
   stack_hint (hd (g_stack st1)) \<noteq> CreateAddress addr \<Longrightarrow>
   account_code0 (g_current st2 addr) =
   account_code0 (g_current st1 addr) \<or>
   account_code0 (g_current st2 addr) =
   account_code0 (stack_state (hd (g_stack st1)) addr)"
by (auto simp add:next0_def Let_def tr_def
  code_return code_update create_account_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(* in the hypotheses, matters a lot if it is a=b or b=a *)
lemma code_push :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_code0 (g_current st1 addr) =
   account_code0 (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def tlR_def
  code_return code_call code_transfer code_update
  code_nonce
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma code_push2 :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = (a,b,c,d) # g_stack st1 \<Longrightarrow>
   account_code0 (g_current st1 addr) = account_code0 (a addr)"
by (auto simp add:next0_def Let_def tr_def tlR_def
  code_return code_call code_transfer code_update
  code_nonce
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma code_push3 :
   "(st1, st2) \<in> tr net \<Longrightarrow>
    g_stack st2 =
    (a, aa, ab, b) # g_stack st1 \<Longrightarrow>
    account_exists (g_current st1 addr) \<Longrightarrow>
    account_code0 (a addr) = account_code0 (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def tlR_def
  code_return code_call code_transfer code_update
  code_nonce
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma push_create_hint :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = abcd # g_stack st1 \<Longrightarrow>
   stack_hint abcd = CreateAddress addr \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   False"
by (auto simp add:next0_def Let_def tr_def
  code_return code_call
  code_transfer code_update
  code_nonce get_hint_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(* how to apply this with mono invariants? *)

definition create_exist_inv :: "address \<Rightarrow> global0 \<Rightarrow> bool" where
"create_exist_inv addr g =
   (\<forall>el \<in> set (g_stack g).
          account_exists (stack_state el addr) \<longrightarrow>
          stack_hint el \<noteq> CreateAddress addr)"

lemma create_exist_inv_stay :
  "g_stack st2 = g_stack st1 \<Longrightarrow>
   create_exist_inv addr st1 \<Longrightarrow>
   create_exist_inv addr st2"
by (simp add:create_exist_inv_def)

lemma create_exist_inv_pop :
  "(g_stack st1, g_stack st2) \<in> tlR \<Longrightarrow>
   create_exist_inv addr st1 \<Longrightarrow>
   create_exist_inv addr st2"
by (auto simp add:create_exist_inv_def tlR_def)

lemma create_exist_inv_push :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = abcd # g_stack st1 \<Longrightarrow>
   create_exist_inv addr st1 \<Longrightarrow>
   create_exist_inv addr st2"
by (auto simp add:next0_def Let_def tr_def
  code_return code_call create_exist_inv_def
  code_transfer code_update
  code_nonce get_hint_def exist_nonce
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma create_exist_inv :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   create_exist_inv addr st1 \<Longrightarrow>
   create_exist_inv addr st2"
by (auto simp add:next0_def Let_def tr_def
  code_return code_call create_exist_inv_def
  code_transfer code_update
  code_nonce get_hint_def exist_nonce
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma pop_alt :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st1, g_stack st2) \<in> tlR \<Longrightarrow>
   g_vmstate st1 \<in>
    {InstructionToEnvironment (ContractReturn a) v h|
     a v h. True} \<union>
    {InstructionToEnvironment (ContractFail a) v h|
     a v h. True} \<union>
    {InstructionToEnvironment (ContractSuicide a) v h|
     a v h. True}"
by (auto simp add:next0_def Let_def tr_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma check_hint :
 "create_exist_inv addr st1 \<Longrightarrow>
  (g_stack st1, g_stack st2) \<in> tlR \<Longrightarrow>
  account_exists
     (stack_state (hd (g_stack st1)) addr) \<Longrightarrow>
  stack_hint (hd (g_stack st1)) \<noteq> CreateAddress addr"
by (cases "g_stack st1"; auto simp add:tlR_def create_exist_inv_def)

lemma code_pop :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st1, g_stack st2) \<in> tlR \<Longrightarrow>
   account_code0 (g_current st1 addr) = cd \<Longrightarrow>
   account_code0 (stack_state (hd (g_stack st1)) addr) = cd \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   create_exist_inv addr st1 \<Longrightarrow>
   account_exists (stack_state (hd (g_stack st1)) addr) \<Longrightarrow>
   account_code0 (g_current st2 addr) = cd"
using pop_alt [of st1 st2 net]
apply auto
subgoal for a v h
using code_ret [of st1 st2 net a v h addr]
   check_hint [of addr st1 st2]
apply force
done
using code_fail [of st1 st2 net]
  apply (metis stack_state.elims)
subgoal for a v h
using code_suicide [of st1 st2 net a v h addr]
   check_hint [of addr st1 st2]
apply force
done
done

definition code_inv :: "address \<Rightarrow> program \<Rightarrow> world_state \<Rightarrow> bool" where
"code_inv addr cd st = (
  account_exists (st addr) \<and> account_code0 (st addr) = cd)"

lemma monoI_head :
   "monoI iv st \<Longrightarrow>
    snd st = a#rest \<Longrightarrow>
    iv a \<Longrightarrow>
    iv (fst st)"
by (auto simp add:monoI_def)

lemma exist_push4 :
   "(st1, st2) \<in> tr net \<Longrightarrow>
       g_stack st2 =
       (a, aa, ab, b) # g_stack st1 \<Longrightarrow>
       account_exists (a addr) \<Longrightarrow>
       account_exists (g_current st1 addr)"
by (auto simp add:next0_def Let_def
  exist_return exist_call exist_transfer
  exist_update exist_nonce tr_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma code_mono :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   create_exist_inv addr st1 \<Longrightarrow>
   (states_t st1, states_t st2) \<in> mono_rules (code_inv addr cd)"
apply (cases "g_stack st1 = g_stack st2")
apply (subgoal_tac "(states_t st1, states_t st2)
    \<in> mono_same (code_inv addr cd)")
apply (simp add:mono_rules_def)
apply (clarsimp simp add:mono_same_def states_t_def)
  apply (simp add: exist_same code_inv_def mono_pop_def
      code_stay)

apply (cases "(g_stack st1,g_stack st2) \<in> tlR")
apply (subgoal_tac "(states_t st1, states_t st2)
    \<in> mono_pop (code_inv addr cd)")
apply (simp add:mono_rules_def)
apply (clarsimp simp add:mono_pop_def states_t_def tlR_def)
  apply (auto simp add: exist_pop code_inv_def)
using code_pop [of st1 st2 net addr cd]
apply (simp add:tlR_def)

apply (cases "(g_stack st2,g_stack st1) \<in> tlR")
apply (subgoal_tac "(states_t st1, states_t st2)
    \<in> mono_push (code_inv addr cd)")
apply (simp add:mono_rules_def)
apply (auto simp add:mono_push_def states_t_def tlR_def
      code_inv_def)
  using exist_push2 apply blast
  apply (simp add: code_push2)

  using exist_push3 apply blast
subgoal for a b c d
using code_push3 [of st1 st2 net a b c d addr]
  exist_push4 [of st1 st2 net a b c d addr]
apply force
done

using stack_changes [of st1 st2 net]
apply (simp add:push_pop_def tlR_def)
done

definition cctx :: "global0 \<Rightarrow> constant_ctx list" where
"cctx g = g_cctx g # map stack_cctx (g_stack g)"

lemma cctx_changes :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (cctx st1, cctx st2) \<in> push_pop"
by (auto simp add:next0_def tr_def tlR_def cctx_def
    push_pop_def Let_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(* storage changes *)
(* storage changes are first the same as code changes, but also from
   calls out *)
lemma storage_continue :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> range InstructionContinue \<Longrightarrow>
   account_storage0 (g_current st1 addr) =
   account_storage0 (g_current st2 addr)"
by (auto simp add:next0_def Let_def tr_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma storage_pop :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_storage0 (g_current st2 addr) =
   account_storage0 (g_current st1 addr) \<or>
   account_storage0 (g_current st2 addr) =
   account_storage0 (stack_state (hd (g_stack st1)) addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def
  create_account_def set_account_code_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma storage_push :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_storage0 (g_current st2 addr) =
   account_storage0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma storage_push2 :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   account_storage0 (stack_state (hd (g_stack st2)) addr) =
   account_storage0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma storage_failed_call :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = g_stack st1 \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_storage0 (g_current st2 addr) =
   account_storage0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

(* balance changes *)

lemma state_continue :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> range InstructionContinue \<Longrightarrow>
   g_current st1 = g_current st2"
by (auto simp add:next0_def Let_def tr_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma balance_failed_call :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st2 = g_stack st1 \<Longrightarrow>
   account_balance0 (g_current st2 addr) =
   account_balance0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma balance_push2 :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   account_balance0 (stack_state (hd (g_stack st2)) addr) =
   account_balance0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

definition return_state :: "instruction_result set" where
"return_state = {InstructionToEnvironment (ContractReturn a) v h|
     a v h. True}"

lemma balance_ret :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> return_state \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_balance0 (g_current st2 addr) =
   account_balance0 (g_current st1 addr) \<or>
   account_balance0 (g_current st2 addr) =
   account_balance0 (stack_state (hd (g_stack st1)) addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def return_state_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

definition fail_state :: "instruction_result set" where
"fail_state = {InstructionToEnvironment (ContractFail a) v h|
     a v h. True}"

lemma balance_fail :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> fail_state \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_balance0 (g_current st2 addr) =
   account_balance0 (stack_state (hd (g_stack st1)) addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def
  update_call_def fail_state_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

definition suicide_state :: "instruction_result set" where
"suicide_state = {InstructionToEnvironment (ContractSuicide a) v h|
     a v h. True}"

lemma balance_add_aux :
 "total_balance bal < 2^256 \<Longrightarrow>
  a \<noteq> b \<Longrightarrow>
  account_balance0 (bal a) \<le>
  account_balance0 (bal a) + account_balance0 (bal b)"
  by (metis order_refl overflow)

lemma balance_add :
 "balance_inv st \<Longrightarrow>
  total_balance (g_orig st) < 2^256 \<Longrightarrow>
  sender \<noteq> recv \<Longrightarrow>
  account_balance0 (g_current st recv) \<le>
  account_balance0 (g_current st recv) +
  account_balance0 (g_current st sender)"
  using orig_balance  balance_add_aux by fastforce

lemma balance_suicide :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   balance_inv st1 \<Longrightarrow>
   total_balance (g_orig st1) < 2^256 \<Longrightarrow>
   g_vmstate st1 \<in> suicide_state \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   account_balance0 (g_current st2 addr) \<ge>
   account_balance0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def
  sub_balance_def balance_add
  update_call_def suicide_state_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

definition create_state :: "instruction_result set" where
"create_state = {InstructionToEnvironment (ContractCreate a) v h|
     a v h. True}"

lemma balance_create :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> create_state \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_balance0 (g_current st2 addr) =
   account_balance0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def sub_balance_def
  update_call_def create_state_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

definition call_state :: "instruction_result set" where
"call_state = {InstructionToEnvironment (ContractCall a) v h|
     a v h. True} \<union>
{InstructionToEnvironment (ContractDelegateCall a) v h|
     a v h. True}"

lemma balance_add2 :
 "balance_inv st \<Longrightarrow>
  total_balance (g_orig st) < 2^256 \<Longrightarrow>
  sender \<noteq> recv \<Longrightarrow>
  x \<le> account_balance0 (g_current st sender) \<Longrightarrow>
  account_balance0 (g_current st recv) \<le>
  account_balance0 (g_current st recv) + x"
  using orig_balance overflow by blast

lemma balance_call :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   balance_inv st1 \<Longrightarrow>
   total_balance (g_orig st1) < 2^256 \<Longrightarrow>
   g_vmstate st1 \<in> call_state \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_balance0 (g_current st2 addr) \<ge>
   account_balance0 (g_current st1 addr)"
apply (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def sub_balance_def
  update_call_def call_state_def
  create_account_def set_account_code_def tlR_def
  balance_add2
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)
(* *)
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
using balance_add2 [of st1 "cctx_this (g_cctx st1)" addr]
apply fastforce
done

lemma balance_storage_ret :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> return_state \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_balance0 (g_current st2 addr) =
   account_balance0 (g_current st1 addr) \<and>
   account_storage0 (g_current st2 addr) =
   account_storage0 (g_current st1 addr) \<or>
   account_balance0 (g_current st2 addr) =
   account_balance0 (stack_state (hd (g_stack st1)) addr) \<and>
   account_storage0 (g_current st2 addr) =
   account_storage0 (stack_state (hd (g_stack st1)) addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def sub_balance_def
  update_call_def return_state_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma storage_fail :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> fail_state \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_storage0 (g_current st2 addr) =
   account_storage0 (stack_state (hd (g_stack st1)) addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def sub_balance_def
  update_call_def fail_state_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma storage_suicide :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_vmstate st1 \<in> suicide_state \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   account_storage0 (g_current st2 addr) =
   account_storage0 (g_current st1 addr)"
by (auto simp add:next0_def Let_def tr_def
  update_return_def update_world_def
  transfer_balance_def update_nonce_def
  add_balance_def sub_balance_def
  update_call_def suicide_state_def
  create_account_def set_account_code_def tlR_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

definition good_inv :: "(account \<Rightarrow> bool) \<Rightarrow> bool" where
"good_inv iv = (\<forall>a b.
   account_storage0 a = account_storage0 b \<longrightarrow>
   account_balance0 a \<le> account_balance0 b \<longrightarrow>
   iv a \<longrightarrow> iv b)"

lemma pop_alt2 :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st1, g_stack st2) \<in> tlR \<Longrightarrow>
   g_vmstate st1 \<in> return_state \<union> fail_state \<union> suicide_state"
unfolding return_state_def fail_state_def
  suicide_state_def
using pop_alt by simp

lemma good_iv_helper :
  "good_inv iv \<Longrightarrow>
   account_balance0 a2 =  account_balance0 a1 \<and>
   account_storage0 a2 = account_storage0 a1 \<or>
   account_balance0 a2 = account_balance0 a0 \<and>
   account_storage0 a2 = account_storage0 a0 \<Longrightarrow>
   iv a1 \<Longrightarrow>
   iv a0 \<Longrightarrow>
   iv a2"
unfolding good_inv_def
  by (metis order_refl)

lemma iv_pop :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st1, g_stack st2) \<in> tlR \<Longrightarrow>
   balance_inv st1 \<Longrightarrow>
   total_balance (g_orig st1) < 2 ^ 256 \<Longrightarrow>
   good_inv iv \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   iv (g_current st1 addr) \<Longrightarrow>
   iv (stack_state (hd (g_stack st1)) addr) \<Longrightarrow>
   iv (g_current st2 addr)"
using pop_alt2 [of st1 st2 net]
apply auto
  using balance_storage_ret good_iv_helper apply blast
apply (auto simp add:good_inv_def)
  apply (metis (no_types, hide_lams) balance_fail order_refl storage_fail)
using storage_suicide [of st1 st2 net addr]
apply simp
using balance_suicide [of st1 st2 net addr]
apply simp
done

lemma push_alt :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   g_vmstate st1 \<in> call_state \<union> create_state"
by (auto simp add:next0_def Let_def tr_def tlR_def
  create_state_def call_state_def
  split:if_split_asm option.split_asm list.split_asm
   contract_action.split_asm stack_hint.split_asm
   instruction_result.splits)

lemma iv_same :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   g_stack st1 = g_stack st2 \<Longrightarrow>
   good_inv iv \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   iv (g_current st1 addr) \<Longrightarrow>
   iv (g_current st2 addr)"
unfolding good_inv_def
by (metis balance_failed_call good_inv_def good_iv_helper storage_failed_call)

lemma iv_push2 :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   good_inv iv \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   iv (g_current st1 addr) \<Longrightarrow>
   iv (stack_state (hd (g_stack st2)) addr)"
  by (simp add: good_inv_def balance_push2 storage_push2)

lemma iv_push :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   (g_stack st2, g_stack st1) \<in> tlR \<Longrightarrow>
   balance_inv st1 \<Longrightarrow>
   total_balance (g_orig st1) < 2 ^ 256 \<Longrightarrow>
   good_inv iv \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   iv (g_current st1 addr) \<Longrightarrow>
   iv (g_current st2 addr)"
using push_alt [of st1 st2 net]
apply auto
using storage_push [of st1 st2 net addr]
using balance_call [of st1 st2 net addr]
apply (simp add:good_inv_def)
using storage_push [of st1 st2 net addr]
using balance_create [of st1 st2 net addr]
  using good_iv_helper by blast

lemma iv_mono :
  "(st1, st2) \<in> tr net \<Longrightarrow>
   balance_inv st1 \<Longrightarrow>
   total_balance (g_orig st1) < 2 ^ 256 \<Longrightarrow>
   good_inv iv \<Longrightarrow>
   account_exists (g_current st1 addr) \<Longrightarrow>
   cctx_this (g_cctx st1) \<noteq> addr \<Longrightarrow>
   \<forall>s1 \<in> set (states st1). iv (s1 addr) \<Longrightarrow>
   s2 \<in> set (states st2) \<Longrightarrow>
   iv (s2 addr)"
using stack_changes [of st1 st2 net]
apply (auto simp add:push_pop_def states_def tlR_def)
  using iv_same apply blast
subgoal
using iv_pop [of st1 st2 net iv addr]
apply (auto simp add:tlR_def)
done
subgoal
using iv_push [of st1 st2 net iv addr]
apply (auto simp add:tlR_def)
done
using iv_push2 [of st1 st2 net iv addr]
apply (auto simp add:tlR_def)
done

end


theory InferDef
  imports AltFlatLemma InferVar
begin

    (* type inferencing constraints *)

datatype perm_crn =
  UnifyCrn s_type s_type
  (*| MemValCrn s_type s_type*)
  | LeqCrn x_perm s_perm
  | LeqTypeCrn s_type s_perm
  (*| EqTypeCrn s_type s_perm*)
  | DisjCrn x_perm x_perm
  | SemiDisjCrn x_perm x_perm

    (* constant / op "types":  *)

fun list_contain where
  "list_contain [] x = False"
| "list_contain (y # t) x = (x = y \<or> list_contain t x)"

fun fresh_in_list where
  "fresh_in_list [] = True"
| "fresh_in_list (x # t) = (\<not> list_contain t x \<and> fresh_in_list t)"

definition fresh_list where
  "fresh_list ds l = (fresh_in_list l \<and> (\<forall> x. list_contain l x \<longrightarrow> x \<notin> ds))"

fun const_scheme :: "p_const \<Rightarrow> nat set \<Rightarrow> s_type \<Rightarrow> perm_crn list \<Rightarrow> nat set \<Rightarrow> bool" where
  "const_scheme UnitConst ds tau c_list ds' = (tau = UnitScheme \<and> c_list = [] \<and> ds' = ds)"
| "const_scheme (IConst i) ds tau c_list ds' = (tau = IntScheme \<and> c_list = [] \<and> ds' = ds)"
| "const_scheme (BConst b) ds tau c_list ds' = (tau = BoolScheme \<and> c_list = [] \<and> ds' = ds)"
| "const_scheme FixConst ds tau c_list ds' = (\<exists> t t1 t2 p q. tau = pure_fun_s (pure_fun_s t t (AffVar q)) t (AffConst Prim) \<and>
  t = FunScheme (VarScheme t1) (VarScheme t2) (SVar p) (AffVar q) \<and> c_list = [LeqTypeCrn t (SPerm UsePerm)] \<and>
  fresh_list ds [t1, t2, p, q] \<and> ds' =  {t1, t2, p, q} \<union> ds )"
(*| "const_scheme EmptyArrayConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s UnitScheme (ArrayScheme (VarScheme t)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme ExtArrayConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ArrayScheme (VarScheme t))
  (FunScheme (VarScheme t) (ArrayScheme (VarScheme t)) (SPerm OwnPerm) (AffConst Ref)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"*)
| "const_scheme NewArrayConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s IntScheme (ArrayScheme (VarScheme t)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme NullConst ds tau c_list ds' = (\<exists> t. tau = VarScheme t \<and> c_list = [] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds )"
| "const_scheme ReadConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ArrayScheme (VarScheme t)) (pure_fun_s IntScheme (VarScheme t) (AffConst Ref)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme WriteConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ArrayScheme (VarScheme t))
  (FunScheme (PairScheme IntScheme (VarScheme t) (SPerm OwnPerm)) UnitScheme (SPerm OwnPerm) (AffConst Ref)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme UnpackConst ds tau c_list ds' = (\<exists> t1 t2 tx p p'. tau = FunScheme (PairScheme (VarScheme t1) (VarScheme t2) (SVar p)) (FunScheme
  (FunScheme (VarScheme t1) (FunScheme (VarScheme t2) (VarScheme tx) (SVar p) (AffVar p'))
    (SVar p) (AffVar p')) (VarScheme tx) (SVar p') (AffVar p)) (SVar p) (AffConst Prim) \<and>
  c_list = [LeqCrn (XPerm (SVar p)) (SVar p')] \<and> fresh_list ds [t1, t2, tx, p, p'] \<and> ds' = {t1, t2, tx, p, p'} \<union> ds)"
| "const_scheme NewChanConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s UnitScheme (PairScheme (ChanScheme (VarScheme t) SEnd) (ChanScheme (VarScheme t) REnd)
  (SPerm OwnPerm)) (AffConst Prim) \<and> c_list = [] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme SendConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ChanScheme (VarScheme t) SEnd) (FunScheme (VarScheme t) UnitScheme
  (SPerm OwnPerm) (AffConst Ref)) (AffConst Prim) \<and> c_list = [] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme RecvConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ChanScheme (VarScheme t) REnd) (VarScheme t) (AffConst Prim) \<and>
    c_list = [] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme ForkConst ds tau c_list ds' = (\<exists> p. tau = FunScheme (FunScheme UnitScheme UnitScheme (SPerm UsePerm) (AffVar p))
  UnitScheme (SPerm OwnPerm) (AffConst Prim) \<and> c_list = [] \<and> p \<notin> ds \<and> ds' = {p} \<union> ds)"

fun op_scheme :: "p_op \<Rightarrow> s_type" where
  "op_scheme (I2Op xop) = pure_fun_s IntScheme (pure_fun_s IntScheme IntScheme (AffConst Prim)) (AffConst Prim)"
| "op_scheme (I1Op xop) = pure_fun_s IntScheme IntScheme (AffConst Prim)"
| "op_scheme (C2Op xop) = pure_fun_s IntScheme (pure_fun_s IntScheme BoolScheme (AffConst Prim)) (AffConst Prim)"
| "op_scheme (C1Op xop) = pure_fun_s IntScheme BoolScheme (AffConst Prim)"
| "op_scheme (R2Op xop) = pure_fun_s BoolScheme (pure_fun_s BoolScheme BoolScheme (AffConst Prim)) (AffConst Prim)"
| "op_scheme (R1Op xop) = pure_fun_s BoolScheme BoolScheme (AffConst Prim)"

    (* inferencing definition *)

definition finite_dom where
  "finite_dom r_s l = (\<forall> x. r_s x \<noteq> XPerm (SPerm NoPerm) \<longrightarrow> list_contain l x)"

fun disj_crn where
  "disj_crn r_s1 r_s2 [] = []"
| "disj_crn r_s1 r_s2 (x # t) = (DisjCrn (r_s1 x) (r_s2 x)) # (disj_crn r_s1 r_s2 t)"

fun semi_disj_crn where
  "semi_disj_crn r_s1 r_s2 [] = []"
| "semi_disj_crn r_s1 r_s2 (x # t) = (SemiDisjCrn (r_s1 x) (r_s2 x)) # (semi_disj_crn r_s1 r_s2 t)"

fun fresh_in_type where
  "fresh_in_type (VarScheme b) a = (a \<noteq> b)"
| "fresh_in_type (ArrayScheme tau) a = (fresh_in_type tau a)"
| "fresh_in_type (PairScheme t1 t2 p) a = (fresh_in_type t1 a \<and> fresh_in_type t2 a)"
| "fresh_in_type (FunScheme t1 t2 p1 p2) a = (fresh_in_type t1 a \<and> fresh_in_type t2 a)"
| "fresh_in_type (ChanScheme tau c_end) a = (fresh_in_type tau a)"
| "fresh_in_type tau a = True"

definition fresh_tvar where
  "fresh_tvar env a = (\<forall> x. case env x of
    None \<Rightarrow> True
    | Some tau \<Rightarrow> fresh_in_type tau a
  )"

fun aff_crn where
  "aff_crn r_s a [] = Nil"
| "aff_crn r_s a (x # t) = (LeqCrn (r_s x) a) # (aff_crn r_s a t)"
  (*
fun var_val_crn where
  "var_val_crn (VarType x) tau tau_x = []"
| "var_val_crn (LocType x) tau tau_x = [MemValCrn tau tau_x]"  *)

fun infer_type :: "nat res_env \<Rightarrow> nat set \<Rightarrow> p_exp \<Rightarrow> s_type \<Rightarrow> perm_var_env \<Rightarrow> perm_var_env \<Rightarrow> perm_var_env \<Rightarrow> perm_crn list \<Rightarrow> nat set \<Rightarrow> bool" where
  "infer_type env ds (ConstExp c) tau r_s r_x r_m c_list ds' =
  (const_scheme c ds tau c_list ds' \<and> r_s = empty_var_env \<and> r_x = empty_var_env \<and> r_m = empty_var_env)"
| "infer_type env ds (OpExp xop) tau r_s r_x r_m c_list ds' = (tau = op_scheme xop \<and>
  r_s = empty_var_env \<and> r_x = empty_var_env \<and> r_m = empty_var_env \<and> c_list = [] \<and> ds = ds')"
| "infer_type env ds (VarExp x) tau r_s r_x r_m c_list ds' = (\<exists> x' a b. x = VarType x' \<and> env (Var x') = Some a \<and> tau = VarScheme a \<and> env (Var x') = Some b \<and>
  r_s = one_var_env (Var x') (XType b) \<and> r_x = r_s \<and> r_m = r_s \<and> c_list = [] \<and> ds' = ds)"
  (*c_list = [LeqTypeCrn (VarScheme b) (SVar p)] @ (var_val_crn x tau (VarScheme b)) \<and>
  p \<notin> ds \<and> ds' = {p} \<union> ds)*)
| "infer_type env ds (PairExp e1 e2) tau r_s r_x r_m c_list ds' = (\<exists> t1 t2 p d r_s1 r_s2 r_x1 r_x2 r_m1 r_m2 cl1 cl2 ds2 ds3.
    infer_type env ds e1 t1 r_s1 r_x1 r_m1 cl1 ds2 \<and> infer_type env ds2 e2 t2 r_s2 r_x2 r_m2 cl2 ds3 \<and> tau = PairScheme t1 t2 (SVar p) \<and>
    r_s = comp_var_env (comp_var_env r_s1 (lift_var_env r_x1 (SVar p))) (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) \<and>
    r_x = ifz_var_env (XPerm (SVar p)) (comp_var_env (lift_var_env r_x1 (SVar p)) (lift_var_env r_x2 (SVar p))) \<and>
    r_m = comp_var_env r_m1 r_m2 \<and> finite_dom r_s d \<and>
    c_list = [LeqTypeCrn t1 (SVar p), LeqTypeCrn t2 (SVar p)] @(*
    (disj_crn (comp_var_env r_s1 (lift_var_env r_x1 (SVar p))) (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) d) @ cl1 @ cl2 \<and>*)
    (disj_crn (lift_var_env r_x1 (SVar p)) (lift_var_env r_x2 (SVar p)) d) @ (semi_disj_crn r_m2 r_x1 d) @ (semi_disj_crn r_m1 r_s2 d)
    (*(semi_disj_crn r_m2 (lift_var_env r_x1 (SVar p)) d) @ (semi_disj_crn r_m1 (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) d)*) @ cl1 @ cl2 \<and>
    p \<notin> ds3 \<and> ds' = {p} \<union> ds3
  )"
| "infer_type env ds (IfExp e1 e2 e3) tau r_s r_x r_m c_list ds' = (\<exists> t1 t2 t3 d r_s1 r_s2 r_s3 r_x1 r_x2 r_x3 r_m1 r_m2 r_m3 cl1 cl2 cl3 ds2 ds3.
    infer_type env ds e1 t1 r_s1 r_x1 r_m1 cl1 ds2 \<and> infer_type env ds2 e2 t2 r_s2 r_x2 r_m2 cl2 ds3 \<and> infer_type env ds3 e3 t3 r_s3 r_x3 r_m3 cl3 ds' \<and>
    r_s = comp_var_env r_s1 (comp_var_env r_s2 r_s3) \<and> r_x = comp_var_env r_x2 r_x3 \<and> r_m = comp_var_env r_m1 (comp_var_env r_m2 r_m3) \<and>
    finite_dom r_s d \<and> tau = t2 \<and>
    c_list = [UnifyCrn t1 BoolScheme, UnifyCrn t2 t3] @ (semi_disj_crn r_m1 (comp_var_env r_s2 r_s3) d) @ cl1 @ cl2 @ cl3)"
| "infer_type env ds (LamExp x e) tau r_s r_x r_m c_list ds' = (\<exists> t2 a p q d r_s' r_x' r_m' cl ds2.
  infer_type (add_env env (Var x) a) (ds \<union> {a}) e t2 r_s' r_x' r_m' cl ds2 \<and> tau = FunScheme (VarScheme a) t2 (SVar p) (AffVar q) \<and>
  r_s = rem_var_env r_s' (Var x) \<and> r_x = r_s \<and> r_m = empty_var_env \<and> x \<notin> ref_vars e \<and>
  finite_dom r_s d \<and> c_list = [LeqCrn (r_s' (Var x)) (SVar p)] @ (aff_crn r_s (SVar q) d) @ cl \<and>
  a \<notin> ds \<and> p \<noteq> q \<and> p \<notin> ds2 \<and> q \<notin> ds2 \<and> ds' = {p, q} \<union> ds2)"
| "infer_type env ds (AppExp e1 e2) tau r_s r_x r_m c_list ds' = (\<exists> tau_f t1 a p q d r_s1 r_s2 r_x1 r_x2 r_m1 r_m2 cl1 cl2 ds2 ds3.
    infer_type env ds e1 tau_f r_s1 r_x1 r_m1 cl1 ds2 \<and> infer_type env ds2 e2 t1 r_s2 r_x2 r_m2 cl2 ds3 \<and>
    tau = VarScheme a \<and> r_s = comp_var_env (comp_var_env r_s1 r_x1) (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) \<and>
    (*r_x = back_lift_var_env (SVar px) (comp_var_env r_s1 (lift_var_env r_s2 (SVar p))) \<and>*)
    r_x = ifz_var_env (XType a) (comp_var_env r_x1 (lift_var_env r_x2 (SVar p))) \<and>
    r_m = comp_var_env (comp_var_env r_m1 r_x1) (comp_var_env r_m2 (lift_var_env r_x2 (SVar p))) \<and> finite_dom r_s d \<and>
    c_list = [UnifyCrn (FunScheme t1 tau (SVar p) (AffVar q)) tau_f (*, EqTypeCrn (VarScheme a) (SVar p_a)*) ] @
    (disj_crn r_x1 (lift_var_env r_x2 (SVar p)) d) @ (semi_disj_crn r_m2 r_x1 d) @ (semi_disj_crn r_m1 r_s2 d) @ cl1 @ cl2 \<and>
    fresh_list ds3 [a, p, q] \<and> ds' = {a, p, q} \<union> ds3
  )"

    (* solution satisfaction *)

fun mini_disj_perm where
  "mini_disj_perm p q = (p = OwnPerm \<longrightarrow> q = NoPerm)"

fun mem_val_type where
  "mem_val_type (ArrayTy tau) = True"
| "mem_val_type (ChanTy tau c_end) = True"
| "mem_val_type tau = False"

fun dir_sol_crn :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> perm_crn \<Rightarrow> bool" where
  "dir_sol_crn t_sub p_sub (UnifyCrn t1 t2) = (\<exists> tau_x. dir_subst_type t_sub p_sub t1 tau_x \<and> dir_subst_type t_sub p_sub t2 tau_x)"
(*| "dir_sol_crn t_sub p_sub (MemValCrn tau tau_x) = (\<exists> t' tx'.
  dir_subst_type t_sub p_sub tau_x tx' \<and> dir_subst_type t_sub p_sub tau t' \<and> req_type tx' = Ref \<and> req_type t' = Ref)"*)
| "dir_sol_crn t_sub p_sub (LeqCrn p1 p2) = (leq_perm (dir_subst_permx t_sub p_sub p1) (sol_subst_perm p_sub p2))"
| "dir_sol_crn t_sub p_sub (LeqTypeCrn tau p) = (\<exists> tau_x.
  dir_subst_type t_sub p_sub tau tau_x \<and> aff_leq (req_type tau_x) (sol_subst_perm p_sub p))"
| "dir_sol_crn t_sub p_sub (DisjCrn p1 p2) = (mini_disj_perm (dir_subst_permx t_sub p_sub p1) (dir_subst_permx t_sub p_sub p2) \<and>
  mini_disj_perm (dir_subst_permx t_sub p_sub p2) (dir_subst_permx t_sub p_sub p1))"
| "dir_sol_crn t_sub p_sub (SemiDisjCrn p1 p2) = (mini_disj_perm (dir_subst_permx t_sub p_sub p1) (dir_subst_permx t_sub p_sub p2))"

fun dir_sol_sat :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> perm_crn list \<Rightarrow> bool" where
  "dir_sol_sat t_sub p_sub [] = True"
| "dir_sol_sat t_sub p_sub (c # c_t) = (dir_sol_crn t_sub p_sub c \<and> dir_sol_sat t_sub p_sub c_t)"

lemma sol_sat_append2: "\<lbrakk> dir_sol_sat t_sub p_sub (cl1 @ cl2) \<rbrakk> \<Longrightarrow> dir_sol_sat t_sub p_sub cl2"
  apply (induct cl1)
   apply (auto)
  done

lemma sol_sat_append1: "\<lbrakk> dir_sol_sat t_sub p_sub (cl1 @ cl2) \<rbrakk> \<Longrightarrow> dir_sol_sat t_sub p_sub cl1"
  apply (induct cl1)
   apply (auto)
  done

lemma sol_sat_disj_crn_elem: "\<lbrakk> dir_sol_sat t_sub p_sub (disj_crn r_x r_s d); list_contain d x \<rbrakk> \<Longrightarrow>
  mini_disj_perm (dir_subst_permx t_sub p_sub (r_x x)) (dir_subst_permx t_sub p_sub (r_s x))
  \<and> mini_disj_perm (dir_subst_permx t_sub p_sub (r_s x)) (dir_subst_permx t_sub p_sub (r_x x))"
  apply (induct d)
   apply (auto)
  done

lemma sol_sat_disj_use_env: "\<lbrakk> dir_sol_sat t_sub p_sub (disj_crn r_x r_s d); finite_dom r_x d; finite_dom r_s d \<rbrakk> \<Longrightarrow>
  disj_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s)"
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (simp add: finite_dom_def)
  apply (auto)
   apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
    apply (simp add: dir_subst_penv_def)
   apply (cut_tac p_sub="p_sub" and d="d" and x="x" in sol_sat_disj_crn_elem)
     apply (auto)
      apply (simp add: dir_subst_penv_def)
     apply (simp add: dir_subst_penv_def)
    apply (simp add: dir_subst_penv_def)
   apply (simp add: dir_subst_penv_def)
  apply (case_tac "r_x x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and d="d" and x="x" in sol_sat_disj_crn_elem)
    apply (auto)
     apply (simp add: dir_subst_penv_def)
    apply (simp add: dir_subst_penv_def)
   apply (simp add: dir_subst_penv_def)
  apply (simp add: dir_subst_penv_def)
  done

lemma sol_sat_mini_disj_crn_elem: "\<lbrakk> dir_sol_sat t_sub p_sub (semi_disj_crn r_x r_s d); list_contain d x \<rbrakk> \<Longrightarrow>
  mini_disj_perm (dir_subst_permx t_sub p_sub (r_x x)) (dir_subst_permx t_sub p_sub (r_s x))"
  apply (induct d)
   apply (auto)
  done

lemma sol_sat_mini_disj_use_env: "\<lbrakk> dir_sol_sat t_sub p_sub (semi_disj_crn r_x r_s d); finite_dom r_x d; finite_dom r_s d \<rbrakk> \<Longrightarrow>
  mini_disj_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s)"
  apply (simp add: mini_disj_use_env_def)
  apply (simp add: finite_dom_def)
  apply (auto)
  apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and d="d" and x="x" in sol_sat_mini_disj_crn_elem)
    apply (auto)
   apply (simp add: dir_subst_penv_def)
  apply (simp add: dir_subst_penv_def)
  done

lemma sol_sat_aff_crn_elem: "\<lbrakk> dir_sol_sat t_sub p_sub (aff_crn r_s (SVar q) d); list_contain d x \<rbrakk> \<Longrightarrow>
  leq_perm (dir_subst_permx t_sub p_sub (r_s x)) (sol_subst_perm p_sub (SVar q))"
  apply (induct d)
   apply (auto)
  done

lemma sol_sat_aff_use_env: "\<lbrakk> dir_sol_sat t_sub p_sub (aff_crn r_s (SVar q) d); finite_dom r_s d \<rbrakk> \<Longrightarrow>
  aff_use_env (dir_subst_penv t_sub p_sub r_s) (sol_subst_aff p_sub (AffVar q))"
  apply (simp add: aff_use_env_def)
  apply (simp add: finite_dom_def)
  apply (case_tac "sol_subst_aff p_sub (AffVar q)")
    apply (auto)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
     apply (auto)
    apply (simp add: dir_subst_penv_def)
    apply (case_tac "r_s x")
       apply (auto)
    apply (case_tac x1)
     apply (auto)
   apply (simp add: dir_subst_penv_def)
   apply (case_tac "p_sub q")
     apply (auto)
  apply (simp add: null_use_env_def)
  apply (auto)
  apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
    apply (auto)
  apply (simp add: dir_subst_penv_def)
  apply (case_tac "p_sub q")
    apply (auto)
  apply (case_tac "dir_subst_permx t_sub p_sub (r_s x)")
    apply (auto)
  done

lemma sol_sat_aff_use_envx: "\<lbrakk> dir_sol_sat t_sub p_sub (aff_crn r_s (SVar q) d); finite_dom r_s d \<rbrakk> \<Longrightarrow>
  aff_use_env (dir_subst_penv t_sub p_sub r_s) (as_aff (p_sub q))"
  apply (simp add: aff_use_env_def)
  apply (simp add: finite_dom_def)
  apply (case_tac "sol_subst_aff p_sub (AffVar q)")
    apply (auto)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
     apply (auto)
    apply (simp add: dir_subst_penv_def)
    apply (case_tac "r_s x")
       apply (auto)
    apply (case_tac x1)
     apply (auto)
   apply (simp add: dir_subst_penv_def)
   apply (case_tac "p_sub q")
     apply (auto)
  apply (simp add: null_use_env_def)
  apply (auto)
  apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
    apply (auto)
  apply (simp add: dir_subst_penv_def)
  apply (case_tac "p_sub q")
    apply (auto)
  apply (case_tac "dir_subst_permx t_sub p_sub (r_s x)")
    apply (auto)
  done
(*
lemma sol_subst_var_type: "sol_subst_var_full t_sub p_sub tau_n a = sol_subst_type_full t_sub p_sub tau_n (VarScheme a)"
  apply (simp add: sol_subst_var_full_def)
  apply (simp add: sol_subst_type_full_def)
  apply (simp add: sol_subst_var_def)
  done
  *)
    (* ##### sub-domain lemmas *)

definition sub_dom where
  "sub_dom r_x r_s = (\<forall> x. r_s x = XPerm (SPerm NoPerm) \<longrightarrow> r_x x =  XPerm (SPerm NoPerm))"

lemma finite_sub_dom: "\<lbrakk> finite_dom r_s d; sub_dom r_x r_s \<rbrakk> \<Longrightarrow> finite_dom r_x d"
  apply (induct d)
   apply (auto)
   apply (simp add: sub_dom_def)
   apply (simp add: finite_dom_def)
  apply (simp add: sub_dom_def)
  apply (simp add: finite_dom_def)
  apply (auto)
  done

lemma id_sub_dom: "sub_dom r_s r_s"
  apply (simp add: sub_dom_def)
  done

lemma lift_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (lift_var_env r_x p) r_s"
  apply (simp add: sub_dom_def)
  apply (simp add: lift_var_env_def)
  done

lemma lift_sub_dom2: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom r_x (lift_var_env r_s p)"
  apply (simp add: sub_dom_def)
  apply (simp add: lift_var_env_def)
  done

lemma dist_lift_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (lift_var_env r_x p) (lift_var_env r_s p)"
  apply (simp add: sub_dom_def)
  apply (simp add: lift_var_env_def)
  done

lemma dist_comp_sub_dom: "\<lbrakk> sub_dom r_xa r_s; sub_dom r_xb r_s \<rbrakk> \<Longrightarrow> sub_dom (comp_var_env r_xa r_xb) r_s"
  apply (simp add: sub_dom_def)
  apply (simp add: comp_var_env_def)
  done

lemma comp_sub_dom1: "\<lbrakk> sub_dom r_x r_sa \<rbrakk> \<Longrightarrow> sub_dom r_x (comp_var_env r_sa r_sb)"
  apply (simp add: sub_dom_def)
  apply (simp add: comp_var_env_def)
  done

lemma comp_sub_dom2: "\<lbrakk> sub_dom r_x r_sb \<rbrakk> \<Longrightarrow> sub_dom r_x (comp_var_env r_sa r_sb)"
  apply (simp add: sub_dom_def)
  apply (simp add: comp_var_env_def)
  done

lemma dist_rem_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (rem_var_env r_x x) (rem_var_env r_s x)"
  apply (simp add: sub_dom_def)
  apply (simp add: rem_var_env_def)
  done

lemma if_zero_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (ifz_var_env q r_x) r_s"
  apply (simp add: sub_dom_def)
  apply (simp add: ifz_var_env_def)
  done

lemma if_zero_sub_dom2: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom r_x (ifz_var_env q r_s)"
  apply (simp add: sub_dom_def)
  apply (simp add: ifz_var_env_def)
  done

lemma infer_x_sub_dom: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow> sub_dom r_x r_s"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var case *)
        apply (rule_tac id_sub_dom)
       apply (rule_tac id_sub_dom)
      apply (rule_tac id_sub_dom)
    (* pair case *)
     apply (rule_tac if_zero_sub_dom)
     apply (rule_tac dist_comp_sub_dom)
      apply (rule_tac comp_sub_dom1)
      apply (rule_tac comp_sub_dom2)
      apply (rule_tac id_sub_dom)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac id_sub_dom)
    (* if case *)
    apply (rule_tac comp_sub_dom2)
    apply (rule_tac dist_comp_sub_dom)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    apply (rule_tac comp_sub_dom2)
    apply (simp)
    (* lam case *)
   apply (rule_tac dist_rem_sub_dom)
   apply (rule_tac id_sub_dom)
    (* app case *)
  apply (rule_tac if_zero_sub_dom)
  apply (rule_tac dist_comp_sub_dom)
   apply (rule_tac comp_sub_dom1)
   apply (rule_tac comp_sub_dom2)
   apply (rule_tac id_sub_dom)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac id_sub_dom)
  done

lemma infer_m_sub_dom: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow> sub_dom r_m r_s"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var case *)
        apply (rule_tac id_sub_dom)
       apply (rule_tac id_sub_dom)
      apply (rule_tac id_sub_dom)
    (* pair case *)
     apply (rule_tac dist_comp_sub_dom)
      apply (rule_tac comp_sub_dom1)
      apply (rule_tac comp_sub_dom1)
      apply (simp)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    (* if case *)
    apply (rule_tac dist_comp_sub_dom)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    apply (rule_tac dist_comp_sub_dom)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    apply (rule_tac comp_sub_dom2)
    apply (rule_tac comp_sub_dom2)
    apply (simp)
    (* lam case *)
   apply (simp add: sub_dom_def)
   apply (simp add: empty_var_env_def)
    (* app case *)
  apply (rule_tac dist_comp_sub_dom)
   apply (rule_tac comp_sub_dom1)
   apply (rule_tac dist_comp_sub_dom)
    apply (rule_tac comp_sub_dom1)
    apply (simp)
   apply (rule_tac comp_sub_dom2)
   apply (rule_tac id_sub_dom)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac dist_comp_sub_dom)
   apply (rule_tac comp_sub_dom1)
   apply (simp)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac id_sub_dom)
  done

    (* ##### general inferencing lemmas *)

lemma infer_x_leq_use_env: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s)"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var cases *)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac id_leq_use_env)
    (* pair case *)
     apply (rule_tac if_zero_leq_var_env)
     apply (rule_tac dist_comp_leq_var_env)
      apply (rule_tac comp_leq_var_env1)
      apply (rule_tac comp_leq_var_env2)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac id_leq_use_env)
    (* if case *)
    apply (rule_tac comp_leq_var_env2)
    apply (rule_tac dist_comp_leq_var_env)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    apply (rule_tac comp_leq_var_env2)
    apply (auto)
    (* lam + app case *)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac if_zero_leq_var_env)
  apply (rule_tac dist_comp_leq_var_env)
   apply (rule_tac comp_leq_var_env1)
   apply (rule_tac comp_leq_var_env2)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac id_leq_use_env)
  done

lemma infer_m_leq_use_env: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub r_m) (dir_subst_penv t_sub p_sub r_s)"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var cases *)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac id_leq_use_env)
    (* pair case *)
     apply (rule_tac dist_comp_leq_var_env)
      apply (rule_tac comp_leq_var_env1)
      apply (rule_tac comp_leq_var_env1)
      apply (auto)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    (* if case *)
    apply (rule_tac dist_comp_leq_var_env)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    apply (rule_tac dist_comp_leq_var_env)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    apply (rule_tac comp_leq_var_env2)
    apply (rule_tac comp_leq_var_env2)
    apply (auto)
    (* lam + app case *)
   apply (rule_tac empty_leq_var_env)
  apply (rule_tac dist_comp_leq_var_env)
   apply (rule_tac comp_leq_var_env1)
   apply (rule_tac dist_comp_leq_var_env)
    apply (rule_tac comp_leq_var_env1)
    apply (auto)
   apply (rule_tac comp_leq_var_env2)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac dist_comp_leq_var_env)
   apply (rule_tac comp_leq_var_env1)
   apply (auto)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac id_leq_use_env)
  done

    (* ##### special comp lemma *)

    (*
definition anti_norm_use_env where
  "anti_norm_use_env r_s r_x = (\<lambda> x. if r_x x \<noteq> NoPerm then NoPerm else r_s x)"
    *)
definition sub_norm_use_env where
  "sub_norm_use_env r_s r_x = (\<lambda> x. if r_x x = OwnPerm then NoPerm else r_s x)"

lemma decomp_use_env: "comp_use_env r_s r_x = comp_use_env r_s (sub_norm_use_env r_x r_s)"
  apply (case_tac "\<forall> x. comp_use_env r_s r_x x = comp_use_env r_s (sub_norm_use_env r_x r_s) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: sub_norm_use_env_def)
  apply (auto)
  done

lemma mini_disj_sub_norm_use_env: "mini_disj_use_env r_s (sub_norm_use_env r_x r_s)"
  apply (simp add: mini_disj_use_env_def)
  apply (simp add: sub_norm_use_env_def)
  done

lemma well_typed_comp_perms_prec: "\<lbrakk> well_typed env delta r_s e tau (diff_use_env r_s r_ex) rx \<rbrakk> \<Longrightarrow>
  well_typed env delta (comp_use_env r_s r_x) e tau (diff_use_env (comp_use_env r_s r_x) r_ex) rx"
  apply (cut_tac r_s="r_s" and r_x="r_x" in decomp_use_env)
  apply (auto)
  apply (rule_tac r_c="comp_use_env (diff_use_env r_s r_ex) (sub_norm_use_env r_x r_s)" in well_typed_decr_end_perm)
    apply (rule_tac well_typed_comp_perms_gen)
     apply (simp)
    apply (rule_tac mini_disj_sub_norm_use_env)
   apply (rule_tac lhs_dist_dcl_use_env)
   apply (rule_tac dist_comp_leq_use_env)
    apply (rule_tac self_comp_leq_use_env1)
   apply (rule_tac comp_leq_use_env2)
   apply (rule_tac self_diff_leq_use_env)
  apply (rule_tac r_sb="diff_use_env r_s r_ex" in trans_leq_use_env)
   apply (rule_tac dist_diff_leq_use_env)
   apply (rule_tac self_comp_leq_use_env1)
  apply (rule_tac well_typed_perm_leqx)
  apply (auto)
  done

lemma well_typed_comp_perms_prec2: "\<lbrakk> well_typed env delta r_s e tau (diff_use_env r_s r_ex) rx  \<rbrakk> \<Longrightarrow>
  well_typed env delta (comp_use_env r_x r_s) e tau (diff_use_env (comp_use_env r_x r_s) r_ex) rx"
  apply (simp add: comm_comp_use_env)
  apply (rule_tac well_typed_comp_perms_prec)
   apply (auto)
  done

    (* ##### special lifting lemma *)

lemma spec_diff_comp_leq_use_env: "\<lbrakk> leq_use_env r_x r_sb; leq_use_env r_x (diff_use_env (comp_use_env r_sa r_sb) r_ex) \<rbrakk> \<Longrightarrow>
  leq_use_env r_x (diff_use_env r_sb r_ex)"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma wtclp_leq_use_env: "\<lbrakk> leq_use_env r_xb r_sb;
  leq_use_env (comp_use_env r_xa r_xb) (diff_use_env (comp_use_env r_sa r_sb) r_ex) \<rbrakk>
    \<Longrightarrow> leq_use_env (comp_use_env r_xa (lift_use_env r_xb r))
        (diff_use_env (comp_use_env r_sa (lift_use_env r_sb r)) r_ex)"
  apply (rule_tac dist_comp_leq_use_env)
   apply (rule_tac r_sb="diff_use_env (comp_use_env r_sa r_sb) r_ex" in trans_leq_use_env)
    apply (rule_tac dist_diff_leq_use_env)
    apply (rule_tac dist_comp_leq_use_env)
     apply (rule_tac self_comp_leq_use_env1)
    apply (rule_tac comp_leq_use_env2)
    apply (rule_tac self_lift_leq_use_env)
   apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
    apply (simp)
   apply (rule_tac self_comp_leq_use_env1)
  apply (rule_tac rhs_dist_dcl_use_env)
  apply (rule_tac comp_leq_use_env2)
  apply (simp add: lift_diff_use_env)
  apply (rule_tac dist_lift_leq_use_env)
  apply (rule_tac r_sa="r_sa" in spec_diff_comp_leq_use_env)
   apply (simp)
  apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
   apply (auto)
  apply (rule_tac self_comp_leq_use_env2)
  done

lemma simp_lift_comp_leq_use_env: "\<lbrakk> leq_use_env r_x (comp_use_env r_sa r_sb) \<rbrakk> \<Longrightarrow> leq_use_env r_x (comp_use_env r_sa (lift_use_env r_sb r))"
  apply (rule_tac r_sb="comp_use_env r_sa r_sb" in trans_leq_use_env)
   apply (rule_tac dist_comp_leq_use_env)
    apply (rule_tac self_comp_leq_use_env1)
   apply (rule_tac comp_leq_use_env2)
   apply (rule_tac self_lift_leq_use_env)
  apply (simp)
  done

lemma well_typed_comp_lift_perms: "\<lbrakk> well_typed env delta (comp_use_env r_sa r_sb) e tau (comp_use_env r_xa r_xb) rx; leq_use_env r_xb r_sb \<rbrakk> \<Longrightarrow>
  well_typed env delta (comp_use_env r_sa (lift_use_env r_sb r)) e tau (comp_use_env r_xa (lift_use_env r_xb r)) rx"
  apply (induct e arbitrary: env r_sa r_sb tau r_xa r_xb rx)
        apply (auto)
    (* const + op cases *)
           apply (rule_tac dist_comp_leq_use_env)
            apply (rule_tac simp_lift_comp_leq_use_env)
            apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
             apply (simp)
            apply (rule_tac self_comp_leq_use_env1)
           apply (rule_tac comp_leq_use_env2)
           apply (rule_tac dist_lift_leq_use_env)
           apply (simp)
          apply (rule_tac simp_lift_comp_leq_use_env)
          apply (simp)
         apply (rule_tac dist_comp_leq_use_env)
          apply (rule_tac simp_lift_comp_leq_use_env)
          apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
           apply (simp)
          apply (rule_tac self_comp_leq_use_env1)
         apply (rule_tac comp_leq_use_env2)
         apply (rule_tac dist_lift_leq_use_env)
         apply (simp)
        apply (rule_tac simp_lift_comp_leq_use_env)
        apply (simp)
    (* var cases *)
       apply (rule_tac simp_lift_comp_leq_use_env)
       apply (simp)
      apply (rule_tac x="r_ex" in exI)
      apply (auto)
        apply (rule_tac wtclp_leq_use_env)
         apply (auto)
       apply (rule_tac simp_lift_comp_leq_use_env)
       apply (simp)
      apply (rule_tac simp_lift_comp_leq_use_env)
      apply (simp)
    (* pair case *)
     apply (cut_tac r_sc="r_xb" and r_sb="comp_use_env r_xa r_xb" and r_sa="r_s3" in trans_leq_use_env)
       apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
        apply (rule_tac self_diff_leq_use_env)
       apply (simp)
      apply (rule_tac self_comp_leq_use_env2)
     apply (cut_tac r_sc="r_xb" and r_sb="r_s3" and r_sa="r_s2" in trans_leq_use_env)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
     apply (rule_tac x="comp_use_env r_s2 (lift_use_env r_xb r)" in exI)
     apply (rule_tac x="comp_use_env r_s3 (lift_use_env r_xb r)" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
      apply (case_tac "\<not> well_typed env delta (comp_use_env r_sa r_sb) e1 t1 (comp_use_env r_s2 r_xb) rx1")
       apply (cut_tac r_s="r_s2" and r_x="r_xb" in cancel_comp_use_env2)
        apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (auto)
        apply (case_tac "\<not> well_typed env delta (comp_use_env r_s2 r_xb) e2 t2 (comp_use_env r_s3 r_xb) rx2")
         apply (cut_tac r_s="r_s3" and r_x="r_xb" in cancel_comp_use_env2)
          apply (simp_all)
         apply (cut_tac env="env" and r_c="comp_use_env r_s2 r_xb" and ?r_s1.0="r_s2" and e="e2" in well_typed_incr_start_perm)
           apply (auto)
         apply (rule_tac self_comp_leq_use_env1)
        apply (cut_tac r="r_xb" in id_leq_use_env)
        apply (auto)
       apply (rule_tac comp_leq_use_env1)
       apply (simp)
      apply (rule_tac comp_leq_use_env1)
      apply (simp)
     apply (rule_tac x="r_ex" in exI)
     apply (auto)
       apply (rule_tac wtclp_leq_use_env)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac rhs_dist_dcl_use_env)
       apply (rule_tac comp_leq_use_env1)
       apply (simp)
      apply (rule_tac simp_lift_comp_leq_use_env)
      apply (simp)
     apply (rule_tac simp_lift_comp_leq_use_env)
     apply (simp)
    (* if case *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="comp_use_env r_s2 (lift_use_env r_xb r)" in exI)
    apply (auto)
     apply (case_tac "\<not> well_typed env delta (comp_use_env r_sa r_sb) e1 BoolTy (comp_use_env r_s2 r_xb) rx'")
      apply (cut_tac r_s="r_s2" and r_x="r_xb" in cancel_comp_use_env2)
       apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
     apply (rule_tac self_comp_leq_use_env2)
    apply (cut_tac r="r_xb" in id_leq_use_env)
    apply (cut_tac r_s="r_s2" and r_x="r_xb" in self_comp_leq_use_env1)
    apply (rule_tac x="rx1" in exI)
    apply (auto)
     apply (cut_tac env="env" and ?r_s1.0="r_s2" and r_c="comp_use_env r_s2 r_xb" and e="e2" in well_typed_incr_start_perm)
       apply (auto)
    apply (rule_tac x="rx2" in exI)
    apply (auto)
    apply (cut_tac env="env" and ?r_s1.0="r_s2" and r_c="comp_use_env r_s2 r_xb" and e="e3" in well_typed_incr_start_perm)
      apply (auto)
    (* lam case *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
    apply (rule_tac simp_lift_comp_leq_use_env)
    apply (simp)
   apply (rule_tac x="r_ex" in exI)
   apply (auto)
     apply (rule_tac wtclp_leq_use_env)
      apply (auto)
    apply (rule_tac simp_lift_comp_leq_use_env)
    apply (simp)
   apply (rule_tac simp_lift_comp_leq_use_env)
   apply (simp)
    (* app case *)
  apply (cut_tac r_sc="r_xb" and r_sb="comp_use_env r_xa r_xb" and r_sa="r_s3" in trans_leq_use_env)
    apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 ra)) r_ex)" in trans_leq_use_env)
     apply (rule_tac self_diff_leq_use_env)
    apply (simp)
   apply (rule_tac self_comp_leq_use_env2)
  apply (cut_tac r_sc="r_xb" and r_sb="r_s3" and r_sa="r_s2" in trans_leq_use_env)
    apply (rule_tac well_typed_perm_leq)
    apply (auto)
  apply (cut_tac r="r_xb" in id_leq_use_env)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="ra" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="comp_use_env r_s2 (lift_use_env r_xb r)" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
   apply (case_tac "\<not> well_typed env delta (comp_use_env r_sa r_sb) e1 (FunTy t1 tau ra a) (comp_use_env r_s2 r_xb) rx1")
    apply (cut_tac r_s="r_s2" and r_x="r_xb" in cancel_comp_use_env2)
     apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (rule_tac x="comp_use_env r_s3 (lift_use_env r_xb r)" in exI)
  apply (auto)
   apply (case_tac "\<not> well_typed env delta (comp_use_env r_s2 r_xb) e2 t1 (comp_use_env r_s3 r_xb) rx2")
    apply (cut_tac r_s="r_s3" and r_x="r_xb" in cancel_comp_use_env2)
     apply (auto)
   apply (cut_tac env="env" and ?r_s1.0="r_s2" and r_c="comp_use_env r_s2 r_xb" and e="e2" in well_typed_incr_start_perm)
     apply (auto)
   apply (rule_tac self_comp_leq_use_env1)
  apply (rule_tac x="r_ex" in exI)
  apply (auto)
     apply (rule_tac wtclp_leq_use_env)
      apply (auto)
     apply (rule_tac rhs_dist_dcl_use_env)
     apply (rule_tac comp_leq_use_env1)
     apply (simp)
    apply (rule_tac comp_leq_use_env1)
    apply (simp)
   apply (rule_tac simp_lift_comp_leq_use_env)
   apply (simp)
  apply (rule_tac simp_lift_comp_leq_use_env)
  apply (simp)
  done

definition set_dom :: "string set \<Rightarrow> string list \<Rightarrow> bool" where
  "set_dom ds l = (\<forall> x. x \<in> ds \<longrightarrow> list_contain l x)"

fun max_length where
  "max_length [] = 0"
| "max_length (x # t) = max (length x) (max_length t)"

  (* how can we prove that the "nu-string" is not contained in l? inductively, we know that the lesser*)

lemma m_list_ex: "\<lbrakk> length x > max_length l \<rbrakk> \<Longrightarrow> \<not> list_contain l x"
  apply (induct l)
   apply (auto)
  done

lemma string_of_length: "\<exists> s :: string. length s = i"
  apply (rule_tac Ex_list_of_length)
  done

lemma fresh_list_ex_gen: "\<lbrakk> set_dom ds l; fresh_list ds t \<rbrakk> \<Longrightarrow> \<exists> a. fresh_list ds (a # t)"
  apply (simp add: fresh_list_def)
  apply (auto)
  apply (cut_tac i="(max (max_length l) (max_length t)) + 1" in string_of_length)
  apply (auto)
  apply (rule_tac x="s" in exI)
  apply (auto)
    (* t does not contain a by construction *)
   apply (cut_tac l="t" and x="s" in m_list_ex)
    apply (auto)
    (* l does not contain a by construction as well *)
  apply (simp add: set_dom_def)
  apply (erule_tac x="s" in allE)
  apply (cut_tac l="l" and x="s" in m_list_ex)
   apply (auto)
  done

lemma fresh_list_ex1: "\<lbrakk> set_dom ds l \<rbrakk> \<Longrightarrow> \<exists> a. fresh_list ds [a]"
  apply (rule_tac fresh_list_ex_gen)
   apply (auto)
  apply (simp add: fresh_list_def)
  done

lemma fresh_list_exl: "\<lbrakk> set_dom ds l \<rbrakk> \<Longrightarrow> \<exists> l'. fresh_list ds l' \<and> length l' = i"
  apply (induct i)
   apply (auto)
   apply (simp add: fresh_list_def)
  apply (cut_tac ds="ds" and t="l'" in fresh_list_ex_gen)
    apply (auto)
  done

lemma fresh_list_ex4: "\<lbrakk> set_dom ds l \<rbrakk> \<Longrightarrow> \<exists> a b c d. fresh_list ds [a, b, c, d]"
  apply (cut_tac ds="ds" and l="l" and i="4" in fresh_list_exl)
   apply (auto)
  apply (case_tac l')
   apply (auto)
  apply (case_tac list)
   apply (auto)
  apply (case_tac lista)
   apply (auto)
  apply (case_tac list)
   apply (auto)
  done

end