theory HoareWithInvariant

imports Main
 "../lem/Evm"
 "../sep_algebra/EvmSep"
 "../sep_algebra/Sep_Tactics"
 "~~/src/HOL/Eisbach/Eisbach"
begin

lemma not_at_least_one :
  "\<not> 1 \<le> (aa :: 256 word) \<Longrightarrow> aa = 0"
apply(simp add:linorder_class.not_le)
done

lemma unat_suc : "unat (aa :: w256) = Suc n \<Longrightarrow> unat (aa - 1) = n"
apply(case_tac "aa \<ge> 1")
 apply(simp add: uint_minus_simple_alt unat_def)
apply(drule not_at_least_one)
apply(simp)
done

(* Following Magnus Myreen's thesis "Formal verification of machine-code programs" 3.2.4 *)

datatype state_element =
    StackHeightElm "nat"  (* considering making it int *)
  | StackElm "nat * w256" (* position, value *)
    (* The position is counted from the bottom *)
    (* StackElement (0, 300) says the oldest element on the stack is 300 *)
  | StorageElm "w256 * w256" (* index, value *)
  | MemoryElm "w256 * byte" (* address, value *)
  | LogElm "nat * log_entry" (* position, log *)
    (* Log (0, entry) says that the first recorded log entry is 0 *)
  | LogNumElm "nat" (* Number of recorded logs *)
  | PcElm "int" (* program counter *)
  | GasElm "int" (* remaining gas *)
  | MemoryUsageElm "int" (* current memory usage *)
  | CodeElm "int * inst" (* a position containing an instruction *)
  | ThisAccountElm "address" (* The address of this account *)
  | BalanceElm "address * w256" (* address, amount *)
  | CallerElm "address"
  | OriginElm "address"
  | SentValueElm "w256"
  | SentDataLengthElm "nat" (* considering making it int *)
  | SentDataElm "nat * byte" (* position, content.  Considering making position an int *)
  | ExtProgramSizeElm "address * int" (* address, size.  Considering making size an int *)
  | ExtProgramElm "address * nat * byte" (* address, position, byte.  Considering making position an int *)
  | ContractActionElm "contract_action" (* None indicates continued execution *)
  | ContinuingElm "bool" (* True if the execution is still continuing *)
  | BlockhashElm "w256 * w256"
  | BlockNumberElm w256
  | CoinbaseElm "address"
  | TimestampElm "w256"
  | DifficultyElm "w256"
  | GaslimitElm "w256"
  | GaspriceElm "w256"
  | AccountExistenceElm "address * bool"

abbreviation blockhash_as_elm :: "(w256 \<Rightarrow> w256) \<Rightarrow> state_element set"
where "blockhash_as_elm f == { BlockhashElm (n, h) | n h. f n = h}"

abbreviation block_info_as_set :: "block_info \<Rightarrow> state_element set"
where "block_info_as_set b ==
  blockhash_as_elm (block_blockhash b) \<union> { CoinbaseElm (block_coinbase b),
  TimestampElm (block_timestamp b), DifficultyElm (block_difficulty b),
  GaslimitElm (block_gaslimit b), BlockNumberElm (block_number b) }"

definition account_existence_as_set :: "(address \<Rightarrow> bool) \<Rightarrow> state_element set"
where
"account_existence_as_set f ==
  { AccountExistenceElm (a, e) | a e. f a = e }"

definition contract_action_as_set :: "contract_action \<Rightarrow> state_element set"
  where "contract_action_as_set act == { ContractActionElm act }"

definition memory_as_set :: "memory \<Rightarrow> state_element set"
  where
    "memory_as_set m == { MemoryElm (a, v) | a v. m a = v }"

definition storage_as_set :: "storage \<Rightarrow> state_element set"
  where
    "storage_as_set s == { StorageElm (i, v) | i v. s i = v}"

definition balance_as_set :: "(address \<Rightarrow> w256) \<Rightarrow> state_element set"
  where
    "balance_as_set b == { BalanceElm (a, v) | a v. b a = v }"

definition stack_as_set :: "w256 list \<Rightarrow> state_element set"
  where
    "stack_as_set s == { StackHeightElm (length s) } \<union>
                       { StackElm (idx, v) | idx v. idx < length s \<and> (rev s) ! idx = v }"

definition data_sent_as_set :: "byte list \<Rightarrow> state_element set"
  where
    "data_sent_as_set lst == { SentDataLengthElm (length lst) } \<union>
                             { SentDataElm (idx, v) | idx v. idx < length lst \<and> lst ! idx = v }"

definition ext_program_as_set :: "(address \<Rightarrow> program) \<Rightarrow> state_element set"
  where
    "ext_program_as_set ext ==
      { ExtProgramSizeElm (adr, s) | adr s. program_length (ext adr) = s } \<union>
      { ExtProgramElm (adr, pos, b) | adr pos b. program_as_natural_map (ext adr) pos = b }
    "

definition log_as_set :: "log_entry list \<Rightarrow> state_element set"
  where
    "log_as_set logs ==
      { LogNumElm (length logs) } \<union>
      { LogElm (pos, l) | pos l. (rev logs) ! pos = l \<and> pos < length logs}
    "

definition program_as_set :: "program \<Rightarrow> state_element set"
  where
    "program_as_set prg ==
      { CodeElm (pos, i) | pos i. program_content prg pos = Some i  } \<union>
      { CodeElm (pos, Misc STOP) | pos. program_content prg pos = None }
    "

definition constant_ctx_as_set :: "constant_ctx \<Rightarrow> state_element set"
  where
    "constant_ctx_as_set c == program_as_set (cctx_program c) \<union> { ThisAccountElm (cctx_this c) }"

definition variable_ctx_as_set :: "variable_ctx \<Rightarrow> state_element set"
  where
    "variable_ctx_as_set v ==
       stack_as_set (vctx_stack v)
    \<union> memory_as_set (vctx_memory v)
    \<union> storage_as_set (vctx_storage v)
    \<union> balance_as_set (vctx_balance v)
    \<union> log_as_set (vctx_logs v)
    \<union> block_info_as_set (vctx_block v)
    \<union> data_sent_as_set (vctx_data_sent v)
    \<union> ext_program_as_set (vctx_ext_program v)
    \<union> account_existence_as_set (vctx_account_existence v)
    \<union> { MemoryUsageElm (vctx_memory_usage v)
      , CallerElm (vctx_caller v)
      , SentValueElm (vctx_value_sent v)
      , OriginElm (vctx_origin v)
      , GaspriceElm (vctx_gasprice v)
      , GasElm (vctx_gas v)
      , PcElm (vctx_pc v)
      , SentDataLengthElm (length (vctx_data_sent v))
      }"

definition contexts_as_set :: "variable_ctx \<Rightarrow> constant_ctx \<Rightarrow> state_element set"
  where
    "contexts_as_set v c ==
       constant_ctx_as_set c \<union> variable_ctx_as_set v"

type_synonym 'a set_pred = "'a set \<Rightarrow> bool"

text \<open>The old sep_commute and sep_assoc are now in sep_conj_ac and
   sep_def should be replaced by the following sep_basic_simps \<close>

lemmas sep_basic_simps =  sep_conj_def sep_set_conv

lemma sep_eq_alts [sep_select]:
  "(\<And>s. T s = (P \<and>* R) s) \<Longrightarrow> T s \<and> A \<Longrightarrow> (P \<and>* R) s \<and> A"
  "(\<And>s. T s = (P \<and>* R) s) \<Longrightarrow> T = B \<Longrightarrow> (P \<and>* R) = B"
  "(\<And>s. T s = (P \<and>* R) s) \<Longrightarrow> T = D \<Longrightarrow> D = (P \<and>* R)"
  by auto+

lemma sep_select_ext[sep_select]:
   "(\<And>s. T s = (P \<and>* R) s) \<Longrightarrow> T s = B s \<Longrightarrow> (P \<and>* R) s = B s"
  "(\<And>s. T s = (P \<and>* R) s) \<Longrightarrow> T s = D s \<Longrightarrow> D s = (P \<and>* R) s"
  by auto+

lemma sep_conj_first:
  "(A \<and> (P \<and>* R) s) = ((P \<and>* R) s \<and> A)"
  by (simp add: conj_commute)

text \<open>Use the method sep_sep_iff to solve simple sep-logic
  lemmas of the following form:
  @{term "(some_sep_prop n \<and>* R) s = (SomeSepPropConst n \<in> s \<and> R (s - {SomeSepPropConst n}))"}\<close>

lemma ex_conj_commute:
  "(\<exists>v. P v \<and> Q v) = (\<exists>v. Q v \<and> P v) "
  by (simp only: conj_commute)

method exI_pick_last_conj =
  --\<open>Group all conjs on the left and then commute to get the
     last conjunction element in first position.\<close>
  (simp (no_asm) only: conj_assoc[symmetric],
   subst ex_conj_commute)?,
  ((rule exI, erule conjI, ((rule conjI[rotated])+; blast))|
   (rule exI, rule exI, erule (1) conjI, ((rule conjI[rotated])+; blast)))

method solve_sep_iff uses simp =
  solves \<open>(rule iffI;  clarsimp simp add: sep_basic_simps simp),
  exI_pick_last_conj\<close>

text \<open>The sep_subst method takes rule of the form "(some_sep_prop \<and>* R) = _"  and
 substitute the LHS with the RHS without having to put some_sep_prop in first pos in
the goal

This method should probably be rewritten in ML with a loop for
performance and to remove the current limitation of maximum 11
nested conjunctions.\<close>

method sep_subst uses simp =
 ((sep_select 1, subst simp) |
  (sep_select 2, subst simp) |
  (sep_select 3, subst simp) |
  (sep_select 4, subst simp) |
  (sep_select 5, subst simp) |
  (sep_select 6, subst simp) |
  (sep_select 7, subst simp) |
  (sep_select 8, subst simp) |
  (sep_select 9, subst simp) |
  (sep_select 10, subst simp))

method sep_simp_aux =
  simp only: sep_conj_first sep_conj_assoc conj_assoc

text \<open>sep_simp_no_asm simplifies a sep logic formula in the conclusion of a goal.
The conclusion can contain normal conjunctions (e.g. @{term "P \<and> (a \<and>* b) s \<and> Q"}),
if so, sep_simp_no_asm will move the element with a sep-conjunction in first
position and apply all the simp rules pass as argument to it.
The simp rules passed as argument must be of the form @{term "(some_sep_prop n \<and>* R) s = (SomeSepPropConst n \<in> s \<and> R (s - {SomeSepPropConst n}))"}
\<close>
method sep_simp_no_asm uses simp =
  ((sep_simp_aux,  (sep_subst simp: simp)?)+)[1] |
  (sep_subst simp: simp, (solves \<open>sep_simp_aux\<close> (* e.g. solves with refl *))?)

text \<open>Same as sep_simp_no_asm but for assumptions. sep_simp_asm can take several
rules to simplify, it rule attempt to apply all of them, multiple times.\<close>

method sep_simp_asm uses simp =
 (simp only: sep_conj_assoc)?,
 ((sep_select_asm 1, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 2, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 3, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 4, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 5, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 6, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 7, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 8, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 9, subst (asm) simp, (erule conjE)+) |
  (sep_select_asm 10, subst (asm) simp, (erule conjE)+))+

method sep_simp uses simp =
  ((sep_simp_asm simp: simp, (sep_simp_no_asm simp: simp)?) |
  (sep_simp_no_asm simp: simp, (sep_simp_asm simp: simp)?))[1]

lemma sep_lc: "(a ** b ** c) = (b ** a ** c)"
 by (simp add: sep_conj_ac)

lemma sep_three : "(c ** a ** b) = (a ** b ** c)"
 by (simp add: sep_conj_ac)

definition emp :: "'a set_pred"
  where
    "emp s == (s = 0)"

lemma emp_sep [simp] :
  "(emp \<and>* r) = r"
  apply(simp add: emp_def  sep_conj_def)
 done

definition pure :: "bool \<Rightarrow> 'a set_pred"
  where
    "pure b s == emp s \<and> b"

notation pure ("\<langle> _ \<rangle>")

definition memory_usage :: "int \<Rightarrow> state_element set \<Rightarrow> bool"
where
"memory_usage u s == (s = {MemoryUsageElm u})"

definition stack_height :: "nat \<Rightarrow> state_element set \<Rightarrow> bool"
  where
    "stack_height h s == (s = {StackHeightElm h})"

definition stack :: "nat \<Rightarrow> w256 \<Rightarrow> state_element set \<Rightarrow> bool"
  where
    "stack pos v s == (s = {StackElm (pos, v)})"

definition program_counter :: "int \<Rightarrow> state_element set \<Rightarrow> bool"
  where
    "program_counter pos s == s = {PcElm pos}"

definition log_number :: "nat \<Rightarrow> state_element set \<Rightarrow> bool"
where
"log_number n s == s = {LogNumElm n}"

definition logged :: "nat \<Rightarrow> log_entry \<Rightarrow> state_element set \<Rightarrow> bool"
where
"logged n l s == s = {LogElm (n, l)}"

definition account_existence :: "address \<Rightarrow> bool \<Rightarrow> state_element set \<Rightarrow> bool"
where
"account_existence a b s == s = {AccountExistenceElm (a, b)}"

lemma sep_logged:
  "(a ** logged n l) s =
   (LogElm (n, l) \<in> s \<and> a (s - {LogElm (n, l)}))"
  by (solve_sep_iff simp: logged_def)

definition gas_pred :: "int \<Rightarrow> state_element set \<Rightarrow> bool"
  where
    "gas_pred g s == s = {GasElm g}"

definition gas_any :: "state_element set \<Rightarrow> bool"
  where
    "gas_any s == (\<exists> g. s = {GasElm g})"

lemma gas_any_sep :
  "(gas_any ** rest) s =
   (\<exists> g. GasElm g \<in> s \<and> rest (s - {GasElm g}))"
  apply (rule iffI)
   apply (fastforce simp: gas_any_def sep_basic_simps)
  apply (clarsimp simp add: sep_basic_simps gas_any_def)
  apply (rule_tac x="{GasElm g}" in exI)
  apply (exI_pick_last_conj)
 done

lemma sep_gas_any_sep:
  "(a ** gas_any ** rest) s =
   (\<exists> g. GasElm g \<in> s \<and> (a ** rest) (s - {GasElm g}))"
 by (sep_simp simp: gas_any_sep)

lemma sep_log_number_sep:
  "(log_number n \<and>* R) s =
   (LogNumElm n \<in> s \<and> R (s - {LogNumElm n}))
  "
  by (solve_sep_iff simp: log_number_def)

definition caller :: "address \<Rightarrow> state_element set \<Rightarrow> bool"
where
"caller c s == s = {CallerElm c}"

definition storage :: "w256 \<Rightarrow> w256 \<Rightarrow> state_element set \<Rightarrow> bool"
where
"storage idx w s == s = {StorageElm (idx, w)}"

definition this_account :: "address \<Rightarrow> state_element set \<Rightarrow> bool"
where
"this_account t s == s = {ThisAccountElm t}"

definition balance :: "address \<Rightarrow> w256 \<Rightarrow> state_element set \<Rightarrow> bool"
where
"balance adr v s == s = {BalanceElm (adr, v)}"

definition block_number_pred :: "w256 \<Rightarrow> state_element set \<Rightarrow> bool"
where
"block_number_pred w s == s = {BlockNumberElm w}"

definition continuing :: "state_element set \<Rightarrow> bool"
where
"continuing s == s = { ContinuingElm True }"

definition not_continuing :: "state_element set \<Rightarrow> bool"
where
"not_continuing s == s = {ContinuingElm False}"

definition action :: "contract_action \<Rightarrow> state_element set \<Rightarrow> bool"
where
"action act s == s = {ContractActionElm act}"

(* memory8, memory, calldata, and storage should be added here *)

definition memory8 :: "w256 \<Rightarrow> byte \<Rightarrow> state_element set \<Rightarrow> bool"
where
"memory8 idx v s == s = {MemoryElm (idx ,v)}"

lemma memory8_sep :
 "(memory8 idx v ** rest) s = (MemoryElm (idx, v) \<in> s \<and> rest (s - {MemoryElm (idx, v)}))"
 by (solve_sep_iff simp: memory8_def)

lemma sep_memory8_sep :
"(a ** memory8 idx v ** rest) s = (MemoryElm (idx, v) \<in> s \<and> (a ** rest) (s - {MemoryElm (idx, v)}))"
proof -
  have "(a ** memory8 idx v ** rest) s = (memory8 idx v ** a ** rest) s"
    by (metis sep_conj_assoc sep_conj_commute)
  moreover have "(memory8 idx v ** a ** rest) s = (MemoryElm (idx, v) \<in> s \<and> (a ** rest) (s - {MemoryElm (idx, v)}))"
    by (rule memory8_sep)
  ultimately show ?thesis
    by auto
qed

fun memory_range :: "w256 \<Rightarrow> byte list \<Rightarrow> state_element set \<Rightarrow> bool"
where
  "memory_range begin [] = emp"
| "memory_range begin (h # t) = (memory8 begin h ** memory_range (begin + 1) t)"

fun memory_range_elms :: "w256 \<Rightarrow> byte list \<Rightarrow> state_element set"
where
  "memory_range_elms begin [] = {}"
| "memory_range_elms begin (a # lst) = {MemoryElm (begin, a)} \<union> memory_range_elms (begin + 1) lst"

lemma memory_range_elms_nil :
  "x \<notin> memory_range_elms b []"
apply(simp)
done

lemma memory_range_elms_cons :
  "memory_range_elms b (a # lst) = {MemoryElm (b, a)} \<union> memory_range_elms (b + 1) lst"
apply(auto)
done

(* prove a lemma about the above two definitions *)

lemma stack_sound0 :
  "(stack pos w ** p) s \<Longrightarrow> StackElm (pos, w) \<in> s"
by (clarsimp simp add: sep_basic_simps stack_def)

lemmas context_rw = contexts_as_set_def variable_ctx_as_set_def constant_ctx_as_set_def
      stack_as_set_def memory_as_set_def
      balance_as_set_def storage_as_set_def log_as_set_def program_as_set_def data_sent_as_set_def
      ext_program_as_set_def account_existence_as_set_def

lemma stack_sound1 :
  "StackElm (pos, w) \<in> contexts_as_set var con \<Longrightarrow> rev (vctx_stack var) ! pos = w"
  apply(simp add: context_rw)
  done

lemma stack_sem :
  "(stack pos w ** p) (contexts_as_set var con) \<Longrightarrow> rev (vctx_stack var) ! pos = w"
  apply(drule stack_sound0)
  apply(drule stack_sound1)
  apply(simp)
  done

definition instruction_result_as_set :: "constant_ctx \<Rightarrow> instruction_result \<Rightarrow> state_element set"
  where
    "instruction_result_as_set c rslt =
        ( case rslt of
          InstructionContinue v \<Rightarrow> {ContinuingElm True} \<union> contexts_as_set v c
        | InstructionToEnvironment act v _ \<Rightarrow> {ContinuingElm False, ContractActionElm act} \<union> contexts_as_set v c
        )"

definition code :: "(int * inst) set \<Rightarrow> state_element set \<Rightarrow> bool"
  where
    "code f s == s = { CodeElm(pos, i) | pos i. (pos, i) \<in> f }"

axiomatization hash2 :: "w256 \<Rightarrow> w256 \<Rightarrow> w256" where
hash_inj :
    "hash2 b v1 = hash2 c v2 \<Longrightarrow> b = c \<or> hash2 b v1 = 0"
and hash_inj2 :
   "hash2 b v1 = hash2 c v2 \<Longrightarrow> v1 = v2  \<or> hash2 b v1 = 0"
and hash_compat :
   "hash2 a b \<noteq> 0 \<Longrightarrow> hash2 a b = keccak (word_rsplit a@ word_rsplit b)"

definition magic_filter :: "8 word list \<Rightarrow> bool" where
"magic_filter lst = (\<forall> a b.
   (lst = word_rsplit a @ word_rsplit b) \<longrightarrow>
   hash2 a b \<noteq> 0)"

definition failed_for_reasons :: "failure_reason set \<Rightarrow> instruction_result \<Rightarrow> bool"
where
"failed_for_reasons allowed r =
 (allowed \<noteq> {} \<and>
 (\<exists> reasons a b.
              r = InstructionToEnvironment (ContractFail reasons) a b
              \<and> set reasons \<subseteq> allowed))"

definition triple ::
 "network \<Rightarrow> failure_reason set \<Rightarrow> (state_element set \<Rightarrow> state_element set \<Rightarrow> bool)
          \<Rightarrow> (state_element set \<Rightarrow> bool) \<Rightarrow> (int * inst) set \<Rightarrow> (state_element set \<Rightarrow> bool) \<Rightarrow> bool"
where
  "triple net allowed_failures reentrancy pre insts post ==
    \<forall> co_ctx presult rest stopper.
       (pre ** code insts ** rest) (instruction_result_as_set co_ctx presult) \<longrightarrow>
       (\<exists> k.
         ((post ** code insts ** rest) (instruction_result_as_set co_ctx (program_sem stopper co_ctx k net presult)))
         \<or> failed_for_reasons allowed_failures (program_sem stopper co_ctx k net presult))"

lemma pure_sep : "(((\<langle> b \<rangle>) ** rest) s) = (b \<and> rest s)"
  by ( simp add: sep_conj_def pure_def emp_def )

lemma continuing_sep:
  "(continuing ** rest) s = ((ContinuingElm True) \<in> s \<and> rest (s - {ContinuingElm True}))"
   by (solve_sep_iff simp: continuing_def)

lemma sep_continuing_sep:
  "(a ** continuing ** b) s = ((ContinuingElm True) \<in> s \<and> (a ** b) (s - {ContinuingElm True}))"
 by (rule iffI) (sep_simp simp: continuing_sep)+

lemma storage_sep:
  "(storage idx w ** rest) s =
   (StorageElm (idx, w) \<in> s \<and> rest (s - {StorageElm (idx, w)}))"
   by (solve_sep_iff simp: storage_def)

lemma sep_storage:
  "(rest ** storage idx w) s =
   (StorageElm (idx, w) \<in> s \<and> rest (s - {StorageElm (idx, w)}))"
  by (solve_sep_iff simp: storage_def)

lemma stack_height_sep : "(stack_height h ** rest) s =
  (StackHeightElm h \<in> s \<and> rest (s - {StackHeightElm h})) "
  by (solve_sep_iff simp: stack_height_def)

lemma sep_stack_height : "(rest ** stack_height h) s =
  (StackHeightElm h \<in> s \<and> rest (s - {StackHeightElm h})) "
  by (solve_sep_iff simp: stack_height_def)

lemma sep_stack_height_sep: "(a ** stack_height h ** rest) s =
  (StackHeightElm h \<in> s \<and> (a ** rest) (s - {StackHeightElm h})) "
  by (sep_simp simp: stack_height_sep)

lemma stack_sep : "(stack p w ** rest) s =
  (StackElm (p, w) \<in> s \<and> rest (s - {StackElm (p, w)}))"
  by (solve_sep_iff simp: stack_def)

lemma sep_stack : "(rest ** stack p w) s =
  (StackElm (p, w) \<in> s \<and> rest (s - {StackElm (p, w)}))"
  by (solve_sep_iff simp: stack_def)

lemma sep_stack_sep  : "(a ** stack p w ** rest) s =
  (StackElm (p, w) \<in> s \<and> (a ** rest) (s - {StackElm (p, w)}))"
  by (sep_simp simp: stack_sep)

lemma program_counter_sep : "(program_counter w ** rest) s =
  (PcElm w \<in> s \<and> rest (s - {PcElm w}))"
  by (solve_sep_iff simp: program_counter_def)

lemma sep_program_counter : "(rest ** program_counter w) s =
  (PcElm w \<in> s \<and> rest (s - {PcElm w}))"
  by (solve_sep_iff simp: program_counter_def)

lemma sep_program_counter_sep : "(a ** program_counter w ** rest) s =
  (PcElm w \<in> s \<and> (a ** rest) (s - {PcElm w}))"
  by (sep_simp simp: program_counter_sep)

lemma code_sep: "(code pairs ** rest) s =
  ({ CodeElm(pos, i) | pos i. (pos, i) \<in> pairs } \<subseteq> s \<and> (rest (s - { CodeElm(pos, i) | pos i. (pos, i) \<in> pairs })))"
  apply (rule iffI)
    apply (rule conjI)
  apply (clarsimp simp: code_def sep_basic_simps)
   apply (clarsimp simp:  sep_basic_simps)
    apply (erule back_subst[where P=rest])
    apply(fastforce simp add: code_def)
  apply (clarsimp simp: code_def sep_basic_simps)
  apply exI_pick_last_conj
 done

lemma sep_code : "(rest ** code pairs) s =
  ({ CodeElm(pos, i) | pos i. (pos, i) \<in> pairs } \<subseteq> s \<and> (rest (s - { CodeElm(pos, i) | pos i. (pos, i) \<in> pairs })))"
  by (sep_simp simp: code_sep)

lemma sep_code_sep: "(a ** code pairs ** rest) s =
  ({ CodeElm(pos, i) | pos i. (pos, i) \<in> pairs } \<subseteq> s \<and> ((a ** rest) (s - { CodeElm(pos, i) | pos i. (pos, i) \<in> pairs })))"
  by (sep_simp simp: code_sep)

lemma sep_sep_code : "(a ** b ** code pairs) s =
  ({ CodeElm(pos, i) | pos i. (pos, i) \<in> pairs } \<subseteq> s \<and> ((a ** b) (s - { CodeElm(pos, i) | pos i. (pos, i) \<in> pairs })))"
  by (sep_simp simp: code_sep)

lemma gas_pred_sep : "(gas_pred g ** rest) s =
  ( GasElm g \<in> s \<and> rest (s - { GasElm g }) )"
  by (solve_sep_iff simp: gas_pred_def)

lemma sep_gas_pred : "(rest ** gas_pred g) s =
  ( GasElm g \<in> s \<and> rest (s - { GasElm g }) )"
  by (solve_sep_iff simp: gas_pred_def)

lemma sep_gas_pred_sep:
  "(a ** gas_pred g ** b) s =
   ( GasElm g \<in> s \<and> (a ** b) (s - { GasElm g } ) )"
 by (sep_simp simp: gas_pred_sep)

lemma memory_usage_sep:
  "(memory_usage u ** rest) s =
   (MemoryUsageElm u \<in> s \<and> rest (s - {MemoryUsageElm u}))"
  by (solve_sep_iff simp: memory_usage_def)

lemma sep_memory_usage:
  "(rest ** memory_usage u) s =
   (MemoryUsageElm u \<in> s \<and> rest (s - {MemoryUsageElm u}))"
 by (solve_sep_iff simp: memory_usage_def)

lemma sep_memory_usage_sep:
  "(a ** memory_usage u ** rest) s =
   (MemoryUsageElm u \<in> s \<and> (a ** rest) (s - {MemoryUsageElm u}))"
	by (sep_simp simp:  memory_usage_sep)

lemma stackHeightElmEquiv: "StackHeightElm h \<in> contexts_as_set v c =
  (length (vctx_stack v) = h)
  "
by (auto simp add:context_rw)

lemma stackElmEquiv: "StackElm (pos, w) \<in> contexts_as_set v c =
  (pos < length (vctx_stack v) \<and> rev (vctx_stack v) ! pos = w)"
by (auto simp add:context_rw)

lemma pcElmEquiv : "PcElm k \<in> contexts_as_set va_ctx co_ctx =
  (vctx_pc va_ctx = k)"
by (auto simp add:context_rw)

lemma gasElmEquiv: "GasElm g \<in> contexts_as_set va_ctx co_ctx =
  (vctx_gas va_ctx = g)"
by (auto simp add:context_rw)

lemma codeElmEquiv:
  "CodeElm (pos, i) \<in> contexts_as_set va_ctx co_ctx =
   ((program_content (cctx_program co_ctx) pos = Some i) \<or>
   (program_content (cctx_program co_ctx) pos = None) \<and> i = Misc STOP)"
by (auto simp add:context_rw)

lemmas stateelm_equiv_simps =
  stackHeightElmEquiv
  stackElmEquiv
  pcElmEquiv
  gasElmEquiv
  codeElmEquiv

lemma insert_minus : "a \<noteq> b \<Longrightarrow> insert a s - { b } = insert a (s - {b})"
  apply(simp add: insert_Diff_if)
  done

lemma pred_functional : "p (s :: state_element set) \<Longrightarrow> s = t \<Longrightarrow> p t"
apply(auto)
done

lemma insert_functional : "e = f \<Longrightarrow> s = t \<Longrightarrow> insert e s = insert f t"
  apply(auto)
  done

lemma lookup_over[simp] : "(rev lista @ (aa # l)) ! length lista = aa"
	by (metis length_rev nth_append_length)

lemma lookup_over1[simp] : "(rev lista @ (w # a # l)) ! Suc (length lista) = a"
(* sledgehammer *)
	by (metis add.left_neutral append.assoc append_Nil2 length_append length_rev list.size(3) list.size(4) nth_append_length plus_nat.simps(2) rev.simps(2) rev_append rev_rev_ident)

lemma short_match[simp] :
  "idx < length lista \<Longrightarrow> (rev lista @ l) ! idx = (rev lista @ m) ! idx"
(* sledgehammer *)
	by (simp add: nth_append)

(**
 ** Inference rules about Hoare triples
 ** Following Magnus Myreen's thesis, 3.5
 **)
lemma code_diff_union : "(code (a \<union> b)) = (code a ** (code (b - a)))"
  by (rule ext)
     (auto simp: sep_basic_simps code_def)

lemma code_diff_union' : "(code (a \<union> b)) = (code b ** (code (a - b)))"
  by (rule ext)
     (auto simp: sep_basic_simps code_def)

lemma code_middle:
  "(p ** code (c_1 \<union> c_2) ** rest) =
   (p ** (code c_1 ** (code (c_2 - c_1))) ** rest)"
 by (simp add: code_diff_union)

lemma code_middle':
  "(p ** rest ** code (c_1 \<union> c_2)) =
   (p ** rest ** (code c_1 ** (code (c_2 - c_1))))"
 by (simp add: code_diff_union)

lemma shuffle3:
  "(p ** (code c_1 ** code (c_2 - c_1)) ** rest) =
   (p ** code c_1 ** (code (c_2 - c_1) ** rest))"
 by (metis sep_conj_assoc)

lemma execution_continue:
  "(program_sem s co_ctx a net (program_sem s co_ctx b net presult) = program_sem s co_ctx (b + a) net presult)"
apply(induction b arbitrary: presult)
 apply(simp add: program_sem.simps)
apply(simp add: program_sem.simps)
done

(* Maybe it's better to organize program_sem as a function from program_result to program_result *)
lemma triple_continue:
"triple net allowed ind q c r \<Longrightarrow>
 no_assertion co_ctx \<Longrightarrow>
 (q ** code c ** rest) (instruction_result_as_set co_ctx (program_sem s co_ctx k net presult)) \<Longrightarrow>
 \<exists> l. ((r ** code c ** rest) (instruction_result_as_set co_ctx (program_sem s co_ctx (k + l) net presult))
      \<or> failed_for_reasons allowed (program_sem s co_ctx (k + l) net presult))"
apply(simp add: triple_def)
apply(drule_tac x = co_ctx in spec)
apply(drule_tac x = "program_sem s co_ctx k net presult" in spec)
apply(drule_tac x = rest in spec)
apply(simp)
apply(drule_tac x = s in spec)
apply (simp add:  sep_code_sep   execution_continue)
done

lemma code_back:
  "(q ** code c_1 ** code (c_2 - c_1) ** rest) s = (q ** code (c_1 \<union> c_2) ** rest) s"
apply(simp only: code_middle shuffle3)
done

lemma code_more:
  "(rest ** p ** code cL ** code (cR - cL)) s = (rest ** p ** code (cL \<union> cR)) s"
apply(simp add: code_middle')
done

lemma code_union_comm :
 "code (cR \<union> cL) = code (cL \<union> cR)"
  by (simp add: sup_commute)

lemma code_union_s:
  "(q ** code (c_2 \<union> c_1) ** rest) s \<Longrightarrow> (q ** code (c_1 \<union> c_2) ** rest) s"
(* sledgehammer *)
	by (simp add: sup_commute)

lemma composition:
  "c = cL \<union> cR \<Longrightarrow> triple net F ind P cL Q \<Longrightarrow> triple net F ind Q cR R \<Longrightarrow> triple net F ind P c R"
  apply (simp (no_asm) add: triple_def)
  apply clarsimp
  apply (subst (asm) triple_def[where pre=P])
  apply clarsimp
  apply (rename_tac co_ctx presult rest stopper)
  apply(drule_tac x = "co_ctx" in spec)
  apply(drule_tac x = "presult" in spec)
  apply(drule_tac x = "code (cR - cL) ** rest" in spec)
  apply (erule impE)
   apply(subgoal_tac "(instruction_result_as_set co_ctx presult - {CodeElm (pos, i) |pos i. (pos, i) \<in> cL \<or> (pos, i) \<in> cR})
    = (instruction_result_as_set co_ctx presult - {CodeElm (pos, i) |pos i. (pos, i) \<in> cL} -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cR \<and> (pos, i) \<notin> cL})")
    apply (simp add: code_back)
   apply blast
  apply(drule_tac x = stopper in spec)
  apply(erule exE)
  apply (subst (asm) triple_def[where pre=Q])
  apply(drule_tac x = "co_ctx" in spec)
  apply(drule_tac x = "(program_sem stopper co_ctx k net presult)" in spec)
  apply(drule_tac x = "code (cL - cR) ** rest" in spec)
  apply(erule disjE)
   apply(drule_tac x = stopper in spec)
   apply (erule impE)
    apply(subgoal_tac "(instruction_result_as_set co_ctx (program_sem stopper co_ctx k net presult) -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cL} -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cR \<and> (pos, i) \<notin> cL}) =
         (instruction_result_as_set co_ctx (program_sem stopper co_ctx k net presult) -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cR} -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cL \<and> (pos, i) \<notin> cR})")
     apply (metis code_diff_union code_union_comm sep_three)
    apply blast
   apply(erule exE)
   apply(rename_tac k l)
   apply(rule_tac x = "k + l" in exI)
   apply(erule disjE)
   apply(rule disjI1)
   apply(subgoal_tac "
   (instruction_result_as_set co_ctx (program_sem stopper co_ctx (k + l) net presult) -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cR} -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cL \<and> (pos, i) \<notin> cR}) =
   (instruction_result_as_set co_ctx (program_sem stopper co_ctx (k + l) net presult) -
         {CodeElm (pos, i) |pos i. (pos, i) \<in> cL \<or> (pos, i) \<in> cR})")
    apply (simp add: code_back code_union_s execution_continue)
   apply blast
  apply auto
 using execution_continue by auto

(** Frame **)

lemma frame:
 "triple net F ind P c Q \<Longrightarrow> triple net F ind (P ** R) c (Q ** R)"
  apply (simp add: triple_def)
  apply clarsimp
  subgoal for co_ctx presult rest stopper
  apply (drule spec[where x=co_ctx])
  apply (drule spec2[where x=presult and y="R ** rest"])
  apply (simp del: sep_conj_assoc add: sep_conj_ac)
  done
 done

lemma imp_sepL:
  "(\<forall>s. a s \<longrightarrow> b s) \<Longrightarrow>
   (\<forall>s. (a ** c) s \<longrightarrow> (b ** c) s)"
  by (auto simp add: sep_basic_simps)

lemma frame_backward:
  "triple net F ind P c Q \<Longrightarrow> P' = (P ** R) \<Longrightarrow> Q' = (Q ** R) \<Longrightarrow>
   triple net F ind P' c Q'"
  by (simp add: frame)

lemma remove_true:
 "(p ** \<langle>True\<rangle> ** rest) = (p ** rest)"
 by (simp add: pure_def sep_conj_def emp_def)

lemma true_sep [simp] :
  "(p ** \<langle>True\<rangle>) = p"
 by (simp add: pure_def sep_conj_def emp_def)

lemma sep_true [simp] :
  "(\<langle>True\<rangle> ** p) = p"
 by (simp add: pure_def sep_conj_def emp_def)

lemma move_pure0 :
  "triple net reasons ind (p ** \<langle> True \<rangle>) c q \<Longrightarrow>  triple net reasons ind p c q"
apply(simp add: triple_def remove_true)
done

lemma false_triple :
  "triple net reasons ind (p ** \<langle> False \<rangle>) c q"
apply(simp add: triple_def sep_basic_simps pure_def)
done

lemma get_pure:
  "((p ** \<langle> b \<rangle> ** rest) s) = (b \<and> (p ** rest) s)"
apply(auto simp add: sep_basic_simps pure_def emp_def)
done

lemma move_pure: "triple net reaons ind (p ** \<langle> b \<rangle>) c q = (b \<longrightarrow> triple net reaons ind p c q)"
apply(auto simp add: move_pure0 false_triple)
apply(case_tac b; auto simp: false_triple)
  done

lemma pure_sepD:
  "(\<langle>P\<rangle> ** R) s \<Longrightarrow> R s"
  by (simp add: pure_def emp_def sep_basic_simps)

lemma move_pureL: "triple net reaons ind (\<langle> b \<rangle> ** p) c q = (b \<longrightarrow> triple net reaons ind p c q)"
 by (metis move_pure sep_conj_commute)

lemma tmp01:
    "(rest ** code c ** p x) (case presult of InstructionContinue v \<Rightarrow> contexts_as_set v co_ctx | _ \<Rightarrow> {}) \<Longrightarrow>
    (rest ** code c ** (\<lambda>s. \<exists>x. p x s)) (case presult of InstructionContinue v \<Rightarrow> contexts_as_set v co_ctx | _ \<Rightarrow> {})"
  apply (sep_cancel)+
  apply blast
  done

lemma tmp0:
       "\<forall>co_ctx. no_assertion co_ctx \<longrightarrow>
                (\<forall>presult rest.
                    ((\<lambda>s. \<exists>x. p x s) ** code c ** rest) (case presult of InstructionContinue v \<Rightarrow> contexts_as_set v co_ctx | _ \<Rightarrow> {}) \<longrightarrow>
                    (\<forall>stopper. \<exists>k. (q ** code c ** rest) (case program_sem stopper co_ctx k net presult of InstructionContinue v \<Rightarrow> contexts_as_set v co_ctx | _ \<Rightarrow> {}))) \<Longrightarrow>
       no_assertion co_ctx \<Longrightarrow>
       (p x ** code c ** rest) (case presult of InstructionContinue v \<Rightarrow> contexts_as_set v co_ctx | _ \<Rightarrow> {}) \<Longrightarrow>
       \<exists>k. (q ** code c ** rest) (case program_sem stopper co_ctx k net presult of InstructionContinue v \<Rightarrow> contexts_as_set v co_ctx | _ \<Rightarrow> {})"
apply(drule_tac x = co_ctx in spec)
apply(simp)
apply(drule_tac x = presult in spec)
apply(drule_tac x = rest in spec)
apply(subgoal_tac "(rest ** code c ** (\<lambda>s. \<exists>x. p x s))
     (case presult of InstructionContinue v \<Rightarrow> contexts_as_set v co_ctx | _ \<Rightarrow> {})")
    (*
apply(rule tmp01)
apply(simp)
done*)
    oops

lemma preE0:
  "((\<lambda>s. \<exists>x. p x s) ** code c ** rest) s \<Longrightarrow>
   \<exists> x. (p x ** code c ** rest) s"
apply(auto simp only: sep_basic_simps)
	by blast

lemma sep_impL :
 "\<forall> s. b s \<longrightarrow> a s \<Longrightarrow>
 (c ** b ** d) s \<longrightarrow>
 (c ** a ** d) s"
  by (metis sep_basic_simps)

lemma pre_imp:
 assumes "\<forall> s. (b s \<longrightarrow> a s)"
 and " triple net reasons ind a c q"
shows" triple net reasons ind b c q"
using assms(2)
  apply(auto simp add: triple_def)
  apply(drule_tac x = co_ctx in spec)
  apply(drule_tac x = presult in spec)
  apply(drule_tac x = rest in spec)
  apply (erule impE)
   apply (sep_drule  assms(1)[rule_format])
   apply blast
  apply(subgoal_tac "(rest ** a ** code c) (instruction_result_as_set co_ctx presult)")
   apply(simp )
  apply (sep_rule sep_impL[OF assms(1), rule_format])
  apply(simp add: code_sep sep_code_sep)
 done

lemma preE1:
"((\<lambda>s. \<exists>x. p x s) ** rest) u
=
(\<exists> x. (p x ** rest) u)
"
apply(auto simp add: sep_basic_simps)
done

lemma preE00:
  "(rest ** code c ** p x) s \<Longrightarrow>
   (rest ** code c ** (\<lambda>s. \<exists>x. p x s)) s"
  apply (sep_cancel)+
  apply blast
 done

lemma preE : "triple net reasons ind (\<lambda> s. \<exists> x. p x s) c q = (\<forall> x. triple net reasons ind (p x) c q)"
apply(auto simp add: triple_def preE1)
 apply(erule_tac x = co_ctx in allE)
 apply(drule_tac x = presult in spec)
  apply(drule_tac x = rest in spec)
  apply (erule impE)
   apply blast
 apply(subgoal_tac "(rest ** code c ** (\<lambda>s. \<exists>x. p x s)) (instruction_result_as_set co_ctx presult)")
   apply(simp)
  apply(rule_tac x=x in preE00)
  apply(simp)
  apply (sep_simp simp: code_sep )
  apply (simp add: sep_conj_commute)
done

(** More rules to come **)

lemma triple_tauto: "triple net failures ind q e q"
apply(simp add: triple_def; auto)
apply(rule_tac x = 0 in exI)
apply(simp add: program_sem.simps)
done

lemma code_extension0: "triple net failures ind p c_1 q \<Longrightarrow> triple net failures ind q c_2 q \<Longrightarrow>
                        triple net failures ind p (c_1 \<union> c_2) q"
apply(rule_tac cL = c_1 and cR = c_2 in composition; auto)
done

lemma code_extension : "triple net failures ind p c q \<Longrightarrow> triple net failures ind p (c \<union> e) q"
	by (simp add: composition triple_tauto)

lemma code_extension_backward :
  "triple net failures ind p c' q \<Longrightarrow> c' \<subseteq> c \<Longrightarrow> triple net failures ind p c q"
proof -
 assume "triple net failures ind p c' q"
 then have "triple net failures ind p (c' \<union> c) q"
  using code_extension by blast
 moreover assume "c' \<subseteq> c"
 then have "c = c' \<union> c"
  by (auto)
 ultimately show "triple net failures ind p c q"
  by auto
qed

(* Some rules about this if-then-else should be derivable. *)

definition if_then_else :: "int \<Rightarrow> inst list \<Rightarrow> inst list \<Rightarrow> inst list \<Rightarrow> inst list"
where
"if_then_else beginning cond then_case else_case =
 cond
 @ (* beginning + length cond *)
 [Stack (PUSH_N (word_rsplit (word_of_int (beginning + int (length cond) + 8 + int (length else_case)) :: 16 word))), Pc JUMPI]
 @ (* beginning + length cond + 4 *)
 else_case
 @ (* beginning + length cond + length else_case + 4 *)
 [Stack (PUSH_N (word_rsplit (word_of_int (beginning + int (length cond) + int (length else_case) + 9 + int (length then_case)) :: 16 word))), Pc JUMP]
 @ (* beginning + length cond + length else_case + 8 *)
 [Pc JUMPDEST]
 @ (* beginning + length cond + length else_case + 9 *)
 then_case
 @ (* beginning + length cond + length else_case + 9 + length then_case *)
 [Pc JUMPDEST]
"

(* example of if_then_else *)

(* loop *)

(* precondition / post condition pair *)

(* What would be the type of precondition? *)
(* instruction_result \<Rightarrow> bool
 * In the precondition, the program counter is overwritten.
 *)

(* validity of pre, program, post triples.
 * Failures are considered as success.
 *)

bundle hoare_bundle =
sep_logged[simp]
gas_any_sep[simp]
sep_gas_any_sep[simp]
sep_log_number_sep[simp]
memory8_sep[simp]
pure_sep[simp]
continuing_sep[simp]
sep_continuing_sep[simp]
storage_sep[simp]
sep_storage[simp]
stack_height_sep[simp]
sep_stack_height[simp]
sep_stack_height_sep[simp]
stack_sep[simp]
sep_stack[simp]
sep_stack_sep[simp]
program_counter_sep[simp]
sep_program_counter[simp]
sep_program_counter_sep[simp]
code_sep[simp]
sep_code[simp]
sep_code_sep[simp]
sep_sep_code[simp]
gas_pred_sep[simp]
sep_gas_pred[simp]
sep_gas_pred_sep[simp]
memory_usage_sep[simp]
sep_memory_usage[simp]
sep_memory_usage_sep[simp]
stackHeightElmEquiv[simp]
stackElmEquiv[simp]
pcElmEquiv[simp]
gasElmEquiv[simp]
codeElmEquiv[simp]
lookup_over[simp]
lookup_over1[simp]
short_match[simp]
memory_as_set_def[simp]
storage_as_set_def[simp]
log_as_set_def[simp]
balance_as_set_def[simp]
next_state_def[simp]
execution_continue[simp]
sep_true[simp]
false_triple[simp]
get_pure[simp]
move_pure[simp]
move_pureL[simp]
sep_code_sep[simp]
preE1[simp]
sep_code_sep[simp]
sep_sep_code[simp]

end


theory Bipartite_Vertex_Priorities
  imports
    Bipartite_Matching_LP
    Measure_Misc
begin

lemma funcset_update:
  assumes "Y \<in> L - {i} \<rightarrow> S"
  assumes "y \<in> S"
  shows "Y(i := y) \<in> L \<rightarrow> S"
  using assms
  by auto

locale bipartite_vertex_priorities = bipartite_matching_lp
begin

abbreviation "\<U> \<equiv> uniform_measure lborel {0..1::real}"
abbreviation "\<Y> \<equiv> \<Pi>\<^sub>M i \<in> L. \<U>"

sublocale component_prob_space: prob_space \<U>
  by (auto intro: prob_space_uniform_measure)

lemmas component_prob_space.prob_space_axioms[intro]

sublocale prob_space \<Y>
  by (auto intro: prob_space_PiM)

lemma prob_space_PiM_\<U>:
  "prob_space (PiM I (\<lambda>_. \<U>))"
  by (auto intro: prob_space_PiM)

lemma emeasure_space_PiM_\<U>[simp]:
  shows "emeasure (PiM I (\<lambda>_. \<U>)) (space (PiM I (\<lambda>_. \<U>))) = 1"
  by (intro prob_space.emeasure_space_1 prob_space_PiM_\<U>)

lemma pair_sigma_finite_split_dim[intro]: "pair_sigma_finite \<U> (Pi\<^sub>M (L - {i}) (\<lambda>i. \<U>))"
  by (intro pair_sigma_finite.intro prob_space_imp_sigma_finite prob_space_PiM) blast+

lemmas pair_sigma_finite_split_dim'[intro] = pair_sigma_finite.pair_sigma_finite_swap[OF pair_sigma_finite_split_dim]

lemma AE_PiM_subset_L_\<U>_funcset:
  assumes "L' \<subseteq> L"
  shows "AE Y in \<Pi>\<^sub>M i \<in> L'. \<U>. Y \<in> L' \<rightarrow> {0..1}"
  using finite_L assms
  by (intro AE_PiM_uniform_measure_PiE_countable)
     (auto intro: countable_finite finite_subset)

lemmas AE_\<Y>_funcset = AE_PiM_subset_L_\<U>_funcset[where L' = L, OF subset_refl]

lemma AE_\<U>_in_range: "AE y in \<U>. y \<in> {0..1}"
  by (auto intro: AE_uniform_measureI)

lemma AE_add_dim_in_range:
  "AE (y,Y) in (\<U> \<Otimes>\<^sub>M Pi\<^sub>M (L - {i}) (\<lambda>i. \<U>)). y \<in> {0..1}"
  by (subst pair_sigma_finite.AE_pair_measure_swap)
     (auto simp: case_prod_beta space_pair_measure intro!: pair_sigma_finite.AE_pair_measure AE_uniform_measureI)

lemma AE_add_dim_funcset:
  "AE (y,Y) in (\<U> \<Otimes>\<^sub>M Pi\<^sub>M (L - {i}) (\<lambda>i. \<U>)). Y \<in> L - {i} \<rightarrow> {0..1}"
  using finite_L
  by (auto intro!: pair_sigma_finite.AE_pair_measure AE_PiM_subset_L_\<U>_funcset simp: case_prod_beta space_pair_measure)

lemma AE_split_dim_funcset:
  shows "AE (y, Y) in \<U> \<Otimes>\<^sub>M Pi\<^sub>M (L - {i}) (\<lambda>i. \<U>). Y(i := y) \<in> L \<rightarrow> {0..1}"
  using AE_add_dim_in_range AE_add_dim_funcset
  by eventually_elim auto

lemma AE_\<U>_funcset:
  "i \<in> L \<Longrightarrow> Y \<in> L - {i} \<rightarrow> {0..1} \<Longrightarrow> AE y in \<U>. Y(i:=y) \<in> L \<rightarrow> {0..1}"
  using AE_\<U>_in_range
  by eventually_elim auto

end

end


theory Sepref_Acconstraint
  imports Refine_Imperative_HOL.IICF TA.Timed_Automata
begin

term hn_ctxt

  subsection \<open>Refinement Assertion\<close>
  fun acconstraint_assn where
(*
    "acconstraint_assn A (E1 x) (E1 x') = A x x'"
  | "acconstraint_assn A (E2 x) (E2 x') = A x x'"
  | "acconstraint_assn A (E3) (E3) = emp"
*)
  "acconstraint_assn A B (LT x y) (LT x' y') = A x x' * B y y'"
  | "acconstraint_assn A B (LE x y) (LE x' y') = A x x' * B y y'"
  | "acconstraint_assn A B (EQ x y) (EQ x' y') = A x x' * B y y'"
  | "acconstraint_assn A B (GE x y) (GE x' y') = A x x' * B y y'"
  | "acconstraint_assn A B (GT x y) (GT x' y') = A x x' * B y y'"
(*
  | "acconstraint_assn A (E5 x y) (E5 x' y') = bool_assn x x' * A y y'"
*)
  | "acconstraint_assn _ _ _ _ = false"

  fun acconstraint_relp where
  "acconstraint_relp A B (LT x y) (LT x' y') \<longleftrightarrow> A x x' \<and> B y y'"
  | "acconstraint_relp A B (LE x y) (LE x' y') \<longleftrightarrow> A x x' \<and> B y y'"
  | "acconstraint_relp A B (EQ x y) (EQ x' y') \<longleftrightarrow> A x x' \<and> B y y'"
  | "acconstraint_relp A B (GE x y) (GE x' y') \<longleftrightarrow> A x x' \<and> B y y'"
  | "acconstraint_relp A B (GT x y) (GT x' y') \<longleftrightarrow> A x x' \<and> B y y'"
  | "acconstraint_relp _ _ _ _ \<longleftrightarrow> False"

  definition [to_relAPP]: "acconstraint_rel A B \<equiv> p2rel (acconstraint_relp (rel2p A) (rel2p B))"

  lemma aconstraint_assn_pure_conv[constraint_simps]:
    "acconstraint_assn (pure A) (pure B) \<equiv> pure (\<langle>A,B\<rangle> acconstraint_rel)"
  apply (rule eq_reflection)
  apply (intro ext)
  subgoal for a b
  apply (cases a; cases b; simp add: acconstraint_rel_def pure_def p2rel_def rel2p_def)
  done
  done

  lemmas [sepref_import_rewrite, sepref_frame_normrel_eqs, fcomp_norm_unfold] =
    aconstraint_assn_pure_conv[symmetric]

  text \<open>You might want to prove some properties\<close>

  text \<open>A pure-rule is required to enable recovering of invalidated data that was not stored on the heap\<close>
  lemma acconstraint_assn_pure[constraint_rules]: "is_pure A \<Longrightarrow> is_pure B \<Longrightarrow> is_pure (acconstraint_assn A B)"
    apply (auto simp: is_pure_iff_pure_assn)
    apply (rename_tac x x')
    apply (case_tac x; case_tac x'; simp add: pure_def)
    done

  text \<open>An identitiy rule is required to easily prove trivial refinement theorems\<close>
  lemma acconstraint_assn_id[simp]: "acconstraint_assn id_assn id_assn = id_assn"
    apply (intro ext)
    subgoal for x y by (cases x; cases y; simp add: pure_def)
    done

  text \<open>With congruence condition\<close>
  lemma acconstraint_match_cong[sepref_frame_match_rules]:
    "\<lbrakk>\<And>x y. \<lbrakk>x\<in>set1_acconstraint e; y\<in>set1_acconstraint e'\<rbrakk> \<Longrightarrow> hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt A' x y\<rbrakk>
    \<Longrightarrow> \<lbrakk>\<And>x y. \<lbrakk>x\<in>set2_acconstraint e; y\<in>set2_acconstraint e'\<rbrakk> \<Longrightarrow> hn_ctxt B x y \<Longrightarrow>\<^sub>t hn_ctxt B' x y\<rbrakk>
    \<Longrightarrow> hn_ctxt (acconstraint_assn A B) e e' \<Longrightarrow>\<^sub>t hn_ctxt (acconstraint_assn A' B') e e'"
    by (cases e; cases e'; simp add: hn_ctxt_def entt_star_mono)

  lemma acconstraint_merge_cong[sepref_frame_merge_rules]:
    assumes "\<And>x y. \<lbrakk>x\<in>set1_acconstraint e; y\<in>set1_acconstraint e'\<rbrakk> \<Longrightarrow> hn_ctxt A x y \<or>\<^sub>A hn_ctxt A' x y \<Longrightarrow>\<^sub>t hn_ctxt Am x y"
    assumes "\<And>x y. \<lbrakk>x\<in>set2_acconstraint e; y\<in>set2_acconstraint e'\<rbrakk> \<Longrightarrow> hn_ctxt B x y \<or>\<^sub>A hn_ctxt B' x y \<Longrightarrow>\<^sub>t hn_ctxt Bm x y"
    shows "hn_ctxt (acconstraint_assn A B) e e' \<or>\<^sub>A hn_ctxt (acconstraint_assn A' B') e e' \<Longrightarrow>\<^sub>t hn_ctxt (acconstraint_assn Am Bm) e e'"
    apply (blast intro: entt_disjE acconstraint_match_cong entt_disjD1[OF assms(1)] entt_disjD2[OF assms(1)] entt_disjD1[OF assms(2)] entt_disjD2[OF assms(2)])
    done

  text \<open>Propagating invalid\<close>
  lemma entt_invalid_acconstraint: "hn_invalid (acconstraint_assn A B) e e' \<Longrightarrow>\<^sub>t hn_ctxt (acconstraint_assn (invalid_assn A) (invalid_assn B)) e e'"
    apply (simp add: hn_ctxt_def invalid_assn_def[abs_def])
    apply (rule enttI)
    apply clarsimp
    apply (cases e; cases e'; auto simp: mod_star_conv pure_def)
    done

  lemmas invalid_acconstraint_merge[sepref_frame_merge_rules] = gen_merge_cons[OF entt_invalid_acconstraint]

  subsection \<open>Constructors\<close>
  text \<open>Constructors need to be registered\<close>
  sepref_register LT LE EQ GE GT

  text \<open>Refinement rules can be proven straightforwardly on the separation logic level (method @{method sepref_to_hoare})\<close>
  (*
  lemma [sepref_fr_rules]: "(return o E1,RETURN o E1) \<in> A\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A"
    by sepref_to_hoare sep_auto
  lemma [sepref_fr_rules]: "(return o E2,RETURN o E2) \<in> A\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A"
    by sepref_to_hoare sep_auto
  lemma [sepref_fr_rules]: "(uncurry0 (return E3),uncurry0 (RETURN E3)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a acconstraint_assn A"
    by sepref_to_hoare sep_auto
  *)
  lemma [sepref_fr_rules]: "(uncurry (return oo LT),uncurry (RETURN oo LT)) \<in> A\<^sup>d*\<^sub>aB\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A B"
    by sepref_to_hoare sep_auto
  lemma [sepref_fr_rules]: "(uncurry (return oo LE),uncurry (RETURN oo LE)) \<in> A\<^sup>d*\<^sub>aB\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A B"
    by sepref_to_hoare sep_auto
  lemma [sepref_fr_rules]: "(uncurry (return oo EQ),uncurry (RETURN oo EQ)) \<in> A\<^sup>d*\<^sub>aB\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A B"
    by sepref_to_hoare sep_auto
  lemma [sepref_fr_rules]: "(uncurry (return oo GE),uncurry (RETURN oo GE)) \<in> A\<^sup>d*\<^sub>aB\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A B"
    by sepref_to_hoare sep_auto
  lemma [sepref_fr_rules]: "(uncurry (return oo GT),uncurry (RETURN oo GT)) \<in> A\<^sup>d*\<^sub>aB\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A B"
    by sepref_to_hoare sep_auto
  (*
  lemma [sepref_fr_rules]: "(uncurry (return oo E4),uncurry (RETURN oo E4)) \<in> A\<^sup>d*\<^sub>aA\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A"
    by sepref_to_hoare sep_auto
  *)
  (*
  lemma [sepref_fr_rules]: "(uncurry (return oo E5),uncurry (RETURN oo E5)) \<in> bool_assn\<^sup>k*\<^sub>aA\<^sup>d \<rightarrow>\<^sub>a acconstraint_assn A"
    by sepref_to_hoare (sep_auto simp: pure_def)
  *)

  subsection \<open>Destructor\<close>
  text \<open>There is currently no automation for destructors, so all the registration boilerplate
    needs to be done manually\<close>

  text \<open>Set ups operation identification heuristics\<close>
  sepref_register case_acconstraint

  text \<open>In the monadify phase, this eta-expands to make visible all required arguments\<close>
  lemma [sepref_monadify_arity]: "case_acconstraint \<equiv> \<lambda>\<^sub>2f1 f2 f3 f4 f5 x. SP case_acconstraint$(\<lambda>\<^sub>2x. f1$x)$(\<lambda>\<^sub>2x. f2$x)$f3$(\<lambda>\<^sub>2x y. f4$x$y)$(\<lambda>\<^sub>2x y. f5$x$y)$x"
    by simp

  text \<open>This determines an evaluation order for the first-order operands\<close>
  lemma [sepref_monadify_comb]: "case_acconstraint$f1$f2$f3$f4$f5$x \<equiv> (\<bind>)$(EVAL$x)$(\<lambda>\<^sub>2x. SP case_acconstraint$f1$f2$f3$f4$f5$x)" by simp

  text \<open>This enables translation of the case-distinction in a non-monadic context.\<close>
  lemma [sepref_monadify_comb]: "EVAL$(case_acconstraint$(\<lambda>\<^sub>2x y. f1 x y)$(\<lambda>\<^sub>2x y. f2 x y)$(\<lambda>\<^sub>2x y. f3 x y)$(\<lambda>\<^sub>2x y. f4 x y)$(\<lambda>\<^sub>2x y. f5 x y)$x)
    \<equiv> (\<bind>)$(EVAL$x)$(\<lambda>\<^sub>2x. SP case_acconstraint$(\<lambda>\<^sub>2x y. EVAL $ f1 x y)$(\<lambda>\<^sub>2x y. EVAL $ f2 x y)$(\<lambda>\<^sub>2x y. EVAL $ f3 x y)$(\<lambda>\<^sub>2x y. EVAL $ f4 x y)$(\<lambda>\<^sub>2x y. EVAL $ f5 x y)$x)"
    apply (rule eq_reflection)
    by (simp split: acconstraint.splits)

  text \<open>Auxiliary lemma, to lift simp-rule over \<open>hn_ctxt\<close>\<close>
  lemma acconstraint_assn_ctxt: "acconstraint_assn A B x y = z \<Longrightarrow> hn_ctxt (acconstraint_assn A B) x y = z"
    by (simp add: hn_ctxt_def)

  text \<open>The cases lemma first extracts the refinement for the datatype from the precondition.
    Next, it generate proof obligations to refine the functions for every case.
    Finally the postconditions of the refinement are merged.

    Note that we handle the
    destructed values separately, to allow reconstruction of the original datatype after the case-expression.

    Moreover, we provide (invalidated) versions of the original compound value to the cases,
    which allows access to pure compound values from inside the case.
    \<close>
  lemma acconstraint_cases_hnr:
    fixes A B and e :: "('a,'b) acconstraint" and e' :: "('ai,'bi) acconstraint"
    defines [simp]: "INVe \<equiv> hn_invalid (acconstraint_assn A B) e e'"
    assumes FR: "\<Gamma> \<Longrightarrow>\<^sub>t hn_ctxt (acconstraint_assn A B) e e' * F"
    (*
    assumes E1: "\<And>x1 x1a. \<lbrakk>e = E1 x1; e' = E1 x1a\<rbrakk> \<Longrightarrow> hn_refine (hn_ctxt A x1 x1a * INVe * F) (f1' x1a) (hn_ctxt A1' x1 x1a * hn_ctxt XX1 e e' * \<Gamma>1') R (f1 x1)"
    assumes E2: "\<And>x2 x2a. \<lbrakk>e = E2 x2; e' = E2 x2a\<rbrakk> \<Longrightarrow> hn_refine (hn_ctxt A x2 x2a * INVe * F) (f2' x2a) (hn_ctxt A2' x2 x2a * hn_ctxt XX2 e e' * \<Gamma>2') R (f2 x2)"
    assumes E3: "\<lbrakk>e = E3; e' = E3\<rbrakk> \<Longrightarrow> hn_refine F f3' \<Gamma>3' R f3"
    *)
    assumes LT: "\<And>x41 x42 x41a x42a.
       \<lbrakk>e = LT x41 x42; e' = LT x41a x42a\<rbrakk>
       \<Longrightarrow> hn_refine
            (hn_ctxt A x41 x41a * hn_ctxt B x42 x42a * INVe * F)
            (f1' x41a x42a)
            (hn_ctxt A1a' x41 x41a * hn_ctxt B1b' x42 x42a * hn_ctxt XX1 e e' * \<Gamma>1') R
            (f1 x41 x42)"
    assumes LE: "\<And>x41 x42 x41a x42a.
       \<lbrakk>e = LE x41 x42; e' = LE x41a x42a\<rbrakk>
       \<Longrightarrow> hn_refine
            (hn_ctxt A x41 x41a * hn_ctxt B x42 x42a * INVe * F)
            (f2' x41a x42a)
            (hn_ctxt A2a' x41 x41a * hn_ctxt B2b' x42 x42a * hn_ctxt XX2 e e' * \<Gamma>2') R
            (f2 x41 x42)"
    assumes EQ: "\<And>x41 x42 x41a x42a.
       \<lbrakk>e = EQ x41 x42; e' = EQ x41a x42a\<rbrakk>
       \<Longrightarrow> hn_refine
            (hn_ctxt A x41 x41a * hn_ctxt B x42 x42a * INVe * F)
            (f3' x41a x42a)
            (hn_ctxt A3a' x41 x41a * hn_ctxt B3b' x42 x42a * hn_ctxt XX3 e e' * \<Gamma>3') R
            (f3 x41 x42)"
    assumes GE: "\<And>x41 x42 x41a x42a.
       \<lbrakk>e = GE x41 x42; e' = GE x41a x42a\<rbrakk>
       \<Longrightarrow> hn_refine
            (hn_ctxt A x41 x41a * hn_ctxt B x42 x42a * INVe * F)
            (f4' x41a x42a)
            (hn_ctxt A4a' x41 x41a * hn_ctxt B4b' x42 x42a * hn_ctxt XX4 e e' * \<Gamma>4') R
            (f4 x41 x42)"
    assumes GT: "\<And>x41 x42 x41a x42a.
       \<lbrakk>e = GT x41 x42; e' = GT x41a x42a\<rbrakk>
       \<Longrightarrow> hn_refine
            (hn_ctxt A x41 x41a * hn_ctxt B x42 x42a * INVe * F)
            (f5' x41a x42a)
            (hn_ctxt A5a' x41 x41a * hn_ctxt B5b' x42 x42a * hn_ctxt XX5 e e' * \<Gamma>5') R
            (f5 x41 x42)"
    (*
    assumes E5: "\<And>x51 x52 x51a x52a.
       \<lbrakk>e = E5 x51 x52; e' = E5 x51a x52a\<rbrakk>
       \<Longrightarrow> hn_refine (hn_ctxt bool_assn x51 x51a * hn_ctxt A x52 x52a * INVe * F) (f5' x51a x52a)
            (hn_ctxt bool_assn x51 x51a * hn_ctxt A5' x52 x52a * hn_ctxt XX5 e e' * \<Gamma>5') R (f5 x51 x52)"
    *)
    assumes MERGE1a[unfolded hn_ctxt_def]:
      "\<And>x x'. hn_ctxt A1a' x x' \<or>\<^sub>A hn_ctxt A2a' x x' \<or>\<^sub>A hn_ctxt A3a' x x' \<or>\<^sub>A hn_ctxt A4a' x x' \<or>\<^sub>A hn_ctxt A5a' x x' \<Longrightarrow>\<^sub>t hn_ctxt A' x x'"
    assumes MERGE1b[unfolded hn_ctxt_def]:
      "\<And>x x'. hn_ctxt B1b' x x' \<or>\<^sub>A hn_ctxt B2b' x x' \<or>\<^sub>A hn_ctxt B3b' x x' \<or>\<^sub>A hn_ctxt B4b' x x' \<or>\<^sub>A hn_ctxt B5b' x x' \<Longrightarrow>\<^sub>t hn_ctxt B' x x'"
    assumes MERGE2[unfolded hn_ctxt_def]: "\<Gamma>1' \<or>\<^sub>A \<Gamma>2' \<or>\<^sub>A \<Gamma>3' \<or>\<^sub>A \<Gamma>4' \<or>\<^sub>A \<Gamma>5' \<Longrightarrow>\<^sub>t \<Gamma>'"
    shows "hn_refine \<Gamma> (case_acconstraint f1' f2' f3' f5' f4' e') (hn_ctxt (acconstraint_assn A' B') e e' * \<Gamma>') R (case_acconstraint$(\<lambda>\<^sub>2x y. f1 x y)$(\<lambda>\<^sub>2x y. f2 x y)$(\<lambda>\<^sub>2x y. f3 x y)$(\<lambda>\<^sub>2x y. f5 x y)$(\<lambda>\<^sub>2x y. f4 x y)$e)"

    apply (rule hn_refine_cons_pre[OF FR])
    apply1 extract_hnr_invalids
    apply (cases e; cases e'; simp add: acconstraint_assn.simps[THEN acconstraint_assn_ctxt])
    subgoal
      apply (rule hn_refine_cons[OF _ LT _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)
      apply (rule entt_star_mono)
      apply1 (rule entt_fr_drop)
      apply (rule entt_star_mono)

      apply1 (rule entt_trans[OF _ MERGE1a])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE1b])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE2])
      applyS (simp add: entt_disjI1' entt_disjI2')
    done
    subgoal
      apply (rule hn_refine_cons[OF _ LE _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)
      apply (rule entt_star_mono)
      apply1 (rule entt_fr_drop)
      apply (rule entt_star_mono)

      apply1 (rule entt_trans[OF _ MERGE1a])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE1b])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE2])
      applyS (simp add: entt_disjI1' entt_disjI2')
    done
    subgoal
      apply (rule hn_refine_cons[OF _ EQ _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)
      apply (rule entt_star_mono)
      apply1 (rule entt_fr_drop)
      apply (rule entt_star_mono)

      apply1 (rule entt_trans[OF _ MERGE1a])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE1b])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE2])
      applyS (simp add: entt_disjI1' entt_disjI2')
    done
    subgoal
      apply (rule hn_refine_cons[OF _ GT _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)
      apply (rule entt_star_mono)
      apply1 (rule entt_fr_drop)
      apply (rule entt_star_mono)

      apply1 (rule entt_trans[OF _ MERGE1a])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE1b])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE2])
      applyS (simp add: entt_disjI1' entt_disjI2')
    done
    subgoal
      apply (rule hn_refine_cons[OF _ GE _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)
      apply (rule entt_star_mono)
      apply1 (rule entt_fr_drop)
      apply (rule entt_star_mono)

      apply1 (rule entt_trans[OF _ MERGE1a])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE1b])
      applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')

      apply1 (rule entt_trans[OF _ MERGE2])
      applyS (simp add: entt_disjI1' entt_disjI2')
    done
  done

  text \<open>After some more preprocessing (adding extra frame-rules for non-atomic postconditions,
    and splitting the merge-terms into binary merges), this rule can be registered\<close>
  lemmas [sepref_comb_rules] = acconstraint_cases_hnr[sepref_prep_comb_rule]

  subsection \<open>Regression Test\<close>
(*

  definition "test \<equiv> do {
    let x = E1 True;

    _ \<leftarrow> case x of
      E1 _ \<Rightarrow> RETURN x  (* Access compound inside case *)
    | _ \<Rightarrow> RETURN E3;

    (* Now test with non-pure *)
    let a = op_array_replicate 4 (3::nat);
    let x = E5 False a;

    _ \<leftarrow> case x of
      E1 _ \<Rightarrow> RETURN (0::nat)
    | E2 _ \<Rightarrow> RETURN 1
    | E3 \<Rightarrow> RETURN 0
    | E4 _ _ \<Rightarrow> RETURN 0
    | E5 _ a \<Rightarrow> mop_list_get a 0;

    (* Rely on that compound still exists (it's components are only read in the case above) *)
    case x of
      E1 a \<Rightarrow> do {mop_list_set a 0 0; RETURN (0::nat)}
    | E2 _ \<Rightarrow> RETURN 1
    | E3 \<Rightarrow> RETURN 0
    | E4 _ _ \<Rightarrow> RETURN 0
    | E5 _ _ \<Rightarrow> RETURN 0
  }"

  sepref_definition foo is "SYNTH (uncurry0 test) (unit_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn)"
    unfolding test_def
    supply [[goals_limit=1]]
    by sepref
*)

end


(*  Title:      HOL/Auth/n_moesi.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_moesi Protocol Case Study*}

theory n_moesi imports n_moesi_lemma_invs_on_rules n_moesi_on_inis
begin
lemma main:
assumes a1: "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
and a2: "0 < N"
shows "\<forall> f. f \<in> (invariants N) --> formEval f s"
proof (rule consistentLemma)
show "consistent (invariants N) {andList (allInitSpecs N)} (rules N)"
proof (cut_tac a1, unfold consistent_def, rule conjI)
show "\<forall> f ini s. f \<in> (invariants N) --> ini \<in> {andList (allInitSpecs N)} --> formEval ini s --> formEval f s"
proof ((rule allI)+, (rule impI)+)
  fix f ini s
  assume b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  have b4: "formEval (andList (allInitSpecs N)) s"
  apply (cut_tac b2 b3, simp) done
  show "formEval f s"
  apply (rule on_inis, cut_tac b1, assumption, cut_tac b2, assumption, cut_tac b3, assumption) done
qed
next show "\<forall> f r s. f \<in> invariants N --> r \<in> rules N --> invHoldForRule s f r (invariants N)"
proof ((rule allI)+, (rule impI)+)
  fix f r s
  assume b1: "f \<in> invariants N" and b2: "r \<in> rules N"
  show "invHoldForRule s f r (invariants N)"
  apply (rule invs_on_rules, cut_tac b1, assumption, cut_tac b2, assumption) done
qed
qed
next show "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
  apply (metis a1) done
qed
end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory NAND_Hoare_Inert_Typed
  imports VHDL_Hoare_Typed NAND_Femto
begin

subsection \<open>Proving @{term "nand3"}: NAND with inert delay \<close>

abbreviation "bval_of_wline tw sig n \<equiv> bval_of (wline_of tw sig n)"
abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

locale scalar_type_nand3 =
  fixes \<Gamma> :: "sig tyenv"
  assumes "\<Gamma> A = Bty" and "\<Gamma> B = Bty" and "\<Gamma> C = Bty"
begin

text \<open>Invariant for NAND: at all times @{term "i"}, the signal @{term "C :: sig"} at @{term "i"}
should be the NAND value of @{term "A :: sig"} and @{term "B :: sig"} at time @{term "i - 1"}.\<close>

definition nand_inv :: "sig assn2" where
  "nand_inv \<equiv> (\<lambda>tw. bval_of_wline tw C (fst tw) \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw - 1) \<and> bval_of_wline tw B (fst tw - 1)))"

definition nand_inv2 :: "sig assn2" where
  "nand_inv2 \<equiv> (\<lambda>tw. disjnt {A, B} (event_of tw) \<longrightarrow> (\<forall>i > fst tw. bval_of_wline tw C i \<longleftrightarrow> bval_of_wline tw C (fst tw)))"

lemma nand_inv_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Bnand (Bsig A) (Bsig B))"
  defines "tw' \<equiv> tw\<lbrakk>C, 1 :=\<^sub>2 v\<rbrakk>"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "nand_inv (fst tw' + 1, snd tw')"
proof -
  have bexpA: "bexp_wt \<Gamma> (Bsig A) Bty" and bexpB: "bexp_wt \<Gamma> (Bsig B) Bty"
    using scalar_type_nand3_axioms unfolding scalar_type_nand3_def  by (metis bexp_wt.intros(3))+
  have "type_of v = Bty"
    using assms(3) bexpA bexpB bexp_wt.intros(9) type_of_eval_world_raw2 v_def by blast
  hence "bval_of_wline tw' C (fst tw + 1) \<longleftrightarrow> bval_of v"
    unfolding tw'_def
  proof (induction v)
    case (Bv x)
    have "snd (snd tw) C (get_time tw) \<noteq> Bv x \<and> snd (snd tw) C (get_time tw + 1) = Bv x \<Longrightarrow>
          (GREATEST n. n \<le> get_time tw + 1 \<and> snd (snd tw) C (n - 1) \<noteq> Bv x \<and> snd (snd tw) C n = Bv x) \<le> fst tw + 1"
      by (metis (mono_tags, lifting) GreatestI_ex_nat Suc_eq_plus1 add_diff_cancel_left' order_refl plus_1_eq_Suc)
    then show ?case
      unfolding worldline_inert_upd2_def VHDL_Hoare.worldline_inert_upd2.simps worldline_inert_upd_def
      comp_def snd_conv by auto
  next
    case (Lv sign bs)
    then show ?case
      by auto
  qed
  also have "... \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw) \<and> bval_of_wline tw B (fst tw))"
    using eval_world_raw_bv[OF bexpA `wityping \<Gamma> (snd tw)`]  eval_world_raw_bv[OF bexpB `wityping \<Gamma> (snd tw)`]
    unfolding v_def by (auto split:val.split)(metis val.distinct(1))+
  finally show ?thesis
    unfolding nand_inv_def tw'_def worldline_inert_upd2_def worldline_inert_upd_def
    by (metis (no_types, hide_lams) One_nat_def add_implies_diff comp_def fst_conv not_less_less_Suc_eq not_less_zero order_refl snd_conv snd_worldline_inert_upd2 worldline_inert_upd2_def)
qed

lemma nand_inv2_next_time:
  fixes tw v
  defines "tw' \<equiv> tw\<lbrakk>C, 1 :=\<^sub>2 v\<rbrakk>"
  shows   "nand_inv2 (fst tw' + 1, snd tw')"
proof -
  { assume "disjnt {A, B} (event_of (fst tw' + 1, snd tw'))"
    have "\<And>j. fst tw + 1 < j \<Longrightarrow> bval_of_wline tw' C j \<longleftrightarrow> bval_of_wline tw' C (fst tw + 1)"
      unfolding tw'_def
    proof (induction v)
      case (Bv x)
      then show ?case
      proof (cases "snd (snd tw) C (get_time tw) = Bv x \<or> snd (snd tw) C (get_time tw + 1) \<noteq> Bv x ")
        case True
        then show ?thesis
          using Bv
          unfolding worldline_inert_upd2_def VHDL_Hoare.worldline_inert_upd2.simps worldline_inert_upd_def
          comp_def snd_conv by auto
      next
        case False
        hence "snd (snd tw) C (get_time tw) \<noteq> Bv x \<and> snd (snd tw) C (get_time tw + 1) = Bv x"
          by auto
        hence "(GREATEST n. n \<le> get_time tw + 1 \<and> snd (snd tw) C (n - 1) \<noteq> Bv x \<and> snd (snd tw) C n = Bv x) = fst tw + 1"
          using GreatestI_nat[where k="fst tw + 1"]
          by (metis (mono_tags, lifting) Greatest_equality Suc_eq_plus1 diff_Suc_1 le_eq_less_or_eq)
        then show ?thesis
          using Bv False
          unfolding worldline_inert_upd2_def VHDL_Hoare.worldline_inert_upd2.simps worldline_inert_upd_def
          comp_def snd_conv by auto
      qed
    next
      case (Lv sign bs)
      let ?w' = "\<lambda>b. snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)]"
      let ?time = "LEAST n. get_time tw < n \<and> n \<le> get_time tw + 1 \<and> (\<exists>b\<in>set [0..<length bs]. ?w' b C (n - 1) \<noteq> ?w' b C n)"
      have *: " bs = (map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1))) [0..<length bs])"
      proof (rule nth_equalityI)
        show "length bs = length (map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1))) [0..<length bs])"
          by auto
      next
        fix b
        assume "b < length bs"
        hence "map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1))) [0..<length bs] ! b =
              bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1))"
          by auto
        have "((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C (get_time tw)  \<noteq> Bv (bs ! b) \<and>
             ((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C (get_time tw + 1) = Bv (bs ! b) \<Longrightarrow>
            ( GREATEST n.
                  n \<le> get_time tw + 1 \<and>
                  ((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C (n - 1) \<noteq> Bv (bs ! b) \<and>
                  ((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C n = Bv (bs ! b)) = fst tw + 1"
          by (metis (mono_tags, lifting) Greatest_equality add_diff_cancel_right' le_eq_less_or_eq)
        hence "bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1)) = (bs ! b)"
          unfolding to_worldline_init_bit_def worldline_inert_upd_def snd_conv by auto
        thus " bs ! b =
        map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1))) [0..<length bs] !
        b "
          using \<open>map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1))) [0..<length bs] ! b = bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (fst tw + 1))\<close>
          by blast
      qed
      have **: " bs = (map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j))) [0..<length bs])"
      proof (rule nth_equalityI)
        show "length bs = length (map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j))) [0..<length bs])"
          by auto
      next
        fix b
        assume "b < length bs"
        hence "map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j))) [0..<length bs] ! b =
              bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j))"
          by auto
        have "((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C (get_time tw)  \<noteq> Bv (bs ! b) \<and>
             ((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C (get_time tw + 1) = Bv (bs ! b) \<Longrightarrow>
            ( GREATEST n.
                  n \<le> get_time tw + 1 \<and>
                  ((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C (n - 1) \<noteq> Bv (bs ! b) \<and>
                  ((snd (snd tw))(C := to_bit b \<circ> snd (snd tw) C)) C n = Bv (bs ! b)) = fst tw + 1"
          by (metis (mono_tags, lifting) Greatest_equality add_diff_cancel_right' le_eq_less_or_eq)
        hence "bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j)) = (bs ! b)"
          unfolding to_worldline_init_bit_def worldline_inert_upd_def snd_conv
          using Lv by auto
        thus " bs ! b =
        map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j))) [0..<length bs] !
        b "
          using \<open>map (\<lambda>b. bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j))) [0..<length bs] ! b = bval_of (snd to_worldline_init_bit (snd tw) C b[C, get_time tw, 1 := Bv (bs ! b)] C (j))\<close>
          by blast
      qed
      show ?case
      proof (cases "\<exists>n>get_time tw. n \<le> get_time tw + 1 \<and> (\<exists>b\<in>set [0..<length bs]. ?w' b C (n - 1) \<noteq> ?w' b C n)")
        case True
        hence "?time = fst tw + 1"
          by (metis (mono_tags, lifting) LeastI_ex antisym_conv1 discrete leD)
        hence "wline_of tw\<lbrakk> C, 1 :=\<^sub>2 Lv sign bs\<rbrakk> C (get_time tw + 1) = Lv sign bs"
          using *[THEN sym] True unfolding worldline_inert_upd2_def VHDL_Hoare.worldline_inert_upd2.simps comp_def snd_conv fun_upd_def
          by auto
        moreover have " wline_of tw\<lbrakk> C, 1 :=\<^sub>2 Lv sign bs\<rbrakk> C j =  Lv sign bs"
          using Lv True \<open>?time = fst tw + 1\<close> **
          unfolding worldline_inert_upd2_def comp_def snd_conv VHDL_Hoare.worldline_inert_upd2.simps
            fun_upd_def by auto
        ultimately show ?thesis
          by auto
      next
        case False
        then show ?thesis
          using Lv * **
          unfolding worldline_inert_upd2_def comp_def snd_conv VHDL_Hoare.worldline_inert_upd2.simps
          fun_upd_def by auto
      qed
    qed }
    thus "nand_inv2 (fst tw' + 1, snd tw')"
      unfolding nand_inv2_def by (simp add: tw'_def worldline_inert_upd2_def)
qed

lemma pre_nand_conc_hoare':
  "\<And>tw. nand_inv tw \<and> nand_inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> nand_inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "nand_inv tw \<and> nand_inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "nand_inv tw" and "nand_inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  have "bval_of_wline tw C (fst tw + 1) \<longleftrightarrow> bval_of_wline tw C (fst tw)"
    using `nand_inv2 tw` `disjnt {A, B} (event_of tw)` unfolding nand_inv2_def
    by (simp add: next_time_world_at_least)
  also have "... \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw - 1) \<and> bval_of_wline tw B (fst tw - 1))"
    using `nand_inv tw` unfolding nand_inv_def by auto
  also have "... \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw) \<and> bval_of_wline tw B (fst tw))"
    using `disjnt {A, B} (event_of tw)`  unfolding event_of_alt_def
    by (smt diff_0_eq_0 disjnt_insert1 mem_Collect_eq)
  finally show "nand_inv (fst tw + 1, snd tw)"
    unfolding nand_inv_def by auto
qed

lemma nand_conc_hoare2:
  "\<And>tw. nand_inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> nand_inv2 (fst tw + 1, snd tw)"
  unfolding nand_inv2_def by auto

lemma conc_stmt_wf_nand3:
  "conc_stmt_wf nand"
  unfolding nand_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc_nand3:
  "nonneg_delay_conc nand"
  unfolding nand_def by auto

lemma nonneg_delay_conc_nand3':
  "nonneg_delay_conc ( process {A, B} : Bassign_inert C (Bnand (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_nand3  by auto

lemma conc_wt_nand3:
  "conc_wt \<Gamma> nand"
  unfolding nand_def  by (metis bexp_wt.intros(3) bexp_wt.intros(9) conc_wt.intros(1) scalar_type_nand3_axioms
  scalar_type_nand3_def seq_wt.intros(5))

lemma conc_wt_nand3':
  "conc_wt \<Gamma> ( process {A, B} : Bassign_inert C (Bnand (Bsig A) (Bsig B)) 1)"
  using conc_wt_nand3 unfolding nand_def by auto

lemma nand_conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. nand_inv tw \<and> nand_inv2 tw\<rbrace> nand \<lbrace>\<lambda>tw. nand_inv tw \<and> nand_inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> nand (\<lambda>tw. nand_inv  (fst tw + 1, snd tw) \<and>
                                                      nand_inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf_nand3, rule nonneg_delay_conc_nand3, rule conc_wt_nand3, simp)
  unfolding nand_def  wp3_conc_single'[OF conc_wt_nand3' nonneg_delay_conc_nand3'] wp3_fun.simps
  using nand_conc_hoare2 nand_inv2_next_time nand_inv_next_time pre_nand_conc_hoare' by presburger

text \<open>Initialisation preserves the invariant\<close>

lemma seq_wt_nand3':
  "seq_wt \<Gamma> (Bassign_inert C (Bnand (Bsig A) (Bsig B)) 1)"
  using conc_wt_nand3' by auto

lemma nonneg_delay_nand3:
  " nonneg_delay (Bassign_inert C (Bnand (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_nand3' by auto

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0) nand (\<lambda>tw. nand_inv tw \<and> nand_inv2 tw)"
  unfolding nand_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. nand_inv (fst tw + 1, snd tw) \<and> nand_inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF seq_wt_nand3' nonneg_delay_nand3], simp)
  unfolding wp3_fun.simps using nand_inv_next_time nand_inv2_next_time by blast

lemma nand_correctness:
  assumes "sim_fin2 w (i + 1) nand tw'" and "wityping \<Gamma> w"
  shows "bval_of_wline tw' C (i + 1) \<longleftrightarrow> \<not> (bval_of_wline tw' A i \<and> bval_of_wline tw' B i)"
  using grand_correctness[OF assms conc_stmt_wf_nand3 conc_wt_nand3 nonneg_delay_conc_nand3 nand_conc_sim2' init_sat_nand_inv_comb]
  unfolding nand_inv_def by (metis (no_types, lifting) add_diff_cancel_right' assms(1)
  sim_fin2.cases world_maxtime_lt_fst_tres)

end


theory Debt_Axiom_Doc
  imports Main Debt_Axiom.Debt_Axiom
begin

section \<open>Introduction over an Example\<close>

text \<open>Debt Axiom provides an approach to safely declare an axiom early, build anything above
  the axiom, and later prove the validity of the previously declared axiom.
  The declared axioms are not free, but require certificates later.
  They are recorded in a ledger so we name them, \<^emph>\<open>debt axioms\<close>.
  A ML kernel validates the certificate and especially it does not depend on
  any declared debt axioms, so the certification is valid and it is a safe way to declare axioms.
  The ML kernel is tiny, consisting of 30 lines of code only, and depending only on
  Isabelle's kernel.

  It resembles Locale which enables local assumptions, but we do not use locales and they are
  real axioms, so we circumvent the limitations of Locale like incomplete supports for some
  Isabelle functions like syntax translation, and complexity of multi-dependence especially
  when the hierarchy is complicated, and also performance cost during activating a huge locale
  when using @{command context} command and \<open>(in locale)\<close> syntax.

  An example usage of the library is building an extensible modular semantic library, where
  we pre-build small snippets each of which formalizes a specific semantic feature,
  and we assemble the snippets of all the semantic features of a target language
  when we are going to formalize it.
  Each snippet can be an Isabelle theory and in the final assembly we import only the features that
  the target language needs.

  If we follow a deep embedding approach where two semantic types are used to model the type
    and the value of the language respectively, note,
  in such a generic library supporting free plug-in of various semantic features,
  the actual definition of the semantic types cannot be decided until the final target language
  to be formalized is given, because the complete semantic features are not decided until
  that time.

  However, if we want the library to be really useful by providing some reasoning supports and
    automatic mechanisms, we do need first the declarations of the semantic types,
    and partial definition about the semantic feature concerned by the module,
    so that we can provide some mechanisms for the feature.

  The Debt Axiom package addresses
  The tour starts from declaring semantic types used in our library to model the type
    and the value of the language respectively.

  Therefore, we just \<^emph>\<open>declare\<close> the types in an \<^emph>\<open>unspecified\<close> way.
\<close>

unspecified_type VAL

text \<open>They are unspecified meaning they are just declared but not finally defined.
The definition can be given later after the final target language is given and decides
the complete target semantic features.

We continue declare some basic infrastructure in the formalization.
\<open>typ_of\<close> give the type of a
\<close>

text \<open>Then we build a semantic module for integer value and its arithmetic.
In a new theory file for this feature, we declare the constructor of the integer model and also
its destructor.
\<close>

debt_axiomatization mk_int :: \<open>int \<Rightarrow> VAL\<close>
               and dest_int :: \<open>VAL \<Rightarrow> int\<close>
              where mk_int_inj[simp]: \<open>dest_int (mk_int i) = i\<close>

text \<open>\<open>dest_int\<close> should be the inverse function of \<open>mk_int\<close>. We declare this property by a debt
  axiom, and require the final semantic assembly to discharge the proof of the axiom.
  The @{command print_debt_axiom} now lists \<open>dest_int\<close> as an obligation debt.
\<close>

print_debt_axiom
  \<comment> \<open>\<open>\<And>i. dest_int (mk_int i) = i\<close>\<close>

text \<open>Formalization of instructions and various automation can be built above the semantic models.\<close>

definition \<open>op_add va vb = mk_int (dest_int va + dest_int vb)\<close>

lemma \<open>op_add (mk_int (1::int)) (op_add (mk_int 2) (mk_int 3)) = mk_int 6\<close>
  unfolding op_add_def by simp

text \<open>Meantime, we may formalize array in another theory file.\<close>

debt_axiomatization mk_array :: \<open>VAL list \<Rightarrow> VAL\<close>
              and dest_array :: \<open>VAL \<Rightarrow> VAL list\<close>
  where mk_array_inj[simp]: \<open>dest_array (mk_array x) = x\<close>

definition \<open>op_push v vL = mk_array (v # dest_array vL)\<close>
definition \<open>op_peek vL = hd (dest_array vL)\<close>
definition \<open>op_pop  vL = mk_array (tl (dest_array vL))\<close>

lemma \<open>op_peek (op_push v L) = v\<close>
  unfolding op_peek_def op_push_def by simp

text \<open>Now in the final theory file assembling the semantic modules,
  we instantiate the unspecified constants and discharge the debt axioms.\<close>

datatype val = V_int (dest_V_int: int) | V_array (dest_V_array: \<open>val list\<close>)

specify_type VAL[simp]: VAL = val

print_debt_axiom

specification (mk_int dest_int mk_array dest_array)
  mk_int_def': \<open>mk_int = VAL.inj o V_int\<close>
  dest_int_def': \<open>dest_int = dest_V_int o VAL.prj\<close>
  mk_array_def': \<open>mk_array = VAL.inj o V_array o map VAL.prj\<close>
  dest_array_def': \<open>dest_array = map VAL.inj o dest_V_array o VAL.prj\<close>
  by auto

lemma mk_int_inj': \<open>dest_int (mk_int i) = i\<close>
  unfolding mk_int_def' dest_int_def' by simp

lemma mk_array_inj': \<open>dest_array (mk_array x) = x\<close>
  unfolding mk_array_def' dest_array_def' by simp

discharge_debt_axiom mk_int_inj : mk_int_inj'
  and mk_array_inj : mk_array_inj'

print_debt_axiom \<comment> \<open>Good job! No debt axiom is recorded.\<close>

text \<open>It rejects impredicativeness properly thanking to the circular dependence checking by
  Isabelle's kernel.\<close>

end


theory CFGExit_wf imports CFGExit CFG_wf begin

subsection {* New well-formedness lemmas using @{text "(_Exit_)"} *}

locale CFGExit_wf = CFGExit sourcenode targetnode kind valid_edge Entry
    get_proc get_return_edges procs Main Exit +
  CFG_wf sourcenode targetnode kind valid_edge Entry
    get_proc get_return_edges procs Main Def Use ParamDefs ParamUses
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> ('var,'val,'ret,'pname) edge_kind"
  and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')")  and get_proc :: "'node \<Rightarrow> 'pname"
  and get_return_edges :: "'edge \<Rightarrow> 'edge set"
  and procs :: "('pname \<times> 'var list \<times> 'var list) list" and Main :: "'pname"
  and Exit::"'node"  ("'('_Exit'_')")
  and Def :: "'node \<Rightarrow> 'var set" and Use :: "'node \<Rightarrow> 'var set"
  and ParamDefs :: "'node \<Rightarrow> 'var list"
  and ParamUses :: "'node \<Rightarrow> 'var set list" +
  assumes Exit_empty:"Def (_Exit_) = {} \<and> Use (_Exit_) = {}"

begin

lemma Exit_Use_empty [dest!]: "V \<in> Use (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

lemma Exit_Def_empty [dest!]: "V \<in> Def (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

end

end


theory ExclLemma
  imports SafeRedCV ProcCVars ProcDef
begin

definition can_access where
  "can_access e x = (x \<in> ref_vars e)"

  (*thm proper_exp_def*)

lemma well_typed_deref_ex: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; x \<notin> free_vars e; x \<in> ref_vars e \<rbrakk> \<Longrightarrow> (\<exists> z. (z, x) \<in> deref_pairs e)"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
         apply (case_tac x2a)
           apply (auto)
    (* pair case. *)
        apply (blast)
       apply (blast)
    (* if case. *)
      apply (blast)
     apply (blast)
    apply (blast)
    (* lam case. *)
   apply (blast)
    (* app case. *)
  apply (blast)
  done

lemma well_typed_deref_ref_use: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; (x, y) \<in> deref_pairs e \<rbrakk> \<Longrightarrow> x \<in> ref_vars e"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
      apply (case_tac x2a)
        apply (auto)
    (* other cases. *)
     apply (blast)
    apply (blast)
   apply (blast)
  apply (blast)
  done

lemma well_typed_deref_npv_use: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; (x, y) \<in> deref_pairs e \<rbrakk> \<Longrightarrow> x \<in> non_prim_vars env e"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
          apply (case_tac x2a)
            apply (auto)
          apply (simp add: non_prim_vars_def)
          apply (simp add: non_prim_entry_def)
          apply (cut_tac tau_x="tau_x" in var_value_unlim)
            apply (auto)
    (* other cases. *)
         apply (simp add: non_prim_vars_def)
        apply (simp add: non_prim_vars_def)
       apply (simp add: non_prim_vars_def)
      apply (simp add: non_prim_vars_def)
     apply (simp add: non_prim_vars_def)
    apply (simp add: non_prim_vars_def)
    (* lam case *)
    apply (case_tac "x = x1a")
     apply (cut_tac e="e" and x="x" and env="add_env env x1a t1" in well_typed_deref_ref_use)
       apply (auto)
    apply (simp add: non_prim_entry_def)
    apply (case_tac "\<exists> t. add_env env x1a t1 x = Some t \<and> req_type t \<noteq> Prim")
     apply (simp add: add_env_def)
    apply (auto)
    (* app case *)
   apply (simp add: non_prim_vars_def)
  apply (simp add: non_prim_vars_def)
  done

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

    (* if x \<leadsto> z and y \<leadsto> z, and x is in the path from y \<leadsto> z, then y \<leadsto> a \<leadsto> x \<leadsto> z *)
lemma path_lookup_cross_ih: "\<lbrakk> path_lookup rs_map x l z; in_path x m; path_lookup rs_map y m z \<rbrakk> \<Longrightarrow>
  (\<exists> a m'. path_lookup rs_map y m' a \<and> nres_lookup rs_map a x \<noteq> NoPerm \<and> path_lookup rs_map x l z \<and> (a = y \<or> in_path a m))"
  apply (induct m arbitrary: y)
   apply (auto)
    (* case where x = a (the top of the path) *)
   apply (case_tac "rs_map y")
    apply (auto)
   apply (rule_tac x="y" in exI)
   apply (auto)
    apply (rule_tac x="[]" in exI)
    apply (simp)
   apply (simp add: nres_lookup_def)
    (* inductive case *)
  apply (case_tac "rs_map y")
   apply (auto)
  apply (case_tac "\<exists>b. (\<exists>m'. path_lookup rs_map a m' b) \<and> nres_lookup rs_map b x \<noteq> NoPerm \<and> (b = a \<or> in_path b m)")
   apply (erule_tac exE)
   apply (auto)
   apply (rule_tac x="a" in exI)
   apply (auto)
   apply (rule_tac x="[a]" in exI)
   apply (auto)
  apply (rule_tac x="b" in exI)
  apply (auto)
   apply (rule_tac x="a # m'" in exI)
  apply (auto)
  done

lemma lookup_in_path: "\<lbrakk> in_path z l; path_lookup rs_map x l y \<rbrakk> \<Longrightarrow> (\<exists> a. nres_lookup rs_map a z \<noteq> NoPerm)"
  apply (induct l arbitrary: x)
   apply (auto)
   apply (case_tac "rs_map x")
    apply (auto)
   apply (simp add: nres_lookup_def)
   apply (rule_tac x="x" in exI)
   apply (auto)
  apply (case_tac "rs_map x")
   apply (auto)
  done

lemma end_in_path: "\<lbrakk> x \<noteq> y; path_lookup rs_map x l y \<rbrakk> \<Longrightarrow> in_path y l"
  apply (induct l arbitrary: x)
   apply (auto)
  apply (case_tac "rs_map x")
   apply (auto)
  apply (case_tac "a = y")
   apply (auto)
  done

    (* if x \<leadsto> z and y \<leadsto> z, then x \<leadsto> a \<leadsto> c \<leadsto> z, and y \<leadsto> b \<leadsto> c \<leadsto> z, a \<noteq> b *)
lemma path_lookup_cross: "\<lbrakk> x \<noteq> y; \<not> in_path x m; \<not> in_path y l; path_lookup rs_map x l z; path_lookup rs_map y m z \<rbrakk> \<Longrightarrow>
  (\<exists> a b c l' m' lx. a \<noteq> b \<and> path_lookup rs_map x l' a \<and> path_lookup rs_map y m' b \<and>
    nres_lookup rs_map a c \<noteq> NoPerm \<and> nres_lookup rs_map b c \<noteq> NoPerm \<and> path_lookup rs_map c lx z)"
    (* we induct over the l, attempting to apply the induction lemma, when x is in_path m *)
  apply (induct l arbitrary: x)
   apply (auto)
    (* empty list case is impossible, since z must be in m *)
   apply (cut_tac y="z" and l="m" in end_in_path)
     apply (auto)
  apply (case_tac "rs_map x")
   apply (auto)
    (* if a is in_path m, by lemma we can get y \<leadsto> ? \<leadsto> a \<leadsto> z. we can select x \<leadsto> x \<leadsto> a \<leadsto> z, y \<leadsto> ? \<leadsto> a \<leadsto> z *)
  apply (case_tac "in_path a m")
   apply (case_tac "\<not> (\<exists>aa m'. path_lookup rs_map y m' aa \<and> nres_lookup rs_map aa a \<noteq> NoPerm \<and> path_lookup rs_map a l z \<and> (aa \<noteq> x))")
    apply (cut_tac x="a" and rs_map="rs_map" and l="l" and y="y" and z="z" and m="m" in path_lookup_cross_ih)
       apply (auto)
   apply (rule_tac x="x" in exI)
   apply (rule_tac x="aaa" in exI)
   apply (auto)
    apply (rule_tac x="[]" in exI)
    apply (auto)
   apply (rule_tac x="a" in exI)
   apply (simp add: nres_lookup_def)
   apply (case_tac "rs_map aaa")
    apply (auto)
    (* otherwise, we can induct. *)
  apply (case_tac "\<exists>a' b. a' \<noteq> b \<and> (\<exists>l'. path_lookup rs_map a l' a') \<and>
                          (\<exists>m'. path_lookup rs_map y m' b) \<and>
                          (\<exists>c. nres_lookup rs_map a' c \<noteq> NoPerm \<and> nres_lookup rs_map b c \<noteq> NoPerm \<and> (\<exists>lx. path_lookup rs_map c lx z))")
   apply (erule_tac exE)
   apply (auto)
    (* - we take x \<leadsto> a' \<leadsto> c \<leadsto> z, y \<leadsto> b \<leadsto> c \<leadsto> z *)
  apply (rule_tac x="a'" in exI)
  apply (rule_tac x="b" in exI)
  apply (auto)
  apply (rule_tac x="a # l'" in exI)
  apply (auto)
  done

lemma wts_excl_dom_use_env: "\<lbrakk> well_typed_system env rs_map p_map s p_set; u \<noteq> v; p_set u = Some e; p_set v = Some e';
  p_map u = Some r_sa; p_map v = Some r_sb; well_typed env r_sa e UnitTy r_se r_xe; well_typed env r_sb e' UnitTy r_se' r_xe' \<rbrakk> \<Longrightarrow>
  strong_disj_use_env (full_dom_use_env env rs_map e) (full_dom_use_env env rs_map e')"
    (* if this is not true, there is some z \<leadsto> x, za \<leadsto> x *)
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  apply (simp add: full_dom_use_env_def)
  apply (simp add: dom_use_env_def)
  apply (case_tac "\<exists>l z. z \<in> non_prim_vars env e' \<and> path_lookup rs_map z l x")
   apply (auto)
    (* we can establish r_sa za \<noteq> None, and r_sb z \<noteq> None *)
  apply (case_tac "r_sa za = NoPerm")
   apply (cut_tac x="za" and ?r_s1.0="r_sa" and e="e" in well_typed_no_npv_use)
     apply (auto)
  apply (case_tac "r_sb z = NoPerm")
   apply (cut_tac x="z" and ?r_s1.0="r_sb" and e="e'" in well_typed_no_npv_use)
     apply (auto)
    (* if z = za, we have a contradiction by map exclusion. *)
  apply (case_tac "z = za")
   apply (case_tac "\<not> disj_nres_map p_map")
    apply (simp add: well_typed_system_def)
    apply (simp add: well_typed_proc_set_def)
   apply (simp add: disj_nres_map_def)
   apply (erule_tac x="u" in allE)
   apply (erule_tac x="v" in allE)
   apply (auto)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="za" in allE)
   apply (simp add: nres_lookup_def)
    (* if za is in l, we have a contradiction by map separation. *)
  apply (case_tac "in_path za l")
   apply (simp add: well_typed_system_def)
   apply (auto)
   apply (erule_tac x="u" in allE)
   apply (auto)
   apply (cut_tac rs_map="rs_map" and z="za" and l="l" in lookup_in_path)
     apply (auto)
   apply (simp add: sep_nres_map_def)
   apply (erule_tac x="a" in allE)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="za" in allE)
   apply (auto)
    (* similarly, we can show z is not in la *)
  apply (case_tac "in_path z la")
   apply (simp add: well_typed_system_def)
   apply (auto)
   apply (erule_tac x="v" in allE)
   apply (auto)
   apply (cut_tac rs_map="rs_map" and z="z" and l="la" in lookup_in_path)
     apply (auto)
   apply (simp add: sep_nres_map_def)
   apply (erule_tac x="a" in allE)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="z" in allE)
   apply (auto)
    (* otherwise we should be able to find a, b, c where z \<leadsto> a \<leadsto> c \<leadsto> x and za \<leadsto> b \<leadsto> c \<leadsto> x*)
  apply (cut_tac rs_map="rs_map" and x="z" and y="za" and z="x" in path_lookup_cross)
       apply (auto)
    (* this is a contradiction by res map exclusion on the maps of a + b containing c *)
  apply (case_tac "\<not> disj_nres_map rs_map")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_state_def)
   apply (simp add: valid_nres_map_def)
  apply (simp add: disj_nres_map_def)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="b" in allE)
  apply (auto)
  apply (simp add: strong_disj_use_env_def)
  apply (erule_tac x="c" in allE)
  apply (auto)
  done

lemma well_typed_no_dom_use: "\<lbrakk> well_typed_state s env rs_map; p_set u = Some e; p_map u = Some r_s;
  well_typed env r_s e UnitTy r_se r_xe; x \<in> ref_vars e; proper_exp rs_map e \<rbrakk> \<Longrightarrow> full_dom_use_env env rs_map e x \<noteq> NoPerm"
    (* free_var case. in this case it is in the dominator since it is non-prim *)
  apply (case_tac "x \<in> free_vars e")
   apply (case_tac "env x = None")
    apply (cut_tac env="env" and x="x" and e="e" in well_typed_fv_env_use)
      apply (auto)
   apply (case_tac "x \<notin> non_prim_vars env e")
    apply (cut_tac s="s" and env="env" and rs_map="rs_map" in wts_mem_val_env)
     apply (simp)
    apply (simp add: mem_val_env_def)
    apply (erule_tac x="x" in allE)
    apply (auto)
    apply (simp add: non_prim_vars_def)
    apply (simp add: non_prim_entry_def)
    apply (case_tac y)
          apply (auto)
   apply (simp add: full_dom_use_env_def)
   apply (simp add: dom_use_env_def)
   apply (case_tac "\<exists> l z. z \<in> non_prim_vars env e \<and> path_lookup rs_map z l x")
    apply (auto)
   apply (erule_tac x="[]" in allE)
   apply (erule_tac x="x" in allE)
   apply (auto)
    (* otherwise, we presume that it has an owner with permissions in r_s. since e is proper, there is a lookup between them *)
  apply (cut_tac x="x" and e="e" in well_typed_deref_ex)
     apply (auto)
  apply (simp add: proper_exp_def)
  apply (erule_tac x="z" in allE)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (simp add: full_dom_use_env_def)
  apply (simp add: dom_use_env_def)
  apply (case_tac "\<exists> l z. z \<in> non_prim_vars env e \<and> path_lookup rs_map z l x")
   apply (auto)
  apply (erule_tac x="l" in allE)
  apply (erule_tac x="z" in allE)
  apply (auto)
  apply (cut_tac x="z" and y="x" and e="e" in well_typed_deref_npv_use)
    apply (auto)
  done

lemma excl_safe_lemma: "\<lbrakk> well_typed_system env rs_map p_map s p_set; p_set u = Some e; can_access e x;
  p_set v = Some e'; u \<noteq> v \<rbrakk> \<Longrightarrow> \<not> can_access e' x"
    (* prelim: p_map u + v has an entry *)
  apply (case_tac "p_map u = None \<or> p_map v = None")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_proc_set_def)
   apply (simp add: full_nres_map_def)
   apply (auto)
    apply (erule_tac x="u" in allE)
    apply (auto)
   apply (erule_tac x="v" in allE)
   apply (auto)
    (* prelim: e must be well-typed + proper *)
  apply (case_tac "\<not> (\<exists> r_s rx. well_typed env y e UnitTy r_s rx \<and> proper_exp rs_map e)")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
    apply (erule_tac x="u" in allE)
    apply (auto)
   apply (erule_tac x="u" in allE)
   apply (auto)
    (* prelim: e' is also well-typed + proper *)
  apply (case_tac "\<not> (\<exists> r_s rx. well_typed env ya e' UnitTy r_s rx \<and> proper_exp rs_map e')")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
    apply (erule_tac x="v" in allE)
    apply (auto)
   apply (erule_tac x="v" in allE)
   apply (auto)
    (* from here, we know that x is in the completion of y + ya *)
  apply (cut_tac env="env" and rs_map="rs_map" and e="e" and x="x" and r_s="y" and s="s" in well_typed_no_dom_use)
        apply (auto)
    apply (simp add: well_typed_system_def)
   apply (simp add: can_access_def)
  apply (cut_tac env="env" and rs_map="rs_map" and e="e'" and x="x" and r_s="ya" and s="s" in well_typed_no_dom_use)
        apply (auto)
    apply (simp add: well_typed_system_def)
   apply (simp add: can_access_def)
    (* this is a contradiction by dominator exlcusion *)
  apply (cut_tac env="env" and rs_map="rs_map" and e="e" and e'="e'" and u="u" and v="v" and p_map="p_map" and s="s" and
      p_set="p_set" in wts_excl_dom_use_env)
          apply (auto)
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  done

end