section {* What can Happen during a Contract Invocation *}

text {* This section defines a set of sequence of account states that can appeear during an
invocation of a countract.  The invocation can be a nested reentrancy, but we focus on one
invocation.  This means we do not look into details of further reentrancy, but just assume
that the inner reentrancy keeps the invariant of the contract.  Of course we need to prove
that the invariant holds for the code, but when we do that we can assume that the inner
nested calls keep the invariants (we can say we are doing mathematical induction on the depth
of reentrancy).  *}

theory RelationalSem

imports Main "./Evm"

begin

subsection {* Some Possible Changes on Our Account State *}

text {* The account state might change even when the account's code is not executing. *}

text {* During blocks, the account might gain balances because somebody mines
Ether for the account.  The balance might increase also while other contracts execute
because they might destroy themselves and send their balance to our account.
The following relation captures this possibility.
*}

text {* When a transaction finishes, if our contract is marked as killed, it is destroyed. *}

inductive account_state_natural_change :: "account_state \<Rightarrow> account_state \<Rightarrow> bool"
where
natural:
 "old_bal \<le> new_bal \<Longrightarrow>
  account_state_natural_change
   \<lparr> account_address = addr
   , account_storage = str
   , account_code = code
   , account_balance = old_bal
   , account_ongoing_calls = going
   , account_killed = killed
   \<rparr>
   \<lparr> account_address = addr
   , account_storage = str
   , account_code = code
   , account_balance = new_bal
   , account_ongoing_calls = going
   , account_killed = killed
   \<rparr>"
| cleaned: -- {* This happens only at the end of a transaction, but we don't know
              the transaction boundaries.
              So this can happen at any moment when there are no ongoing calls.  *}
  "account_state_natural_change
  \<lparr> account_address = addr
  , account_storage = str
  , account_code = code
  , account_balance = old_bal
  , account_ongoing_calls = []
  , account_killed = True
  \<rparr>
  (empty_account addr)"

declare account_state_natural_change.simps [simp]

text "When the execution comes back from an external call, the account state might have changed
arbitrariliy.  Our strategy is to assume that an invariant is kept here; and later prove that
the invariant actually holds."

inductive account_state_return_change :: "(account_state \<Rightarrow> bool) \<Rightarrow> account_state \<Rightarrow> account_state \<Rightarrow> bool"
where
account_return:
"invariant
 \<lparr> account_address = addr
 , account_storage = new_str
 , account_code = code
 , account_balance = new_bal
 , account_ongoing_calls = ongoing
 , account_killed = killed
 \<rparr>
 \<Longrightarrow>
 account_state_return_change invariant
 \<lparr> account_address = addr
 , account_storage = old_str
 , account_code = code
 , account_balance = old_bal
 , account_ongoing_calls = ongoing
 , account_killed = killed
 \<rparr>
 \<lparr> account_address = addr
 , account_storage = new_str
 , account_code = code
 , account_balance = new_bal
 , account_ongoing_calls = ongoing
 , account_killed = killed
 \<rparr>
 "

declare account_state_return_change.simps [simp]

text "Next we specify which program results might see a return."

fun returnable_result :: "program_result \<Rightarrow> bool"
where
  "returnable_result ProgramStepRunOut = False"
| "returnable_result (ProgramToWorld (ContractCall _) _ _ _) = True"
| "returnable_result (ProgramToWorld (ContractCreate _) _ _ _) = True"
| "returnable_result (ProgramToWorld ContractSuicide _ _ _) = False"
| "returnable_result (ProgramToWorld ContractFail _ _ _) = False"
  (* because we are not modeling nested calls here, the effect of the nested calls are modeled in
   * account_state_return_change *)
| "returnable_result (ProgramToWorld (ContractReturn _) _ _ _) = False"
| "returnable_result (ProgramInit _) = False"
| "returnable_result ProgramInvalid = False"
| "returnable_result ProgramAnnotationFailure = False"

subsection {* A Round of the Game *}

text {* Now we are ready to specify the worlds turn. *}

inductive world_turn :: "(account_state \<Rightarrow> bool) (* The invariant of our contract*)
                      \<Rightarrow> (account_state * program_result)
                         (* the account state before the world's move
                            and the last thing our account did *)
                      \<Rightarrow> (account_state * variable_env)
                         (* the account state after the world's move
                            and the variable environment from which our contract must start.
                          *)
                      \<Rightarrow> bool (* a boolean indicating if that is a possible world's move. *)"
where
  world_call: -- {* the world might call our contract. *}
  "
   build_venv_called old_state callargs next_venv \<Longrightarrow>
   world_turn I (old_state, ProgramInit callargs) (old_state, next_venv)"
| world_return: -- {* the world might return to our contract. *}
  "account_state_return_change I account_state_going_out account_state_back \<Longrightarrow>
   build_venv_returned account_state_back result new_v \<Longrightarrow>
   returnable_result program_r \<Longrightarrow>
   world_turn I (account_state_going_out, program_r)
                (account_state_pop_ongoing_call account_state_back, new_v)"
| world_fail: -- {* the world might fail from an account into our contract. *}
  "account_state_return_change I account_state_going_out account_state_back \<Longrightarrow>
   build_venv_failed account_state_back = Some new_v \<Longrightarrow>
   returnable_result result \<Longrightarrow>
   world_turn I (account_state_going_out, result)
                (account_state_pop_ongoing_call account_state_back, new_v)"

text {* As a reply, our contract might make a move, or report an annotation failure.*}

inductive contract_turn :: "(account_state * variable_env) \<Rightarrow> (account_state * program_result) \<Rightarrow> bool"
where
  contract_to_world:
  "build_cenv old_account = cenv \<Longrightarrow>
   program_sem old_venv cenv
      (program_length (cenv_program cenv)) steps
      = ProgramToWorld act st bal opt_v \<Longrightarrow> (* if the program behaves like this *)
   account_state_going_out (* and if the account state is updated like this*)
     = update_account_state old_account act st bal opt_v \<Longrightarrow>
   contract_turn (old_account, old_venv) (* the contract can change the account state like this. *)
      (account_state_going_out, ProgramToWorld act st bal opt_v)"
| contract_annotation_failure:
  "build_cenv old_account = cenv \<Longrightarrow>
   program_sem old_venv cenv
      (program_length (cenv_program cenv)) steps = ProgramAnnotationFailure \<Longrightarrow>
   contract_turn (old_account, old_venv) (old_account, ProgramAnnotationFailure)"

text {* When we combine the world's turn and the contract's turn, we get one round.
The round is a binary relation over a single set.
*}

inductive one_round :: "(account_state \<Rightarrow> bool) \<Rightarrow> (account_state * program_result) \<Rightarrow> (account_state * program_result) \<Rightarrow> bool"
where
round:
"world_turn I a b \<Longrightarrow> contract_turn b c \<Longrightarrow> one_round I a c"

subsection {* Repetitions of rounds *}

text {* So, we can repeat rounds and see where they bring us.  *}
text {* The definition is taken from the book Concrete Semantics, and then modified *}
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text {* The repetition of rounds is either zero-times or once and the repetition. *}
lemma star_case :
"star r a c \<Longrightarrow>
 (a = c \<or> (\<exists> b. r a b \<and> star r b c))"
apply(induction rule: star.induct; auto)
done

text {* The next lemma is purely for convenience.
Actually the rounds can go nowhere after this invocation fails.
*}
lemma no_entry_fail [dest!]:
"star (one_round I)
      (a, ProgramToWorld ContractFail st bal v_opt)
      (b, c) \<Longrightarrow> b = a \<and> c = ProgramToWorld ContractFail st bal v_opt"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: world_turn.simps)
done

text {* Similarly, the rounds can go nowhere after this invocation returns. *}
lemma no_entry_return [dest!]:
"star (one_round I)
      (a, ProgramToWorld (ContractReturn data) st bal v_opt)
      (b, c) \<Longrightarrow> b = a \<and> c = ProgramToWorld (ContractReturn data) st bal v_opt"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: world_turn.simps)
done

text {* Also similarly, the rounds can go nowhere after this invocation
causes our contract to destroy itself.
*}
lemma no_entry_suicide [dest!]:
"star (one_round I)
      (a, ProgramToWorld ContractSuicide st bal v_opt)
      (b, c) \<Longrightarrow> b = a \<and> c = ProgramToWorld ContractSuicide st bal v_opt"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: world_turn.simps)
done

text {* And then the rounds can go nowhere after an annotation failure. *}
lemma no_entry_annotation_failure [dest!]:
"star (one_round I)
      (a, ProgramAnnotationFailure)
      (b, c) \<Longrightarrow> b = a \<and> c = ProgramAnnotationFailure"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: world_turn.simps)
done

subsection {* How to State an Invariant *}

text {* For any invariant @{term I} over account states, now @{term "star (one_round I)"}
relation shows all possibilities during one invocation, assuming that the
invariant is kept during external calls\footnote{This assumption about deeper reentrancy should
be considered as an induction hypothesis.  There has to be a lemma actually perform
such induction.}.
The following template traverses the states and proves that the invariant is actually kept
after every possible round.  Also the template states that no annotation failures happen.
*}

definition no_assertion_failure_post :: "(account_state \<Rightarrow> bool) \<Rightarrow> (account_state \<times> program_result) \<Rightarrow> bool"
where
"no_assertion_failure_post I fin =
 (I (fst fin) \<and>
  snd fin \<noteq> ProgramAnnotationFailure)
"

definition no_assertion_failure :: "(account_state \<Rightarrow> bool) \<Rightarrow> bool"
where
"no_assertion_failure (I :: account_state \<Rightarrow> bool) ==
  (\<forall> addr str code bal ongoing killed callenv.
    I \<lparr> account_address = addr, account_storage = str, account_code = code,
        account_balance = bal, account_ongoing_calls = ongoing, account_killed = killed \<rparr> \<longrightarrow>
  (\<forall> fin. star (one_round I) (
    \<lparr> account_address = addr, account_storage = str, account_code = code,
      account_balance = bal, account_ongoing_calls = ongoing, account_killed = killed \<rparr>
  , ProgramInit callenv) fin \<longrightarrow>
  no_assertion_failure_post I fin
 ))"

subsection {* How to State a Pre-Post Condition Pair *}

text {* After proving a theorem of the above form, I might be interested in
a more specific case (if the caller is not this particular account, nothing should change).
For that purpose, here is another template statement.  This contains everything above plus
an assumption about the initial call, and a conclusion about the state after the invocation.
*}

definition pre_post_conditions ::
"(account_state \<Rightarrow> bool) \<Rightarrow> (account_state \<Rightarrow> call_env \<Rightarrow> bool) \<Rightarrow>
 (account_state \<Rightarrow> call_env \<Rightarrow> (account_state \<times> program_result) \<Rightarrow> bool) \<Rightarrow> bool"
where
"pre_post_conditions (I :: account_state \<Rightarrow> bool) (precondition :: account_state \<Rightarrow> call_env\<Rightarrow> bool)
(postcondition :: (account_state \<Rightarrow> call_env \<Rightarrow> (account_state \<times> program_result) \<Rightarrow> bool)) ==
  (\<forall> initial_account initial_call. I initial_account \<longrightarrow>
     precondition initial_account initial_call \<longrightarrow>
  (\<forall> fin. star (one_round I) (initial_account, ProgramInit initial_call) fin \<longrightarrow>
  snd fin \<noteq> ProgramAnnotationFailure \<and>
  (\<forall> fin_observed. account_state_natural_change (fst fin) fin_observed \<longrightarrow>
  I fin_observed \<and>
  postcondition initial_account initial_call (fin_observed, snd fin))))
"

end


(*  Title:       Isabelle Collections Library
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section {* \isaheader{Set Implementation by non-distinct Lists} *}
theory ListSetImpl_NotDist
imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  (*"../common/ListAdd"*)
begin
text_raw {*\label{thy:ListSetImpl_NotDist}*}

(*@impl Set
  @type 'a lsnd
  @abbrv lsnd
  Sets implemented by lists that may contain duplicate elements.
  Insertion is quick, but other operations are less performant than on
  lists with distinct elements.
*)

type_synonym
  'a lsnd = "'a list"

subsection "Definitions"

definition lsnd_\<alpha> :: "'a lsnd \<Rightarrow> 'a set" where "lsnd_\<alpha> == set"
abbreviation (input) lsnd_invar
  :: "'a lsnd \<Rightarrow> bool" where "lsnd_invar == (\<lambda>_. True)"
definition lsnd_empty :: "unit \<Rightarrow> 'a lsnd" where "lsnd_empty == (\<lambda>_::unit. [])"
definition lsnd_memb :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> bool" where "lsnd_memb x l == List.member l x"
definition lsnd_ins :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_ins x l == x#l"
definition lsnd_ins_dj :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_ins_dj x l == x#l"

definition lsnd_delete :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_delete x l == remove_rev x l"

definition lsnd_iteratei :: "'a lsnd \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lsnd_iteratei l = foldli (remdups l)"

definition lsnd_isEmpty :: "'a lsnd \<Rightarrow> bool" where "lsnd_isEmpty s == s=[]"

definition lsnd_union :: "'a lsnd \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd"
  where "lsnd_union s1 s2 == revg s1 s2"
definition lsnd_union_dj :: "'a lsnd \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd"
  where "lsnd_union_dj s1 s2 == revg s1 s2" -- "Union of disjoint sets"

definition lsnd_to_list :: "'a lsnd \<Rightarrow> 'a list" where "lsnd_to_list == remdups"
definition list_to_lsnd :: "'a list \<Rightarrow> 'a lsnd" where "list_to_lsnd == id"

subsection "Correctness"
lemmas lsnd_defs =
  lsnd_\<alpha>_def
  lsnd_empty_def
  lsnd_memb_def
  lsnd_ins_def
  lsnd_ins_dj_def
  lsnd_delete_def
  lsnd_iteratei_def
  lsnd_isEmpty_def
  lsnd_union_def
  lsnd_union_dj_def
  lsnd_to_list_def
  list_to_lsnd_def

lemma lsnd_empty_impl: "set_empty lsnd_\<alpha> lsnd_invar lsnd_empty"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_memb_impl: "set_memb lsnd_\<alpha> lsnd_invar lsnd_memb"
by (unfold_locales)(auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_impl: "set_ins lsnd_\<alpha> lsnd_invar lsnd_ins"
by (unfold_locales) (auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_dj_impl: "set_ins_dj lsnd_\<alpha> lsnd_invar lsnd_ins_dj"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_delete_impl: "set_delete lsnd_\<alpha> lsnd_invar lsnd_delete"
by (unfold_locales) (auto simp add: lsnd_delete_def lsnd_\<alpha>_def remove_rev_alt_def)

lemma lsnd_\<alpha>_finite[simp, intro!]: "finite (lsnd_\<alpha> l)"
  by (auto simp add: lsnd_defs)

lemma lsnd_is_finite_set: "finite_set lsnd_\<alpha> lsnd_invar"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_iteratei_impl: "poly_set_iteratei lsnd_\<alpha> lsnd_invar lsnd_iteratei"
proof
  fix l :: "'a list"
  show "finite (lsnd_\<alpha> l)"
    unfolding lsnd_\<alpha>_def by simp

  show "set_iterator (lsnd_iteratei l) (lsnd_\<alpha> l)"
    apply (rule set_iterator_I [of "remdups l"])
    apply (simp_all add: lsnd_\<alpha>_def lsnd_iteratei_def)
  done
qed

lemma lsnd_isEmpty_impl: "set_isEmpty lsnd_\<alpha> lsnd_invar lsnd_isEmpty"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_impl: "set_union lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_union"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_dj_impl: "set_union_dj lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_union_dj"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_to_list_impl: "set_to_list lsnd_\<alpha> lsnd_invar lsnd_to_list"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma list_to_lsnd_impl: "list_to_set lsnd_\<alpha> lsnd_invar list_to_lsnd"
by(unfold_locales)(auto simp add: lsnd_defs)

definition lsnd_basic_ops :: "('x,'x lsnd) set_basic_ops"
  where [icf_rec_def]: "lsnd_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = lsnd_\<alpha>,
    bset_op_invar = lsnd_invar,
    bset_op_empty = lsnd_empty,
    bset_op_memb = lsnd_memb,
    bset_op_ins = lsnd_ins,
    bset_op_ins_dj = lsnd_ins_dj,
    bset_op_delete = lsnd_delete,
    bset_op_list_it = lsnd_iteratei
  \<rparr>"

setup Locale_Code.open_block
interpretation lsnd_basic: StdBasicSet lsnd_basic_ops
  apply (rule StdBasicSet.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule lsnd_empty_impl lsnd_memb_impl lsnd_ins_impl lsnd_ins_dj_impl
    lsnd_delete_impl lsnd_iteratei_impl)+
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lsnd_ops \<equiv> lsnd_basic.dflt_ops \<lparr>
  set_op_isEmpty := lsnd_isEmpty,
  set_op_union := lsnd_union,
  set_op_union_dj := lsnd_union_dj,
  set_op_to_list := lsnd_to_list,
  set_op_from_list := list_to_lsnd
  \<rparr>"

setup Locale_Code.open_block
interpretation lsnd: StdSetDefs lsnd_ops .
interpretation lsnd: StdSet lsnd_ops
proof -
  interpret aux: StdSet lsnd_basic.dflt_ops
    by (rule lsnd_basic.dflt_ops_impl)

  show "StdSet lsnd_ops"
    unfolding lsnd_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf
      lsnd_isEmpty_impl lsnd_union_impl lsnd_union_dj_impl lsnd_to_list_impl
      list_to_lsnd_impl
    )
    done
qed
interpretation lsnd: StdSet_no_invar lsnd_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lsnd"*}

lemma pi_lsnd[proper_it]:
  "proper_it' lsnd_iteratei lsnd_iteratei"
  apply (rule proper_it'I)
  unfolding lsnd_iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_lsnd: proper_it_loc lsnd_iteratei lsnd_iteratei
  apply unfold_locales by (rule pi_lsnd)

definition test_codegen where "test_codegen \<equiv> (
  lsnd.empty,
  lsnd.memb,
  lsnd.ins,
  lsnd.delete,
  lsnd.list_it,
  lsnd.sng,
  lsnd.isEmpty,
  lsnd.isSng,
  lsnd.ball,
  lsnd.bex,
  lsnd.size,
  lsnd.size_abort,
  lsnd.union,
  lsnd.union_dj,
  lsnd.diff,
  lsnd.filter,
  lsnd.inter,
  lsnd.subset,
  lsnd.equal,
  lsnd.disjoint,
  lsnd.disjoint_witness,
  lsnd.sel,
  lsnd.to_list,
  lsnd.from_list
)"

export_code test_codegen in SML

end


header {* The abstract semantics is correct *}

theory AbsCFCorrect
  imports AbsCF ExCF "~~/src/Tools/Adhoc_Overloading"
begin

default_sort type

text {*
The intention of the abstract semantics is to safely approximate the real control flow. This means that every call recorded by the exact semantics must occur in the result provided by the abstract semantics, which in turn is allowed to predict more calls than actually done.
*}

subsection {* Abstraction functions *}

text {*
This relation is expressed by abstraction functions and approximation relations. For each of our data types, there is an abstraction function @{text "abs_<type>"}, mapping the a value from the exact setup to the corresponding value in the abstract view. The approximation relation then expresses the fact that one abstract value of such a type is safely approximated by another.

Because we need an abstraction function for contours, we extend the @{text contour} type class by the abstraction functions and two equations involving the @{text nb} and @{text \<binit>} symbols.
*}

class contour_a = contour +
  fixes abs_cnt :: "contour \<Rightarrow> 'a"
  assumes abs_cnt_nb[simp]: "abs_cnt (nb b lab) = \<anb> (abs_cnt b) lab"
     and abs_cnt_initial[simp]: "abs_cnt(\<binit>) = \<abinit>"

instantiation unit :: contour_a
begin
definition "abs_cnt _ = ()"
instance by default auto
end

text {*
It would be unwieldly to always write out @{text "abs_<type> x"}. We would rather like to write @{text "|x|"} if the type of @{text x} is known, as Shivers does it as well. Isabelle allows one to use the same syntax for different symbols. In that case, it generates more than one parse tree and picks the (hopefully unique) tree that typechecks.

Unfortunately, this does not work well in our case: There are eight @{text "abs_<type>"} functions and some expressions later have multiple occurrences of these, causing an exponential blow-up of combinations.

Therefore, we use a module by Christian Sternagel and Alexander Krauss for ad-hoc overloading, where the choice of the concrete function is done at parse time and immediately. This is used in the following to set up the the symbol @{text "|_|"} for the family of abstraction functions.
*}

consts abs :: "'a \<Rightarrow> 'b" ("|_|")

adhoc_overloading
  abs abs_cnt

definition abs_benv :: "benv \<Rightarrow> 'c::contour_a \<abenv>"
  where "abs_benv \<beta> = map_option abs_cnt \<circ> \<beta>"

adhoc_overloading
  abs abs_benv

primrec abs_closure :: "closure \<Rightarrow> 'c::contour_a \<aclosure>"
  where "abs_closure (l,\<beta>) = (l,|\<beta>| )"

adhoc_overloading
  abs abs_closure

primrec abs_d :: "d \<Rightarrow> 'c::contour_a \<ad>"
  where "abs_d (DI i) = {}"
      | "abs_d (DP p) = {PP p}"
      | "abs_d (DC cl) = {PC |cl|}"
      | "abs_d (Stop) = {AStop}"

adhoc_overloading
  abs abs_d

definition abs_venv :: "venv \<Rightarrow> 'c::contour_a \<avenv>"
  where "abs_venv ve = (\<lambda>(v,b_a). \<Union>{(case ve (v,b) of Some d \<Rightarrow> |d| | None \<Rightarrow> {}) | b. |b| = b_a })"

adhoc_overloading
  abs abs_venv

definition abs_ccache :: "ccache \<Rightarrow> 'c::contour_a \<accache>"
  where "abs_ccache cc = (\<Union>((c,\<beta>),d) \<in> cc . {((c,abs_benv \<beta>), p) | p . p\<in>abs_d d})"
(* equivalent, but I already have cont2cont for UNION
  where "abs_ccache cc = { ((c,abs_benv \<beta>),p) | c \<beta> p d . ((c,\<beta>),d) \<in> cc \<and> p \<in> abs_d d}" *)

adhoc_overloading
  abs abs_ccache

fun abs_fstate :: "fstate \<Rightarrow> 'c::contour_a \<afstate>"
  where "abs_fstate (d,ds,ve,b) = (the_elem |d|, map abs_d ds, |ve|, |b| )"

adhoc_overloading
  abs abs_fstate

fun abs_cstate :: "cstate \<Rightarrow> 'c::contour_a \<acstate>"
  where "abs_cstate (c,\<beta>,ve,b) = (c, |\<beta>|, |ve|, |b| )"

adhoc_overloading
  abs abs_cstate

subsection {* Lemmas about abstraction functions *}

text {*
Some results about the abstractions functions.
*}

lemma abs_benv_empty[simp]: "|empty| = empty"
unfolding abs_benv_def by simp

lemma abs_benv_upd[simp]: "|\<beta>(c\<mapsto>b)| = |\<beta>| (c \<mapsto> |b| )"
  unfolding abs_benv_def by simp

lemma the_elem_is_Proc:
  assumes "isProc cnt"
  shows "the_elem |cnt| \<in> |cnt|"
using assms by (cases cnt)auto

lemma abs_cache_singleton [simp]: "|{((c,\<beta>),d)}| = {((c, |\<beta>| ), p) |p. p \<in> |d|}"
  unfolding abs_ccache_def by simp

lemma abs_venv_empty[simp]: "|empty| = {}."
  apply (rule ext) by (auto simp add: abs_venv_def smap_empty_def)

subsection {* Approximation relation *}

text {*
The family of relations defined here capture the notion of safe approximation.
*}

consts approx :: "'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<lessapprox> _")

definition venv_approx :: "'c \<avenv> \<Rightarrow>'c \<avenv> \<Rightarrow> bool"
  where "venv_approx = smap_less"

adhoc_overloading
  approx venv_approx

definition ccache_approx :: "'c \<accache> \<Rightarrow>'c \<accache> \<Rightarrow> bool"
  where "ccache_approx = less_eq"

adhoc_overloading
  approx ccache_approx

definition d_approx :: "'c \<ad> \<Rightarrow>'c \<ad> \<Rightarrow> bool"
  where "d_approx = less_eq"

adhoc_overloading
  approx d_approx

definition ds_approx :: "'c \<ad> list \<Rightarrow>'c \<ad> list \<Rightarrow> bool"
  where "ds_approx = list_all2 d_approx"

adhoc_overloading
  approx ds_approx

inductive fstate_approx :: "'c \<afstate> \<Rightarrow>'c \<afstate> \<Rightarrow> bool"
  where "\<lbrakk> ve \<lessapprox> ve' ; ds \<lessapprox> ds' \<rbrakk>
         \<Longrightarrow> fstate_approx (proc,ds,ve,b) (proc,ds',ve',b)"

adhoc_overloading
  approx fstate_approx

inductive cstate_approx :: "'c \<acstate> \<Rightarrow>'c \<acstate> \<Rightarrow> bool"
  where "\<lbrakk> ve \<lessapprox> ve' \<rbrakk> \<Longrightarrow> cstate_approx (c,\<beta>,ve,b) (c,\<beta>,ve',b)"

adhoc_overloading
  approx cstate_approx

subsection {* Lemmas about the approximation relation *}

text {*
Most of the following lemmas reduce an approximation statement about larger structures, as they are occurring the semantics functions, to statements about the components.
*}

lemma venv_approx_trans[trans]:
  fixes ve1 ve2 ve3 :: "'c \<avenv>"
  shows "\<lbrakk> ve1 \<lessapprox> ve2; ve2 \<lessapprox> ve3 \<rbrakk> \<Longrightarrow> (ve1 \<lessapprox> ve3)"
  unfolding venv_approx_def by (rule smap_less_trans)

lemma abs_venv_union: "|ve1 ++ ve2| \<lessapprox> |ve1| \<union>. |ve2|"
  by (auto simp add: venv_approx_def smap_less_def abs_venv_def smap_union_def, split option.split_asm, auto)

lemma abs_venv_map_of_rev: "|map_of (rev l)| \<lessapprox> \<Union>. (map (\<lambda>(v,k). |[v \<mapsto> k]| ) l)"
proof (induct l)
  case Nil show ?case unfolding abs_venv_def by (auto simp: venv_approx_def smap_less_def ) next
  case (Cons a l)
    obtain v k where "a=(v,k)" by (rule prod.exhaust)
    hence "|map_of (rev (a#l))| \<lessapprox> ( |[v \<mapsto> k]| \<union>. |map_of (rev l)| ):: 'a \<avenv>"
      by (auto intro: abs_venv_union)
    also
    have "\<dots> \<lessapprox> |[v \<mapsto> k]| \<union>. (\<Union>. (map (\<lambda>(v,k). |[v  \<mapsto> k]| ) l))"
      by (auto intro!:smap_union_mono[OF smap_less_refl Cons[unfolded venv_approx_def]] simp:venv_approx_def)
    also
    have "\<dots> = \<Union>. ( |[v \<mapsto> k]| # map (\<lambda>(v,k). |[v \<mapsto> k]| ) l)"
      by (rule smap_Union_union)
    also
    have "\<dots> = \<Union>. (map (\<lambda>(v,k). |[v \<mapsto> k]| ) (a#l))"
      using `a = (v,k)`
      by auto
    finally
    show ?case .
qed

lemma abs_venv_map_of: "|map_of l| \<lessapprox> \<Union>. (map (\<lambda>(v,k). |[v \<mapsto> k]| ) l)"
  using abs_venv_map_of_rev[of "rev l"] by simp

lemma abs_venv_singleton: "|[(v,b) \<mapsto> d]| = {(v,|b| ) := |d|}."
  by (rule ext, auto simp add:abs_venv_def smap_singleton_def smap_empty_def)

lemma ccache_approx_empty[simp]:
  fixes x :: "'c \<accache>"
  shows "{} \<lessapprox> x"
  unfolding ccache_approx_def by simp

lemmas ccache_approx_trans[trans] = subset_trans[where 'a = "((label \<times> 'c \<abenv>) \<times> 'c \<aproc>)", folded ccache_approx_def]
lemmas Un_mono_approx = Un_mono[where 'a = "((label \<times> 'c \<abenv>) \<times> 'c \<aproc>)", folded ccache_approx_def]
lemmas Un_upper1_approx = Un_upper1[where 'a = "((label \<times> 'c \<abenv>) \<times> 'c \<aproc>)", folded ccache_approx_def]
lemmas Un_upper2_approx = Un_upper2[where 'a = "((label \<times> 'c \<abenv>) \<times> 'c \<aproc>)", folded ccache_approx_def]

lemma abs_ccache_union: "|c1 \<union> c2| \<lessapprox> |c1| \<union> |c2|"
  unfolding ccache_approx_def abs_ccache_def by auto

lemma d_approx_empty[simp]: "{} \<lessapprox> (d::'c \<ad>)"
  unfolding d_approx_def by simp

lemma ds_approx_empty[simp]: "[] \<lessapprox> []"
  unfolding ds_approx_def by simp

subsection {* Lemma 7 *}

text {*
Shivers' lemma 7 says that @{text \<aA>} safely approximates @{text \<A>}.
*}

lemma lemma7:
  assumes "|ve::venv| \<lessapprox> ve_a"
  shows "|\<A> f \<beta> ve| \<lessapprox> \<aA> f |\<beta>| ve_a"
proof(cases f)
case (R _ v)
  from assms have assm': "\<And>v b. case_option {} abs_d (ve (v,b)) \<lessapprox> ve_a (v,|b| )"
    by (auto simp add:d_approx_def abs_venv_def venv_approx_def smap_less_def elim!:allE)
  show ?thesis
    proof(cases "\<beta> (binder v)")
    case None thus ?thesis using R by auto next
    case (Some b)
      thus ?thesis using R assm'[of v b]
         by (auto simp add:abs_benv_def split:option.split)
  qed
qed (auto simp add:d_approx_def)

subsection {* Lemmas 8 and 9 *}

text {*
The main goal of this section is to show that @{text \<aF>} safely approximates @{text \<F>} and that @{text \<aC>} safely approximates @{text \<C>}. This has to be shown at once, as the functions are mutually recursive and requires a fixed point induction. To that end, we have to augment the set of continuity lemmas.
*}

lemma cont2cont_abs_ccache[cont2cont,simp]:
  assumes "cont f"
  shows "cont (\<lambda>x. abs_ccache(f x))"
unfolding abs_ccache_def
using assms
by (rule cont2cont)(rule cont_const)

text {*
Shivers proves these lemmas using parallel fixed point induction over the two fixed points (the one from the exact semantics and the one from the abstract semantics). But it is simpler and equivalent to just do induction over the exact semantics and keep the abstract semantics functions fixed, so this is what I am doing.
*}

lemma lemma89:
 fixes fstate_a :: "'c::contour_a \<afstate>" and cstate_a :: "'c::contour_a \<acstate>"
 shows "|fstate| \<lessapprox> fstate_a \<Longrightarrow> |\<F>\<cdot>(Discr fstate)| \<lessapprox> \<aF>\<cdot>(Discr fstate_a)"
   and "|cstate| \<lessapprox> cstate_a \<Longrightarrow> |\<C>\<cdot>(Discr cstate)| \<lessapprox> \<aC>\<cdot>(Discr cstate_a)"
proof(induct arbitrary: fstate fstate_a cstate cstate_a rule: evalF_evalC_induct)
case Admissibility show ?case
  unfolding ccache_approx_def
  by (intro adm_lemmas adm_subset adm_prod_split adm_not_conj adm_not_mem adm_single_valued cont2cont)
next
case Bottom {
  case 1 show ?case by simp next
  case 2 show ?case by simp next
}
next
case (Next evalF evalC) {
case 1
  obtain d ds ve b where fstate: "fstate = (d,ds,ve,b)"
    by (cases fstate, auto)
  moreover
  obtain proc ds_a ve_a b_a where fstate_a: "fstate_a = (proc,ds_a,ve_a,b_a)"
    by (cases fstate_a, auto)
  ultimately
  have abs_d: "the_elem |d| = proc"
   and abs_ds: "map abs_d ds \<lessapprox> ds_a"
   and abs_ve: "|ve| \<lessapprox> ve_a"
   and abs_b: "|b| = b_a"
  using 1 by (auto elim:fstate_approx.cases)

  from abs_ds have dslength: "length ds = length ds_a"
    by (auto simp add:ds_approx_def dest!:list_all2_lengthD)

  from fstate fstate_a abs_d abs_ds abs_ve abs_ds dslength
  show ?case
  proof(cases fstate rule:fstate_case, auto simp del:a_evalF.simps a_evalC.simps set_map)

  txt {* Case Lambda *}
  fix \<beta> and lab and vs:: "var list" and c
  assume ds_a_length: "length vs = length ds_a"

  have "|\<beta>(lab \<mapsto> b)| = |\<beta>| (lab \<mapsto> b_a)"
    unfolding below_fun_def using abs_b by simp
  moreover

  { have "|ve(map (\<lambda>v. (v, b)) vs [\<mapsto>] ds)|
          \<lessapprox> |ve| \<union>. |map_of (rev (zip (map (\<lambda>v. (v, b)) vs) ds))|"
      unfolding map_upds_def by (intro abs_venv_union)
    also
    have "\<dots> \<lessapprox> ve_a  \<union>. (\<Union>. (map (\<lambda>(v,k). |[v \<mapsto> k]| ) (zip (map (\<lambda>v. (v, b)) vs) ds)))"
      using abs_ve abs_venv_map_of_rev
      by (auto intro:smap_union_mono simp add:venv_approx_def)
    also
    have "\<dots> = ve_a \<union>. (\<Union>. (map (\<lambda>(v,y). |[(v,b) \<mapsto> y]| ) (zip vs ds)))"
      by (auto simp add: zip_map1 o_def split_def)
    also
    have "\<dots> \<lessapprox> ve_a \<union>. (\<Union>. (map (\<lambda>(v,y). {(v,b_a) := y}.) (zip vs ds_a)))"
    proof-
      from abs_b abs_ds
      have "list_all2 venv_approx (map (\<lambda>(v, y). |[(v, b) \<mapsto> y]| ) (zip vs ds))
                                  (map (\<lambda>(v, y). {(v,b_a) := y}.) (zip vs ds_a))"
        by (auto simp add: ds_approx_def d_approx_def venv_approx_def abs_venv_singleton list_all2_conv_all_nth intro:smap_singleton_mono list_all2I)
      thus ?thesis
        by (auto simp add:venv_approx_def intro: smap_union_mono[OF smap_less_refl smap_Union_mono])
    qed
    finally
    have "|ve(map (\<lambda>v. (v, b)) vs [\<mapsto>] ds)|
          \<lessapprox> ve_a \<union>. (\<Union>. (map (\<lambda>(v,y). {(v, b_a) := y}.) (zip vs ds_a)))".
  }
  ultimately
  have prem: "|(c, \<beta>(lab \<mapsto> b), ve(map (\<lambda>v. (v, b)) vs [\<mapsto>] ds), b)|
        \<lessapprox> (c,  |\<beta>|(lab \<mapsto> b_a), ve_a \<union>. (\<Union>.(map (\<lambda>(v, y). {(v, b_a) := y}.) (zip vs ds_a))), b_a)"
    using abs_b
    by(auto intro:cstate_approx.intros simp add: abs_cstate.simps)

  show "|evalC\<cdot>(Discr (c, \<beta>(lab \<mapsto> b), ve(map (\<lambda>v. (v, b)) vs [\<mapsto>] ds), b))|
        \<lessapprox> \<aF>\<cdot>(Discr (PC (Lambda lab vs c, |\<beta>| ), ds_a, ve_a, b_a))"
  using Next.hyps(2)[OF prem] ds_a_length
  by (subst a_evalF.simps, simp del:a_evalF.simps a_evalC.simps)

  next
  txt {* Case Plus *}
  fix lab a1 a2 cnt
  assume "isProc cnt"
  assume abs_ds': "[{}, {}, |cnt| ] \<lessapprox> ds_a"
  then obtain a1_a a2_a cnt_a where ds_a: "ds_a = [a1_a, a2_a, cnt_a]" and abs_cnt: "|cnt| \<lessapprox> cnt_a"
    unfolding ds_approx_def
    by (cases ds_a rule:list.exhaust[OF _ list.exhaust[OF _ list.exhaust, of _ _ "\<lambda>_ x. x"],  of _ _ "\<lambda>_ x. x"])
       (auto simp add:ds_approx_def)

  have new_elem: "|{((lab, [lab \<mapsto> b]), cnt)}| \<lessapprox> {((lab, [lab \<mapsto> b_a]), cont) |cont. cont \<in> cnt_a}"
    using abs_cnt and abs_b
    by (auto simp add:ccache_approx_def d_approx_def)

  have prem: "|(cnt, [DI (a1 + a2)], ve, nb b lab)| \<lessapprox>
              (the_elem |cnt|, [{}], ve_a, \<anb> b_a lab)"
    using abs_ve and abs_b
    by (auto intro:fstate_approx.intros simp add:ds_approx_def)

  have "|(evalF\<cdot>(Discr (cnt, [DI (a1 + a2)], ve, nb b lab)))|
       \<lessapprox> \<aF>\<cdot>(Discr (the_elem |cnt|, [{}], ve_a, \<anb> b_a lab))"
    by (rule Next.hyps(1)[OF prem])
  also have "\<dots> \<lessapprox> (\<Union>cnt\<in>cnt_a. \<aF>\<cdot>(Discr (cnt, [{}], ve_a, \<anb> b_a lab)))"
    using abs_cnt
    by (auto intro: the_elem_is_Proc[OF `isProc cnt`] simp del: a_evalF.simps simp add:ccache_approx_def d_approx_def)
  finally
  have old_elems: "|(evalF\<cdot>(Discr (cnt, [DI (a1 + a2)], ve, nb b lab)))|
       \<lessapprox> (\<Union>cnt\<in>cnt_a. \<aF>\<cdot>(Discr (cnt, [{}], ve_a, \<anb> b_a lab)))".

  have "|((evalF\<cdot>(Discr (cnt, [DI (a1 + a2)], ve, nb b lab)))
          \<union> {((lab, [lab \<mapsto> b]), cnt)})|
        \<lessapprox> |(evalF\<cdot>(Discr (cnt, [DI (a1 + a2)], ve, nb b lab)))|
          \<union> |{((lab, [lab \<mapsto> b]), cnt)}|"
    by (rule abs_ccache_union)
  also
  have "\<dots> \<lessapprox>
        (\<Union>cnt\<in>cnt_a. \<aF>\<cdot>(Discr (cnt, [{}], ve_a, \<anb> b_a lab)))
        \<union> {((lab, [lab \<mapsto> b_a]), cont) |cont. cont \<in> cnt_a}"
    by (rule Un_mono_approx[OF old_elems new_elem])
  finally
  show "|insert ((lab, [lab \<mapsto> b]), cnt)
                (evalF\<cdot>(Discr (cnt, [DI (a1 + a2)], ve, nb b lab)))|
        \<lessapprox> \<aF>\<cdot>(Discr (PP (prim.Plus lab), ds_a, ve_a, b_a))"
    using ds_a by (subst a_evalF.simps)(auto simp del:a_evalF.simps)
  next

  txt {* Case If (true branch) *}
  fix ct cf v cntt cntf
  assume "isProc cntt"
  assume "isProc cntf"
  assume abs_ds': "[{}, |cntt|, |cntf| ] \<lessapprox> ds_a"
  then obtain v_a cntt_a cntf_a where ds_a: "ds_a = [v_a, cntt_a, cntf_a]"
                              and abs_cntt: "|cntt| \<lessapprox> cntt_a"
                              and abs_cntf: "|cntf| \<lessapprox> cntf_a"
    by (cases ds_a rule:list.exhaust[OF _ list.exhaust[OF _ list.exhaust, of _ _ "\<lambda>_ x. x"],  of _ _ "\<lambda>_ x. x"])
       (auto simp add:ds_approx_def)

  let ?c = "ct::label" and ?cnt = cntt and ?cnt_a = cntt_a

  have new_elem: "|{((?c, [?c \<mapsto> b]), ?cnt)}| \<lessapprox> {((?c, [?c \<mapsto> b_a]), cont) |cont. cont \<in> ?cnt_a}"
    using abs_cntt and abs_cntf and abs_b
    by (auto simp add:ccache_approx_def d_approx_def)

  have prem: "|(?cnt, [], ve, nb b ?c)| \<lessapprox>
              (the_elem |?cnt|, [], ve_a, \<anb> b_a ?c)"
    using abs_ve and abs_b
    by (auto intro:fstate_approx.intros)

  have "|evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))|
       \<lessapprox> \<aF>\<cdot>(Discr (the_elem |?cnt|, [], ve_a, \<anb> b_a ?c))"
    by (rule Next.hyps(1)[OF prem])
  also have "\<dots> \<lessapprox> (\<Union>cnt\<in>?cnt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ?c)))"
    using abs_cntt and abs_cntf
    by (auto intro: the_elem_is_Proc[OF `isProc ?cnt`] simp del: a_evalF.simps simp add:ccache_approx_def d_approx_def)

  finally
  have old_elems: "|evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))|
       \<lessapprox> (\<Union>cnt\<in>?cnt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ?c)))".

  have "|evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))
          \<union> {((?c, [?c \<mapsto> b]), ?cnt)}|
        \<lessapprox> |evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))|
          \<union> |{((?c, [?c \<mapsto> b]), ?cnt)}|"
    by (rule abs_ccache_union)
  also
  have "\<dots> \<lessapprox>
        (\<Union>cnt\<in>?cnt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ?c)))
        \<union> {((?c, [?c \<mapsto> b_a]), cont) |cont. cont \<in> ?cnt_a}"
    by (rule Un_mono_approx[OF old_elems new_elem])
  also
  have "\<dots> \<lessapprox>
        ((\<Union>cnt\<in>cntt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ct)))
          \<union> {((ct, [ct \<mapsto> b_a]), cont) |cont. cont \<in> cntt_a})
      \<union> ((\<Union>cnt\<in>cntf_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a cf)))
          \<union> {((cf, [cf \<mapsto> b_a]), cont) |cont. cont \<in> cntf_a})"
    by (rule Un_upper1_approx|rule Un_upper2_approx)
  finally
  show "|insert ((?c, [?c \<mapsto> b]), ?cnt)
                (evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c)))| \<lessapprox>
          \<aF>\<cdot>(Discr (PP (prim.If ct cf), ds_a, ve_a, b_a))"
    using ds_a by (subst a_evalF.simps)(auto simp del:a_evalF.simps)
  next

  txt {* Case If (false branch). We use schematic variable to keep this similar to the true branch. *}
  fix ct cf v cntt cntf
  assume "isProc cntt"
  assume "isProc cntf"
  assume abs_ds': "[{}, |cntt|, |cntf| ] \<lessapprox> ds_a"
  then obtain v_a cntt_a cntf_a where ds_a: "ds_a = [v_a, cntt_a, cntf_a]"
                              and abs_cntt: "|cntt| \<lessapprox> cntt_a"
                              and abs_cntf: "|cntf| \<lessapprox> cntf_a"
    by (cases ds_a rule:list.exhaust[OF _ list.exhaust[OF _ list.exhaust, of _ _ "\<lambda>_ x. x"],  of _ _ "\<lambda>_ x. x"])
       (auto simp add:ds_approx_def)

  let ?c = "cf::label" and ?cnt = cntf and ?cnt_a = cntf_a

  have new_elem: "|{((?c, [?c \<mapsto> b]), ?cnt)}| \<lessapprox> {((?c, [?c \<mapsto> b_a]), cont) |cont. cont \<in> ?cnt_a}"
    using abs_cntt and abs_cntf and abs_b
    by (auto simp add:ccache_approx_def d_approx_def)

  have prem: "|(?cnt, [], ve, nb b ?c)| \<lessapprox>
              (the_elem |?cnt|, [], ve_a, \<anb> b_a ?c)"
    using abs_ve and abs_b
    by (auto intro:fstate_approx.intros)

  have "|evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))|
       \<lessapprox> \<aF>\<cdot>(Discr (the_elem |?cnt|, [], ve_a, \<anb> b_a ?c))"
    by (rule Next.hyps(1)[OF prem])
  also have "\<dots> \<lessapprox> (\<Union>cnt\<in>?cnt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ?c)))"
    using abs_cntt and abs_cntf
    by (auto intro: the_elem_is_Proc[OF `isProc ?cnt`] simp del: a_evalF.simps simp add:ccache_approx_def d_approx_def)

  finally
  have old_elems: "|evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))|
       \<lessapprox> (\<Union>cnt\<in>?cnt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ?c)))".

  have "|evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))
          \<union> {((?c, [?c \<mapsto> b]), ?cnt)}|
        \<lessapprox> |evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c))|
          \<union> |{((?c, [?c \<mapsto> b]), ?cnt)}|"
    by (rule abs_ccache_union)
  also
  have "\<dots> \<lessapprox>
        (\<Union>cnt\<in>?cnt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ?c)))
        \<union> {((?c, [?c \<mapsto> b_a]), cont) |cont. cont \<in> ?cnt_a}"
    by (rule Un_mono_approx[OF old_elems new_elem])
  also
  have "\<dots> \<lessapprox>
        ((\<Union>cnt\<in>cntt_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a ct)))
          \<union> {((ct, [ct \<mapsto> b_a]), cont) |cont. cont \<in> cntt_a})
      \<union> ((\<Union>cnt\<in>cntf_a. \<aF>\<cdot>(Discr (cnt, [], ve_a, \<anb> b_a cf)))
          \<union> {((cf, [cf \<mapsto> b_a]), cont) |cont. cont \<in> cntf_a})"
    by (rule Un_upper1_approx|rule Un_upper2_approx)
  finally
  show "|insert ((?c, [?c \<mapsto> b]), ?cnt)
                (evalF\<cdot>(Discr (?cnt, [], ve, nb b ?c)))| \<lessapprox>
          \<aF>\<cdot>(Discr (PP (prim.If ct cf), ds_a, ve_a, b_a))"
    using ds_a by (subst a_evalF.simps)(auto simp del:a_evalF.simps)
 qed
next
case 2
  obtain c \<beta> ve b where cstate: "cstate = (c,\<beta>,ve,b)"
    by (cases cstate, auto)
  moreover
  obtain c_a \<beta>_a ds_a ve_a b_a where cstate_a: "cstate_a = (c_a,\<beta>_a,ve_a,b_a)"
    by (cases cstate_a, auto)
  ultimately
  have abs_c: "c = c_a"
   and abs_\<beta>: "|\<beta>| = \<beta>_a"
   and abs_ve: "|ve| \<lessapprox> ve_a"
   and abs_b: "|b| = b_a"
  using 2 by (auto elim:cstate_approx.cases)

  from cstate cstate_a abs_c abs_\<beta> abs_b
  show ?case
  proof(cases c, auto simp add:HOL.Let_def simp del:a_evalF.simps a_evalC.simps set_map evalV.simps)

  txt {* Case App *}
  fix lab f vs
  let ?d = "\<A> f \<beta> ve"
  assume "isProc ?d"

  have "map (abs_d \<circ> (\<lambda>v. \<A> v \<beta> ve)) vs \<lessapprox> map (\<lambda>v. \<aA> v \<beta>_a ve_a) vs"
    using abs_\<beta> and lemma7[OF abs_ve, of _ \<beta>]
    by (auto intro!: list_all2I simp add:set_zip ds_approx_def)

  hence "|evalF\<cdot>(Discr (?d, map (\<lambda>v. \<A> v \<beta> ve) vs, ve, nb b lab))|
     \<lessapprox> \<aF>\<cdot>(Discr(the_elem |?d|, map (\<lambda>v. \<aA> v \<beta>_a ve_a) vs, ve_a, \<anb> |b| lab))"
    using abs_ve and abs_cnt_nb and abs_b
    by -(rule Next.hyps(1),auto intro:fstate_approx.intros)
  also have "\<dots> \<lessapprox> (\<Union>f'\<in>\<aA> f \<beta>_a ve_a.
              \<aF>\<cdot>(Discr(f', map (\<lambda>v. \<aA> v \<beta>_a ve_a) vs, ve_a, \<anb> |b| lab)))"
    using lemma7[OF abs_ve] the_elem_is_Proc[OF `isProc ?d`] abs_\<beta>
    by (auto simp del: a_evalF.simps simp add:d_approx_def ccache_approx_def)
  finally
  have old_elems: "
     |evalF\<cdot>(Discr (\<A> f \<beta> ve, map (\<lambda>v. \<A> v \<beta> ve) vs, ve, nb b lab))|
     \<lessapprox> (\<Union>f'\<in> \<aA> f \<beta>_a ve_a.
              \<aF>\<cdot>(Discr(f', map (\<lambda>v. \<aA> v \<beta>_a ve_a) vs, ve_a, \<anb> |b| lab)))"
    by auto

  have new_elem: "|{((lab, \<beta>), \<A> f \<beta> ve)}|
                  \<lessapprox> {((lab, \<beta>_a), f') |f'. f' \<in> \<aA> f \<beta>_a ve_a}"
    using abs_\<beta> and lemma7[OF abs_ve]
    by(auto simp add:ccache_approx_def d_approx_def)

  have "|evalF\<cdot>(Discr (\<A> f \<beta> ve, map (\<lambda>v. \<A> v \<beta> ve) vs, ve, nb b lab))
        \<union> {((lab, \<beta>), \<A> f \<beta> ve)}|
        \<lessapprox> |evalF\<cdot>(Discr (\<A> f \<beta> ve, map (\<lambda>v. \<A> v \<beta> ve) vs, ve, nb b lab))|
        \<union> |{((lab, \<beta>), \<A> f \<beta> ve)}|"
    by (rule abs_ccache_union)
  also have "\<dots>
        \<lessapprox> (\<Union>f'\<in>\<aA> f \<beta>_a ve_a.
              \<aF>\<cdot>(Discr(f', map (\<lambda>v. \<aA> v \<beta>_a ve_a) vs, ve_a, \<anb> |b| lab)))
        \<union> {((lab, \<beta>_a), f') |f'. f' \<in> \<aA> f \<beta>_a ve_a}"
    by (rule Un_mono_approx[OF old_elems new_elem])
  finally
  show "|insert ((lab, \<beta>), \<A> f \<beta> ve)
                (evalF\<cdot>(Discr (\<A> f \<beta> ve, map (\<lambda>v. \<A> v \<beta> ve) vs, ve, nb b lab)))|
        \<lessapprox> \<aC>\<cdot>(Discr (App lab f vs, |\<beta>|, ve_a, |b| ))"
    using abs_\<beta>
    by (subst a_evalC.simps)(auto simp add: HOL.Let_def simp del:a_evalF.simps)
  next

  txt {* Case Let *}
  fix lab binds c'

  have "|\<beta>(lab \<mapsto> nb b lab)| =
        \<beta>_a(lab \<mapsto> \<anb> |b| lab)"
    using abs_\<beta> and abs_b
    by simp
  moreover
  have "|map_of (map (\<lambda>(v, l). ((v, nb b lab),
                                 DC (l, \<beta>(lab \<mapsto> nb b lab))))
                     binds)|
    \<lessapprox> \<Union>. (map (\<lambda>(v, l).
              {(v, \<anb> |b| lab) :=  {PC (l, \<beta>_a(lab \<mapsto> \<anb> |b| lab))}}.)
              binds)"
    using abs_b and abs_\<beta>
    apply -
    apply (rule venv_approx_trans[OF abs_venv_map_of])
    apply (auto intro:smap_union_mono list_all2I
              simp add:venv_approx_def o_def set_zip abs_venv_singleton split_def smap_less_refl)
    done
  hence "|ve ++ map_of
            (map (\<lambda>(v, l).
                   ((v, nb b lab),
                    DC (l, \<beta>(lab \<mapsto> nb b lab))))
                  binds)| \<lessapprox>
        ve_a \<union>.
        (\<Union>.
          (map (\<lambda>(v, l).
            {(v, \<anb> |b| lab) :=  {PC (l, \<beta>_a(lab \<mapsto> \<anb> |b| lab))}}.)
            binds))"
    by (rule venv_approx_trans[OF abs_venv_union
      smap_union_mono[OF abs_ve[unfolded venv_approx_def], folded venv_approx_def]])
  ultimately
  have "|evalC\<cdot>(Discr(c', \<beta>(lab \<mapsto> nb b lab),
            ve ++ map_of
                  (map (\<lambda>(v, l). ((v, nb b lab), DC (l, \<beta>(lab \<mapsto> nb b lab)))) binds),
            nb b lab))|
    \<lessapprox> \<aC>\<cdot>(Discr (c', \<beta>_a(lab \<mapsto> \<anb> |b| lab),
            ve_a \<union>.
             (\<Union>. (map (\<lambda>(v, l).
                   {(v, \<anb> |b| lab) :=  {PC (l, \<beta>_a(lab \<mapsto> \<anb> |b| lab))}}.)
                   binds)),
         \<anb> |b| lab))"
    using abs_cnt_nb and abs_b
    by -(rule Next.hyps(2),auto intro: cstate_approx.intros)

  thus "|evalC\<cdot>(Discr (c', \<beta>(lab \<mapsto> nb b lab),
                      ve ++ map_of (map (\<lambda>(v, l).((v, nb b lab),\<A> (L l) (\<beta>(lab \<mapsto> nb b lab)) ve)) binds),
                      nb b lab))| \<lessapprox>
          \<aC>\<cdot>(Discr (call.Let lab binds c', |\<beta>|, ve_a, |b| ))"
    using abs_\<beta>
    by (subst a_evalC.simps)(auto simp add: HOL.Let_def simp del:a_evalC.simps)
  qed
}
qed

text {*
And finally, we lift this result to @{text \<aPR>} and @{text \<PR>}.
*}

lemma lemma6: "|\<PR> l| \<lessapprox> \<aPR> l"
  unfolding evalCPS_def evalCPS_a_def
  by (auto intro!:lemma89 fstate_approx.intros simp del:evalF.simps a_evalF.simps
      simp add: ds_approx_def d_approx_def venv_approx_def)
end