section \<open>Lifting theorems onto filters\<close>
theory Eventuallize
  imports Complex_Main
begin

text \<open>
  The following attribute and ML function lift a given theorem of the form
    \<^prop>\<open>\<forall>x. A x \<longrightarrow> B x \<longrightarrow> C x\<close>
  to
    \<^prop>\<open>eventually A F \<Longrightarrow> eventually B F \<Longrightarrow> eventually C F\<close> .
\<close>

ML \<open>
signature EVENTUALLIZE =
sig
val eventuallize : Proof.context -> thm -> int option -> thm
end

structure Eventuallize : EVENTUALLIZE =
struct

fun dest_All (Const (\<^const_name>\<open>HOL.All\<close>, _) $ Abs (x, T, t)) = (x, T, t)
  | dest_All (Const (\<^const_name>\<open>HOL.All\<close>, T) $ f) =
      ("x", T |> dest_funT |> fst |> dest_funT |> fst, f $ Bound 0)
  | dest_All t = raise TERM ("dest_All", [t])

fun strip_imp (\<^term>\<open>(\<longrightarrow>)\<close> $ a $ b) = apfst (cons a) (strip_imp b)
  | strip_imp t = ([], t)

fun eventuallize ctxt thm n =
  let
    fun err n = raise THM ("Invalid index in eventuallize: " ^ Int.toString n, 0, [thm])
    val n_max =
      thm |> Thm.concl_of |> HOLogic.dest_Trueprop |> dest_All |> #3 |> strip_imp |> fst |> length
    val _ = case n of NONE => () | SOME n =>
      if n >= 0 andalso n <= n_max then () else err n
    val n = case n of SOME n => n | NONE => n_max
    fun conv n =
      if n < 2 then Conv.all_conv else Conv.arg_conv (conv (n - 1)) then_conv
        Conv.rewr_conv @{thm eq_reflection[OF imp_conjL [symmetric]]}
    val conv = Conv.arg_conv (Conv.binder_conv (K (conv n)) ctxt)
    val thm' = Conv.fconv_rule conv thm
    fun go n = if n < 2 then @{thm _} else @{thm eventually_conj} OF [@{thm _}, go (n - 1)]
  in
    @{thm eventually_rev_mp[OF _ always_eventually]} OF [go n, thm']
  end

end
\<close>

attribute_setup eventuallized = \<open>
  Scan.lift (Scan.option Parse.nat) >>
    (fn n => fn (ctxt, thm) =>
      (NONE, SOME (Eventuallize.eventuallize (Context.proof_of ctxt) thm n)))
\<close>

end


section\<open>PTA Generalisation\<close>
text\<open>The problem with the simplistic heuristics of \<^cite>\<open>"foster2019"\<close> is that the performance of the
Inference technique is almost entirely dependent on the quality and applicability of the heuristics
provided to it. Producing high quality heuristics often requires some inside knowledge of the system
under inference. If the user has this knowledge already, they are unlikely to require automated
inference. Ideally, we would like something more generally applicable. This theory presents a more
abstract \emph{metaheuristic} which can be implemented with genetic programming.\<close>

theory PTA_Generalisation
  imports "../Inference" Same_Register Group_By
begin

hide_const I

datatype value_type = N | S

instantiation value_type :: linorder begin
fun less_value_type :: "value_type \<Rightarrow> value_type \<Rightarrow> bool" where
  "less_value_type N S = True" |
  "less_value_type _ _ = False"

definition less_eq_value_type :: "value_type \<Rightarrow> value_type \<Rightarrow> bool" where
 "less_eq_value_type v1 v2 \<equiv> (v1 < v2 \<or> v1 = v2)"

instance
  apply standard
  using less_eq_value_type_def less_value_type.elims(2) apply blast
     apply (simp add: less_eq_value_type_def)
    apply (metis less_eq_value_type_def value_type.exhaust)
  using less_eq_value_type_def less_value_type.elims(2) apply blast
  by (metis less_eq_value_type_def less_value_type.elims(3) value_type.simps(2))

end

\<comment> \<open>This is a very hacky way of making sure that things with differently typed outputs don't get
    lumped together.\<close>
fun typeSig :: "output_function \<Rightarrow> value_type" where
  "typeSig (L (value.Str _)) = S" |
  "typeSig _ = N"

definition same_structure :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "same_structure t1 t2 = (
    Label t1 = Label t2 \<and>
    Arity t1 = Arity t2 \<and>
    map typeSig (Outputs t1) = map typeSig (Outputs t2)
  )"

lemma same_structure_equiv:
  "Outputs t1 = [L (Num m)] \<Longrightarrow> Outputs t2 = [L (Num n)] \<Longrightarrow>
   same_structure t1 t2 = Transition.same_structure t1 t2"
  by (simp add: same_structure_def Transition.same_structure_def)

type_synonym transition_group = "(tids \<times> transition) list"

fun observe_all :: "iEFSM \<Rightarrow>  cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> transition_group" where
  "observe_all _ _ _ [] = []" |
  "observe_all e s r ((l, i, _)#es)  =
    (case random_member (i_possible_steps e s r l i)  of
      (Some (ids, s', t)) \<Rightarrow> (((ids, t)#(observe_all e s' (evaluate_updates t i r) es))) |
      _ \<Rightarrow> []
    )"

definition transition_groups_exec :: "iEFSM \<Rightarrow> trace \<Rightarrow> (nat \<times> tids \<times> transition) list list" where
  "transition_groups_exec e t = group_by (\<lambda>(_, _, t1) (_, _, t2). same_structure t1 t2) (enumerate 0 (observe_all e 0 <> t))"

type_synonym struct = "(label \<times> arity \<times> value_type list)"

text\<open>We need to take the list of transition groups and tag them with the last transition that was
taken which had a different structure.\<close>
fun tag :: "struct option \<Rightarrow> (nat \<times> tids \<times> transition) list list \<Rightarrow> (struct option \<times> struct \<times> (nat \<times> tids \<times> transition) list) list" where
  "tag _ [] = []" |
  "tag t (g#gs) = (
    let
      (_, _, head) = hd g;
      struct = (Label head, Arity head, map typeSig (Outputs head))
    in
    (t, struct, g)#(tag (Some struct) gs)
  )"

text\<open>We need to group transitions not just by their structure but also by their history - i.e. the
last transition which was taken which had a different structure. We need to order these groups by
their relative positions within the traces such that output and update functions can be inferred in
the correct order.\<close>
definition transition_groups :: "iEFSM \<Rightarrow> log \<Rightarrow> transition_group list" where
  "transition_groups e l = (
    let
      trace_groups = map (transition_groups_exec e) l;
      tagged = map (tag None) trace_groups;
      flat =  sort (fold (@) tagged []);
      group_fun = fold (\<lambda>(tag, s, gp) f. f((tag, s) $:= gp@(f$(tag, s)))) flat (K$ []);
      grouped = map (\<lambda>x. group_fun $ x) (finfun_to_list group_fun);
      inx_groups = map (\<lambda>gp. (Min (set (map fst gp)), map snd gp)) grouped
    in
      map snd (sort inx_groups)
  )"

text\<open>For a given trace group, log, and EFSM, we want to build the training set for that group. That
is, the set of inputs, registers, and expected outputs from those transitions. To do this, we must
walk the traces in the EFSM to obtain the register values.\<close>
fun trace_group_training_set :: "transition_group \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> (inputs \<times> registers \<times> value list) list \<Rightarrow> (inputs \<times> registers \<times> value list) list" where
  "trace_group_training_set _ _ _ _ [] train = train" |
  "trace_group_training_set gp e s r ((l, i, p)#t) train = (
    let
      (id, s', transition) = fthe_elem (i_possible_steps e s r l i)
    in
    if \<exists>(id', _) \<in> set gp. id' = id then
      trace_group_training_set gp e s' (evaluate_updates transition i r) t ((i, r, p)#train)
    else
      trace_group_training_set gp e s' (evaluate_updates transition i r) t train
  )"

definition make_training_set :: "iEFSM \<Rightarrow> log \<Rightarrow> transition_group \<Rightarrow> (inputs \<times> registers \<times> value list) list" where
  "make_training_set e l gp = fold (\<lambda>h a. trace_group_training_set gp e 0 <> h a) l []"

primrec replace_groups :: "transition_group list \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "replace_groups [] e = e" |
  "replace_groups (h#t) e = replace_groups t (fold (\<lambda>(id, t) acc. replace_transition acc id t) h e)"

lemma replace_groups_fold [code]:
  "replace_groups xs e = fold (\<lambda>h acc'. (fold (\<lambda>(id, t) acc. replace_transition acc id t) h acc')) xs e"
  by (induct xs arbitrary: e,  auto)

definition insert_updates :: "transition \<Rightarrow> update_function list \<Rightarrow> transition" where
  "insert_updates t u = (
    let
      \<comment> \<open>Want to filter out null updates of the form rn := rn. It doesn't affect anything but it  \<close>
      \<comment> \<open>does make things look cleaner                                                            \<close>
      necessary_updates = filter (\<lambda>(r, u). u \<noteq> V (R r)) u
    in
    t\<lparr>Updates := (filter (\<lambda>(r, _). r \<notin> set (map fst u)) (Updates t))@necessary_updates\<rparr>
  )"

fun add_groupwise_updates_trace :: "trace  \<Rightarrow> (tids \<times> update_function list) list \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> iEFSM" where
  "add_groupwise_updates_trace [] _ e _ _ = e" |
  "add_groupwise_updates_trace ((l, i, _)#trace) funs e s r = (
    let
      (id, s', t) = fthe_elem (i_possible_steps e s r l i);
      updated = evaluate_updates t i r;
      newUpdates = List.maps snd (filter (\<lambda>(tids, _). set id \<subseteq> set tids) funs);
      t' = insert_updates t newUpdates;
      updated' = apply_updates (Updates t') (join_ir i r) r;
      necessaryUpdates = filter (\<lambda>(r, _). updated $ r \<noteq> updated' $ r) newUpdates;
      t'' = insert_updates t necessaryUpdates;
      e' = replace_transition e id t''
    in
    add_groupwise_updates_trace trace funs e' s' updated'
  )"

primrec add_groupwise_updates :: "log  \<Rightarrow> (tids \<times> update_function list) list \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "add_groupwise_updates [] _ e = e" |
  "add_groupwise_updates (h#t) funs e = add_groupwise_updates t funs (add_groupwise_updates_trace h funs e 0 <>)"

lemma fold_add_groupwise_updates [code]:
  "add_groupwise_updates log funs e = fold (\<lambda>trace acc. add_groupwise_updates_trace trace funs acc 0 <>) log e"
  by (induct log arbitrary: e, auto)

\<comment> \<open>This will be replaced to calls to Z3 in the executable\<close>
definition get_regs :: "(vname \<Rightarrow>f String.literal) \<Rightarrow> inputs \<Rightarrow> vname aexp \<Rightarrow> value \<Rightarrow> registers" where
  "get_regs types inputs expression output = Eps (\<lambda>r. aval expression (join_ir inputs r) = Some output)"

declare get_regs_def [code del]
code_printing constant get_regs \<rightharpoonup> (Scala) "Dirties.getRegs"

type_synonym action_info = "(cfstate \<times> registers \<times> registers \<times> inputs \<times> tids \<times> transition)"
type_synonym run_info = "action_info list"
type_synonym targeted_run_info = "(registers \<times> action_info) list"

fun everything_walk :: "output_function \<Rightarrow> nat \<Rightarrow> (vname \<Rightarrow>f String.literal) \<Rightarrow> trace \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> transition_group \<Rightarrow> run_info" where
  "everything_walk _ _ _ [] _ _ _ _ = []" |
  "everything_walk f fi types ((label, inputs, outputs)#t) oPTA s regs gp  = (
    let (tid, s', ta) = fthe_elem (i_possible_steps oPTA s regs label inputs) in
     \<comment> \<open>Possible steps with a transition we need to modify\<close>
    if \<exists>(tid', _) \<in> set gp. tid = tid' then
      (s, regs, get_regs types inputs f (outputs!fi), inputs, tid, ta)#(everything_walk f fi types t oPTA s' (evaluate_updates ta inputs regs) gp)
    else
      let empty = <> in
      (s, regs, empty, inputs, tid, ta)#(everything_walk f fi types t oPTA s' (evaluate_updates ta inputs regs) gp)
  )"

definition everything_walk_log :: "output_function \<Rightarrow> nat \<Rightarrow> (vname \<Rightarrow>f String.literal) \<Rightarrow> log \<Rightarrow> iEFSM \<Rightarrow> transition_group \<Rightarrow> run_info list" where
  "everything_walk_log f fi types log e gp = map (\<lambda>t. everything_walk f fi types t e 0 <> gp) log"

fun target :: "registers \<Rightarrow> run_info \<Rightarrow> targeted_run_info" where
  "target _ [] = []" |
  "target tRegs ((s, oldregs, regs, inputs, tid, ta)#t) = (
    let newTarget = if finfun_to_list regs = [] then tRegs else regs in
    (tRegs, s, oldregs, regs, inputs, tid, ta)#target newTarget t
  )"

fun target_tail :: "registers \<Rightarrow> run_info \<Rightarrow> targeted_run_info \<Rightarrow> targeted_run_info" where
  "target_tail _ [] tt = rev tt" |
  "target_tail tRegs ((s, oldregs, regs, inputs, tid, ta)#t) tt = (
    let newTarget = if finfun_to_list regs = [] then tRegs else regs in
    target_tail newTarget t ((tRegs, s, oldregs, regs, inputs, tid, ta)#tt)
  )"

lemma target_tail: "(rev bs)@(target tRegs ts) = target_tail tRegs ts bs"
proof(induct ts arbitrary: bs tRegs)
  case (Cons a ts)
  then show ?case
    apply (cases a)
    apply simp
    apply standard
    by (metis (no_types, lifting) append_eq_append_conv2 rev.simps(2) rev_append rev_swap self_append_conv2)+
qed simp

definition "target_fold tRegs ts b = fst (fold (\<lambda>(s, oldregs, regs, inputs, tid, ta) (acc, tRegs).
let newTarget = if finfun_to_list regs = [] then tRegs else regs in
    (acc@[(tRegs, s, oldregs, regs, inputs, tid, ta)], newTarget)
) ts (rev b, tRegs))"

lemma target_tail_fold: "target_tail tRegs ts b = target_fold tRegs ts b"
proof(induct ts arbitrary: tRegs b)
  case Nil
  then show ?case
    by (simp add: target_fold_def)
next
  case (Cons a ts)
  then show ?case
    apply (cases a)
    by (simp add: target_fold_def)
qed

lemma target_fold [code]: "target tRegs ts = target_fold tRegs ts []"
  by (metis append_self_conv2 rev.simps(1) target_tail_fold target_tail)

\<comment> \<open>This will be replaced by symbolic regression in the executable\<close>
definition get_update :: "label \<Rightarrow> nat \<Rightarrow> value list \<Rightarrow> (inputs \<times> registers \<times> registers) list \<Rightarrow> vname aexp option" where
  "get_update _ reg values train = (let
    possible_funs = {a. \<forall>(i, r, r') \<in> set train. aval a (join_ir i r) = r' $ reg}
    in
    if possible_funs = {} then None else Some (Eps (\<lambda>x. x \<in> possible_funs))
  )"

declare get_update_def [code del]
code_printing constant get_update \<rightharpoonup> (Scala) "Dirties.getUpdate"

definition get_updates_opt :: "label \<Rightarrow> value list \<Rightarrow> (inputs \<times> registers \<times> registers) list \<Rightarrow> (nat \<times> vname aexp option) list" where
  "get_updates_opt l values train = (let
    updated_regs = fold List.union (map (finfun_to_list \<circ> snd \<circ> snd) train) [] in
    map (\<lambda>r.
      let targetValues = remdups (map (\<lambda>(_, _, regs). regs $ r) train) in
      if  (\<forall>(_, anteriorRegs, posteriorRegs) \<in> set train. anteriorRegs $ r = posteriorRegs $ r) then
        (r, Some (V (R r)))
      else if length targetValues = 1 \<and> (\<forall>(inputs, anteriorRegs, _) \<in> set train. finfun_to_list anteriorRegs = []) then
        case hd targetValues of Some v \<Rightarrow>
        (r, Some (L v))
      else
        (r, get_update l r values train)
    ) updated_regs
  )"

definition finfun_add :: "(('a::linorder) \<Rightarrow>f 'b) \<Rightarrow> ('a \<Rightarrow>f 'b) \<Rightarrow> ('a \<Rightarrow>f 'b)" where
  "finfun_add a b = fold (\<lambda>k f. f(k $:= b $ k)) (finfun_to_list b) a"

definition group_update :: "value list \<Rightarrow> targeted_run_info \<Rightarrow> (tids \<times> (nat \<times> vname aexp) list) option" where
  "group_update values l = (
    let
      (_, (_, _, _, _, _, t)) = hd l;
      targeted = filter (\<lambda>(regs, _). finfun_to_list regs \<noteq> []) l;
      maybe_updates = get_updates_opt (Label t) values (map (\<lambda>(tRegs, s, oldRegs, regs, inputs, tid, ta). (inputs, finfun_add oldRegs regs, tRegs)) targeted)
    in
    if \<exists>(_, f_opt) \<in> set maybe_updates. f_opt = None then
      None
    else
      Some (fold List.union (map (\<lambda>(tRegs, s, oldRegs, regs, inputs, tid, ta). tid) l) [], map (\<lambda>(r, f_o). (r, the f_o)) maybe_updates)
  )"

fun groupwise_put_updates :: "transition_group list \<Rightarrow> log \<Rightarrow> value list \<Rightarrow> run_info list \<Rightarrow> (nat \<times> (vname aexp \<times> vname \<Rightarrow>f String.literal)) \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "groupwise_put_updates [] _ _ _ _  e = e" |
  "groupwise_put_updates (gp#gps) log values walked (o_inx, (op, types)) e = (
    let
      targeted = map (\<lambda>x. filter (\<lambda>(_, _, _, _, _, id, tran). (id, tran) \<in> set gp) x) (map (\<lambda>w. rev (target <> (rev w))) walked);
      group = fold List.union targeted []
    in
    case group_update values group of
      None \<Rightarrow> groupwise_put_updates gps log values walked (o_inx, (op, types)) e |
      Some u \<Rightarrow> groupwise_put_updates gps log values walked (o_inx, (op, types)) (make_distinct (add_groupwise_updates log [u] e))
  )"

definition updates_for_output :: "log \<Rightarrow> value list \<Rightarrow> transition_group \<Rightarrow> nat \<Rightarrow> vname aexp \<Rightarrow> vname \<Rightarrow>f String.literal \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
"updates_for_output log values current o_inx op types e = (
  if AExp.enumerate_regs op = {} then e
  else
    let
      walked = everything_walk_log op o_inx types log e current;
      groups = transition_groups e log
    in
    groupwise_put_updates groups log values walked (o_inx, (op, types)) e
  )"

type_synonym output_types = "(vname aexp \<times> vname \<Rightarrow>f String.literal)"

fun put_updates :: "log \<Rightarrow> value list \<Rightarrow> transition_group \<Rightarrow> (nat \<times> output_types option) list \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "put_updates _ _ _ [] e = e" |
  "put_updates log values gp ((_, None)#ops) e = put_updates log values gp ops e" |
  "put_updates log values gp ((o_inx, Some (op, types))#ops) e = (
    let
      gp' = map (\<lambda>(id, t). (id, t\<lparr>Outputs := list_update (Outputs t) o_inx op\<rparr>)) gp;
      generalised_model = fold (\<lambda>(id, t) acc. replace_transition acc id t) gp' e;
      e' = updates_for_output log values gp o_inx op types generalised_model
    in
    if accepts_log (set log) (tm e') then
     put_updates log values gp' ops e'
    else
     put_updates log values gp ops e
  )"

fun unzip_3 :: "('a \<times> 'b \<times> 'c) list \<Rightarrow> ('a list \<times> 'b list \<times> 'c list)" where
  "unzip_3 [] = ([], [], [])" |
  "unzip_3 ((a, b, c)#l) = (
    let (as, bs, cs) = unzip_3 l in
    (a#as, b#bs, c#cs)
  )"

lemma unzip_3: "unzip_3 l = (map fst l, map (fst \<circ> snd) l, map (snd \<circ> snd) l)"
  by (induct l, auto)

fun unzip_3_tailrec_rev :: "('a \<times> 'b \<times> 'c) list \<Rightarrow> ('a list \<times> 'b list \<times> 'c list) \<Rightarrow> ('a list \<times> 'b list \<times> 'c list)" where
  "unzip_3_tailrec_rev [] (as, bs, cs) = (as, bs, cs)" |
  "unzip_3_tailrec_rev ((a, b, c)#t) (as, bs, cs) = unzip_3_tailrec_rev t (a#as, b#bs, c#cs)"

lemma unzip_3_tailrec_rev: "unzip_3_tailrec_rev l (as, bs, cs) = ((map_tailrec_rev fst l as), (map_tailrec_rev (fst \<circ> snd) l bs), (map_tailrec_rev (snd \<circ> snd) l cs))"
  by (induct l arbitrary: as bs cs, auto)

definition "unzip_3_tailrec l = (let (as, bs, cs) = unzip_3_tailrec_rev l ([],[],[]) in (rev as, rev bs, rev cs))"

lemma unzip_3_tailrec [code]: "unzip_3 l = unzip_3_tailrec l"
  apply (simp only: unzip_3_tailrec_def unzip_3_tailrec_rev)
  by (simp add: Let_def map_tailrec_rev unzip_3 map_eq_map_tailrec)

text\<open>We want to return an aexp which, when evaluated in the correct context accounts for the literal
input-output pairs within the training set. This will be replaced by symbolic regression in the
executable\<close>
definition get_output :: "label \<Rightarrow> nat \<Rightarrow> value list \<Rightarrow> (inputs \<times> registers \<times> value) list \<Rightarrow> (vname aexp \<times> (vname \<Rightarrow>f String.literal)) option" where
  "get_output _ maxReg values train = (let
    possible_funs = {a. \<forall>(i, r, p) \<in> set train. aval a (join_ir i r) = Some p}
    in
    if possible_funs = {} then None else Some (Eps (\<lambda>x. x \<in> possible_funs), (K$ STR ''int''))
  )"
declare get_output_def [code del]
code_printing constant get_output \<rightharpoonup> (Scala) "Dirties.getOutput"

definition get_outputs :: "label \<Rightarrow> nat \<Rightarrow> value list \<Rightarrow> inputs list \<Rightarrow> registers list \<Rightarrow> value list list \<Rightarrow> (vname aexp \<times> (vname \<Rightarrow>f String.literal)) option list" where
  "get_outputs l maxReg values I r outputs = map_tailrec (\<lambda>(maxReg, ps). get_output l maxReg values (zip I (zip r ps))) (enumerate maxReg (transpose outputs))"

definition enumerate_exec_values :: "trace \<Rightarrow> value list" where
  "enumerate_exec_values vs = fold (\<lambda>(_, i, p) I. List.union (List.union i p) I) vs []"

definition enumerate_log_values :: "log \<Rightarrow> value list" where
  "enumerate_log_values l = fold (\<lambda>e I. List.union (enumerate_exec_values e) I) l []"

(*This is where the types stuff originates*)
definition generalise_and_update :: "log \<Rightarrow> iEFSM \<Rightarrow> transition_group \<Rightarrow> iEFSM" where
  "generalise_and_update log e gp = (
    let
      label = Label (snd (hd gp));
      values = enumerate_log_values log;
      new_gp_ts = make_training_set e log gp;
      (I, R, P) = unzip_3 new_gp_ts;
      max_reg = max_reg_total e;
      outputs = get_outputs label max_reg values I R P
    in
      put_updates log values gp (enumerate 0 outputs) e
  )"

text \<open>Splitting structural groups up into subgroups by previous transition can cause different
subgroups to get different updates. We ideally want structural groups to have the same output and
update functions, as structural groups are likely to be instances of the same underlying behaviour.\<close>
definition standardise_group :: "iEFSM \<Rightarrow> log \<Rightarrow> transition_group \<Rightarrow> (iEFSM \<Rightarrow> log \<Rightarrow> transition_group \<Rightarrow> transition_group) \<Rightarrow> iEFSM" where
  "standardise_group e l gp s = (
    let
      standardised = s e l gp;
      e' = replace_transitions e standardised
    in
      if e' = e then e else
      if accepts_log (set l) (tm e') then e' else e
)"

primrec find_outputs :: "output_function list list \<Rightarrow> iEFSM \<Rightarrow> log \<Rightarrow> transition_group \<Rightarrow> output_function list option" where
  "find_outputs [] _ _ _ = None" |
  "find_outputs (h#t) e l g = (
    let
      outputs = fold (\<lambda>(tids, t) acc. replace_transition acc tids (t\<lparr>Outputs := h\<rparr>)) g e
    in
      if accepts_log (set l) (tm outputs) then
        Some h
      else
        find_outputs t e l g
  )"

primrec find_updates_outputs :: "update_function list list \<Rightarrow> output_function list list \<Rightarrow> iEFSM \<Rightarrow> log \<Rightarrow> transition_group \<Rightarrow> (output_function list \<times> update_function list) option" where
  "find_updates_outputs [] _ _ _ _ = None" |
  "find_updates_outputs (h#t) p e l g = (
    let
      updates = fold (\<lambda>(tids, t) acc. replace_transition acc tids (t\<lparr>Updates := h\<rparr>)) g e
    in
      case find_outputs p updates l (map (\<lambda>(id, t). (id,t\<lparr>Updates := h\<rparr>))  g) of
        Some pp \<Rightarrow> Some (pp, h) |
        None \<Rightarrow> find_updates_outputs t p e l g
  )"

definition updates_for :: "update_function list \<Rightarrow> update_function list list" where
  "updates_for U = (
    let uf = fold (\<lambda>(r, u) f. f(r $:= u#(f $ r))) U (K$ []) in
    map (\<lambda>r. map (\<lambda>u. (r, u)) (uf $ r)) (finfun_to_list uf)
  )"

definition standardise_group_outputs_updates :: "iEFSM \<Rightarrow> log \<Rightarrow> transition_group \<Rightarrow> transition_group" where
  "standardise_group_outputs_updates e l g = (
    let
      update_groups = product_lists (updates_for (remdups (List.maps (Updates \<circ> snd) g)));
      update_groups_subs = fold (List.union \<circ> subseqs) update_groups [];
      output_groups = product_lists (transpose (remdups (map (Outputs \<circ> snd) g)))
    in
    case find_updates_outputs update_groups_subs output_groups e l g of
      None \<Rightarrow> g |
      Some (p, u) \<Rightarrow> map (\<lambda>(id, t). (id, t\<lparr>Outputs := p, Updates := u\<rparr>)) g
  )"

fun find_first_use_of_trace :: "nat \<Rightarrow> trace \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> tids option" where
  "find_first_use_of_trace _ [] _ _ _ = None" |
  "find_first_use_of_trace rr ((l, i, _)#es) e s r = (
    let
      (id, s', t) = fthe_elem (i_possible_steps e s r l i)
    in
      if (\<exists>p \<in> set (Outputs t). aexp_constrains p (V (R rr))) then
        Some id
      else
        find_first_use_of_trace rr es e s' (evaluate_updates t i r)
  )"

definition find_first_uses_of :: "nat \<Rightarrow> log \<Rightarrow> iEFSM \<Rightarrow> tids list" where
  "find_first_uses_of r l e = List.maps (\<lambda>x. case x of None \<Rightarrow> [] | Some x \<Rightarrow> [x]) (map (\<lambda>t. find_first_use_of_trace r t e 0 <>) l)"

fun find_initialisation_of_trace :: "nat \<Rightarrow> trace \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> (tids \<times> transition) option" where
  "find_initialisation_of_trace _ [] _ _ _ = None" |
  "find_initialisation_of_trace r' ((l, i, _)#es) e s r = (
    let
      (tids, s', t) = fthe_elem (i_possible_steps e s r l i)
    in
    if (\<exists>(rr, u) \<in> set (Updates t). rr = r' \<and> is_lit u) then
      Some (tids, t)
    else
      find_initialisation_of_trace r' es e s' (evaluate_updates t i r)
  )"

primrec find_initialisation_of :: "nat \<Rightarrow> iEFSM \<Rightarrow> log \<Rightarrow> (tids \<times> transition) option list" where
  "find_initialisation_of _ _ [] = []" |
  "find_initialisation_of r e (h#t) = (
    case find_initialisation_of_trace r h e 0 <> of
      None \<Rightarrow> find_initialisation_of r e t |
      Some thing \<Rightarrow> Some thing#(find_initialisation_of r e t)
  )"

definition delay_initialisation_of :: "nat \<Rightarrow> log \<Rightarrow> iEFSM \<Rightarrow> tids list \<Rightarrow> iEFSM" where
  "delay_initialisation_of r l e tids = fold (\<lambda>x e. case x of
      None \<Rightarrow> e |
    Some (i_tids, t) \<Rightarrow>
      let
        origins = map (\<lambda>id. origin id e) tids;
        init_val = snd (hd (filter (\<lambda>(r', _). r = r') (Updates t)));
        e' = fimage (\<lambda>(id, (origin', dest), tr).
        \<comment> \<open>Add the initialisation update to incoming transitions\<close>
        if dest \<in> set origins then
          (id, (origin', dest), tr\<lparr>Updates := List.insert (r, init_val) (Updates tr)\<rparr>)
        \<comment> \<open>Strip the initialisation update from the original initialising transition\<close>
        else if id = i_tids then
          (id, (origin', dest), tr\<lparr>Updates := filter (\<lambda>(r', _). r \<noteq> r') (Updates tr)\<rparr>)
        else
          (id, (origin', dest), tr)
      ) e
      in
      \<comment> \<open>We don't want to update a register twice so just leave it\<close>
      if accepts_log (set l) (tm e') then
        e'
      else
        e
  ) (find_initialisation_of r e l) e"

fun groupwise_generalise_and_update :: "log \<Rightarrow> iEFSM \<Rightarrow> transition_group list \<Rightarrow> iEFSM" where
  "groupwise_generalise_and_update _ e [] = e" |
  "groupwise_generalise_and_update log e (gp#t) = (
        let
          e' = generalise_and_update log e gp;
          rep = snd (hd (gp));
          structural_group = fimage (\<lambda>(i, _, t). (i, t)) (ffilter (\<lambda>(_, _, t). same_structure rep t) e');
          delayed = fold (\<lambda>r acc. delay_initialisation_of r log acc (find_first_uses_of r log acc)) (sorted_list_of_set (all_regs e')) e';
          standardised = standardise_group delayed log (sorted_list_of_fset structural_group) standardise_group_outputs_updates;
          structural_group2 = fimage (\<lambda>(_, _, t). (Outputs t, Updates t)) (ffilter (\<lambda>(_, _, t).  Label rep = Label t \<and> Arity rep = Arity t \<and> length (Outputs rep) = length (Outputs t)) standardised)
        in
        \<comment> \<open>If we manage to standardise a structural group, we do not need to evolve outputs and
            updates for the other historical subgroups so can filter them out.\<close>
        if fis_singleton structural_group2 then
          groupwise_generalise_and_update log (merge_regs standardised (accepts_log (set log))) (filter (\<lambda>g. set g \<inter> fset structural_group = {}) t)
        else
          groupwise_generalise_and_update log (merge_regs standardised (accepts_log (set log))) t
  )"

definition drop_all_guards :: "iEFSM \<Rightarrow> iEFSM \<Rightarrow> log \<Rightarrow> update_modifier \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> iEFSM" where
"drop_all_guards e pta log m np = (let
      derestricted = fimage (\<lambda>(id, tf, tran). (id, tf, tran\<lparr>Guards := []\<rparr>)) e;
      nondeterministic_pairs = sorted_list_of_fset (np derestricted)
    in
    case resolve_nondeterminism {} nondeterministic_pairs pta derestricted m (accepts_log (set log)) np of
      (None, _) \<Rightarrow> pta |
      (Some resolved, _) \<Rightarrow> resolved
  )"

definition updated_regs :: "transition \<Rightarrow> nat set" where
  "updated_regs t = set (map fst (Updates t))"

definition fewer_updates :: "transition \<Rightarrow> transition fset \<Rightarrow> transition option" where
  "fewer_updates t tt = (
    let p = ffilter (\<lambda>t'. same_structure t t' \<and> Outputs t = Outputs t' \<and> updated_regs t' \<subset> updated_regs t) tt in
    if p = {||} then None else Some (snd (fMin (fimage (\<lambda>t. (length (Updates t), t)) p))))"

fun remove_spurious_updates_aux :: "iEFSM \<Rightarrow> transition_group \<Rightarrow> transition fset \<Rightarrow> log \<Rightarrow> iEFSM" where
  "remove_spurious_updates_aux e [] _ _ = e" |
  "remove_spurious_updates_aux e ((tid, t)#ts) tt l = (
    case fewer_updates t tt of
      None \<Rightarrow> remove_spurious_updates_aux e ts tt l |
      Some t' \<Rightarrow> (
        let e' = replace_transition e tid t' in
        if accepts_log (set l) (tm e') then
          remove_spurious_updates_aux e' ts tt l
        else
          remove_spurious_updates_aux e ts tt l
      )
  )"

(* This goes through and tries to remove spurious updates that get introduced during preprocessing *)
definition remove_spurious_updates :: "iEFSM \<Rightarrow> log \<Rightarrow> iEFSM" where
  "remove_spurious_updates e l = (
    let transitions = fimage (\<lambda>(tid, _, t). (tid, t)) e in
      remove_spurious_updates_aux e (sorted_list_of_fset transitions) (fimage snd transitions) l
  )"

definition derestrict :: "iEFSM \<Rightarrow> log \<Rightarrow> update_modifier \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> iEFSM" where
  "derestrict pta log m np = (
    let
      normalised = groupwise_generalise_and_update log pta (transition_groups pta log)
    in
      drop_all_guards normalised pta log m np
  )"

definition "drop_pta_guards pta log m np = drop_all_guards pta pta log m np"

end


section \<open> Idle and Active Relations \<close>

theory tcircus_idle
  imports tcircus_rel
begin

definition filter_idle :: "('s, 'e) taction \<Rightarrow> ('s, 'e) taction" ("idle'(_')") where
[upred_defs]: "filter_idle P = U(R1(P \<and> &tt \<in> tocks UNIV))"

definition filter_time :: "('s, 'e) taction \<Rightarrow> ('s, 'e) taction" ("time'(_')") where
[upred_defs]: "filter_time P = U(R1(\<exists> $st\<acute> \<bullet> \<exists> $pat\<acute> \<bullet> \<exists> $ref\<acute> \<bullet> P\<lbrakk>idleprefix(&tt)/&tt\<rbrakk>))"

definition filter_active :: "('s, 'e) taction \<Rightarrow> ('s, 'e) taction" ("active'(_')") where
[upred_defs]: "filter_active(P) = U(R1(\<exists> t e t'. P \<and> \<guillemotleft>t\<guillemotright> \<in> tocks UNIV \<and> &tt = \<guillemotleft>t @ (Evt e # t')\<guillemotright>))"

utp_const filter_idle filter_active

lemma idle_TRR [closure]: assumes "P is TRR" shows "idle(P) is TRR"
proof -
  have "TRR(idle(TRR(P))) = idle(TRR(P))" by rel_blast
  thus "idle(P) is TRR" by (metis Healthy_def assms)
qed

lemma active_TRR [closure]: assumes "P is TRR" shows "active(P) is TRR"
proof -
  have "TRR(active(TRR(P))) = active(TRR(P))" by rel_blast
  thus "active(P) is TRR" by (metis Healthy_def assms)
qed

lemma time_TRR [closure]: assumes "P is TRR" shows "time(P) is TRR"
proof -
  have "TRR(time(TRR(P))) = time(TRR(P))" by rel_blast
  thus "time(P) is TRR" by (metis Healthy_def assms)
qed

lemma
  assumes "P is TRR"
  shows "(P \<and> time(P)) is TIP"
  apply (simp add: Healthy_def)
  apply (trr_auto cls: assms)
  oops

lemma active_disj [rpred]: "active(P \<or> Q) = (active(P) \<or> active(Q))"
  by rel_auto

lemma idle_conj [rpred]: "idle(P \<and> Q) = (idle(P) \<and> idle(Q))"
  by (rel_auto)

lemma idle_disj [rpred]: "idle(P \<or> Q) = (idle(P) \<or> idle(Q))"
  by (rel_auto)

lemma idle_idem [rpred]: "idle(idle(P)) = idle(P)"
  by rel_auto

lemma idle_true': "idle(true) = U(R1(&tt \<in> tocks UNIV))"
  by rel_auto

lemma active_idem [rpred]: "active(active(P)) = active(P)"
  by rel_auto

lemma TRR_idle_or_active [rpred]:
  assumes "P is TRR"
  shows "(idle(P) \<or> active(P)) = P"
  by (trr_auto cls: assms)
     (metis hd_Cons_tl hd_activesuffix idle_active_decomp idleprefix_tocks rangeE tocks_Nil tocks_append)

lemma refine_eval_dest: "P \<sqsubseteq> Q \<Longrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>e s \<Longrightarrow> \<lbrakk>P\<rbrakk>\<^sub>e s"
  by (rel_auto)

lemma Healthy_after: "\<lbrakk> \<And> i. P i is H \<rbrakk> \<Longrightarrow> H \<circ> P = P"
  by (metis (mono_tags, lifting) Healthy_if fun.map_cong fun.map_id0 id_apply image_iff)

lemma idle_skip [rpred]: "idle(II\<^sub>t) = II\<^sub>t"
  by (rel_auto)

lemma idle_false [rpred]: "idle(false) = false"
  by (rel_auto)

lemma time_disj [rpred]: "time(P \<or> Q) = (time(P) \<or> time(Q))"
  by (rel_auto)

lemma TIP_has_time [rpred]:
  assumes "P is TRR" "P is TIP"
  shows "(P \<and> time(P)) = P"
  apply (trr_auto cls: assms)
  apply (drule refine_eval_dest[OF TIP_prop[OF assms(1) assms(2)]])
  apply (rel_blast)
  done

lemma TIP_time_active [rpred]:
  assumes "P is TRR" "P is TIP"
  shows "(active(P) \<and> time(P)) = active(P)"
  apply (trr_auto cls: assms)
  apply (drule refine_eval_dest[OF TIP_prop[OF assms(1) assms(2)]])
  apply (rel_blast)
  done

lemma TRF_time [closure]:
  "P is TRR \<Longrightarrow> time(P) is TRF"
  by (rule TRF_intro, simp add: closure unrest, simp_all add: filter_time_def unrest)

end


theory Failures_TickTock_Hiding

imports
  Failures_TickTock
begin
(*
lemma
  assumes "\<forall> P Q. (s2w (opS P Q)) = (opW (s2w P) (s2w Q))"
          "\<forall> P. s2w (w2s P) = P"
    shows "(w2s (opW P Q)) = (opS (w2s P) (w2s Q))"
proof -
  have "\<forall>P Q. (s2w (opS P Q)) = (opW (s2w P) (s2w Q))"
    using assms by auto
  then have "(s2w (opS (w2s P) (w2s Q))) = (opW (s2w (w2s P)) (s2w (w2s Q)))"
    by auto
  then have "(s2w (opS (w2s P) (w2s Q))) = (opW P Q)"
    using assms by auto
  then have "(w2s (s2w (opS (w2s P) (w2s Q)))) = (w2s (opW P Q))"
    by auto
  then have "(opS (w2s P) (w2s Q)) = (w2s (opW P Q))"
    using assms

  obtain p where p:"p = (w2s P)

  then have "\<forall> P Q. s2w (opS (w2s P) (w2s Q)) = (opW (s2w (w2s P)) (s2w (w2s Q)))"
    using *)

lemma ttproc2F_HideF_failures_subseteq_HidingTT:
  assumes TTwf_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
  shows "fst ((ttproc2F P) \<setminus>\<^sub>F HS) \<subseteq> fst (ttproc2F (P \<setminus>\<^sub>C (ttevt2F`HS)))"
  using assms unfolding ttproc2F_def HidingTT_def HideF_def
proof (auto)
  fix b s y
  assume assm1:"Some (s, b \<union> HS) = tt2F y"
  and    assm2:"y \<in> P"

  text \<open> To proceed with the proof we need to remove HS, and keep b.
         This exists in P so long as P is TT1, because it is a subset refusal. \<close>

  then obtain z2 where z2:"Some (s, b) = tt2F z2 \<and> z2 \<in> P"
    using assm1 assm2 apply auto
    using Some_tt2F_subset TT1_P TT1_def by blast
  then have Some_z2:"Some (s, b) = tt2F z2"
    by auto

  text \<open> Then we can pick any z, where filtering the trace based on Some(s,b)
         is equivalent to getting a failure via tt2F. \<close>

  then obtain z where z:"tt2F z = Some (filter (\<lambda>e. e \<notin> HS) s, b)"
    using Some_tt2F_exists_filter assm1 z2
    by metis

  text \<open> Then it is sufficient to induce over the original hide_trace rule for the
         following predicate that doesn't mention P at all. \<close>

  have "\<exists>z. z \<in> hide_trace (ttevt2F ` HS) y \<and> Some (filter (\<lambda>e. e \<notin> HS) s, b) = tt2F z"
    using assm1 z
  proof (induct "(ttevt2F `HS)" y arbitrary:b s z rule:hide_trace.induct)
    case 1
    then show ?case by auto
  next
    case (2 e xs) (* {t.  (Event e \<in> X \<and> t \<in> hide_trace X s)
                        \<or> (\<exists>s'. Event e \<notin> X \<and> s' \<in> hide_trace X s \<and> t = [Event e]\<^sub>E # s')} *)
    have "Some (s, b \<union> HS) = tt2F ([Event e]\<^sub>E # xs)"
      using 2 by auto
    then have tt2F_xs:"Some(tl s,b \<union> HS) = tt2F xs"
      by (simp add: Some_tt2F_event_tl)
    then have tt2T_tl_s:"tt2T xs = tl s"
       using Some_tt2F_imp_tt2T' by blast

    have "s = tt2T ([Event e]\<^sub>E # xs)"
      using "2.prems"(1) Some_tt2F_imp_tt2T' by blast

    then have "tt2T z = filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # xs))"
      using 2
      by (simp add: Some_tt2F_imp_tt2T')
    then have tt2T_z:"tt2T z = filter (\<lambda>e. e \<notin> HS) (evt e # tt2T xs)"
      by auto

    then show ?case using 2
      proof (cases "Event e \<in> (ttevt2F ` HS)")
        case True
        then have "evt e \<in> HS"
          apply auto
          by (metis evt.exhaust ttevent.distinct(3) ttevent.inject ttevt2F.simps(1) ttevt2F.simps(2))
        then have "tt2T z = filter (\<lambda>e. e \<notin> HS) (tt2T xs)"
          using tt2T_z by simp
        then have "tt2T z = filter (\<lambda>e. e \<notin> HS) (tl s)"
          using tt2T_tl_s by simp
        then have "\<exists>z. z \<in> hide_trace (ttevt2F ` HS) xs \<and> Some (filter (\<lambda>e. e \<notin> HS) s, b) = tt2F z"
          using 2 tt2F_xs
          using \<open>s = tt2T ([Event e]\<^sub>E # xs)\<close> \<open>tt2T z = filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # xs))\<close> by auto
        then show ?thesis
          by (simp add: True)
      next
        case False
        then have "evt e \<notin> HS"
          using image_iff by fastforce
        then have "tt2T z = (evt e # (filter (\<lambda>e. e \<notin> HS) (tt2T xs)))"
          by (simp add: tt2T_z)
        then have "tt2T (tl z) = (filter (\<lambda>e. e \<notin> HS) (tt2T xs))" and
                  hd_z:"hd z = [Event e]\<^sub>E"
          apply (simp add: tt2T_tl_evt)
          by (simp add: \<open>tt2T z = evt e # filter (\<lambda>e. e \<notin> HS) (tt2T xs)\<close> tt2T_hd_evt)
        then have "\<exists>z. z \<in> hide_trace (ttevt2F ` HS) xs \<and> Some (filter (\<lambda>e. e \<notin> HS) (tl s), b) = tt2F z"
          using 2 tt2F_xs tt2T_tl_s
          by (smt Some_tt2F_tail \<open>s = tt2T ([Event e]\<^sub>E # xs)\<close> \<open>tt2T z = evt e # filter (\<lambda>e. e \<notin> HS) (tt2T xs)\<close> \<open>tt2T z = filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # xs))\<close>)
        then have "\<exists>z. [Event e]\<^sub>E # z \<in> hide_trace (ttevt2F ` HS) ([Event e]\<^sub>E # xs) \<and> Some (filter (\<lambda>e. e \<notin> HS) s, b) = tt2F ([Event e]\<^sub>E # z)"
          using hd_z apply auto
          using False
          by (metis (mono_tags, lifting) \<open>s = tt2T ([Event e]\<^sub>E # xs)\<close> \<open>tt2T z = evt e # filter (\<lambda>e. e \<notin> HS) (tt2T xs)\<close> \<open>tt2T z = filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # xs))\<close> eq_fst_iff eq_snd_iff option.simps(5) tt2T_tl_s)
        then have "\<exists>z. z \<in> hide_trace (ttevt2F ` HS) ([Event e]\<^sub>E # xs) \<and> Some (filter (\<lambda>e. e \<notin> HS) s, b) = tt2F z"
          by (metis \<open>tt2T z = evt e # filter (\<lambda>e. e \<notin> HS) (tt2T xs)\<close> hd_z list.distinct(1) list.exhaust_sel tt2T.simps(3))
        then show ?thesis
          using hd_z by auto
      qed
  next
    case 3
    then show ?case by auto
  next
    case (4 Y s)
    then show ?case by auto
  next
    case (5 Y)
    then have "s = []"
      using Some_tt2F_imp_tt2T' tt2T.simps(5) by blast
    then obtain Z where Z:"z = [[Z]\<^sub>R] \<and> ttevt2F`b \<subseteq> Z"
      using 5 apply auto
      by (metis (no_types, lifting) image_Collect_subsetI old.prod.inject option.inject tt2F.simps(1) tt2F_some_exists)
  show ?case using 5
  proof (cases "(ttevt2F ` (b \<union> HS)) \<subseteq> Y")
      case True
      then show ?thesis using 5 Z
        apply auto
        by (rule_tac x="[[(ttevt2F`b)]\<^sub>R]" in exI, auto)
    next
      case False
      then show ?thesis using 5 Z
        by auto
    qed
  next
    case (6 t)
    then show ?case by auto
  next
    case (7 Y e t)
    then show ?case by auto
  next
    case (8 Y t)
    then show ?case by auto
  next
    case (9 Y Z t)
    then show ?case by auto
  next
    case (10 x t)
    then show ?case by auto
  qed

  then have "\<exists>z. Some (filter (\<lambda>e. e \<notin> HS) s, b) = tt2F z \<and> (\<exists>x. x = hide_trace (ttevt2F ` HS) y \<and> y \<in> P \<and> z \<in> x)"
    using assm2 assm1 z
    by blast
  then show "\<exists>y. Some (filter (\<lambda>e. e \<notin> HS) s, b) = tt2F y \<and> (\<exists>x. (\<exists>p. x = hide_trace (ttevt2F ` HS) p \<and> p \<in> P) \<and> y \<in> x)"
    by auto
qed

lemma ttproc2F_HidingTT_failures_subseteq_HideF:
  assumes TTwf_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
  shows "fst (ttproc2F (P \<setminus>\<^sub>C (ttevt2F`HS))) \<subseteq> fst ((ttproc2F P) \<setminus>\<^sub>F HS)"
  using assms unfolding ttproc2F_def HidingTT_def HideF_def
proof (auto)
  fix a b y p
  assume assm1:"Some (a, b) = tt2F y"
  and    assm2:"y \<in> hide_trace (ttevt2F ` HS) p"
  and    assm3:"p \<in> P"

  text \<open> Key to doing this proof without using p \<in> P is to use p
         and focus on showing that some prefix of it exists that
         satisfies the condition. \<close>

  have "\<exists>s. (\<exists>r. Some (s, b \<union> HS) = tt2F r \<and> r \<lesssim>\<^sub>C p) \<and> a = filter (\<lambda>e. e \<notin> HS) s"
    using assm1 assm2
  proof (induct "(ttevt2F ` HS)" p arbitrary:y a b rule:hide_trace.induct)
    case (1 X)
    then show ?case by auto
  next
    case (2 X e s)
    then show ?case
    proof (cases "Event X \<in> (ttevt2F ` HS)")
      case True
      then have evt_X:"evt X \<in> HS"
        by (metis (no_types, hide_lams) evt.exhaust imageE ttevent.inject ttevent.simps(5) ttevt2F.simps(1) ttevt2F.simps(2))
      then have "s \<in> hide_trace (ttevt2F ` HS) e"
        using 2 True by auto
      then have "\<exists>s. (\<exists>r.  Some (s, b \<union> HS) = tt2F r \<and> r \<lesssim>\<^sub>C e) \<and> a = filter (\<lambda>e. e \<notin> HS) s"
        using 2 by auto
      then have "\<exists>s. (\<exists>r. Some (evt X # s, b \<union> HS) = tt2F ([Event X]\<^sub>E # r) \<and> r \<lesssim>\<^sub>C e) \<and> a = filter (\<lambda>e. e \<notin> HS) (evt X # s)"
        using True evt_X apply auto
        by (metis (no_types, lifting) fst_conv option.simps(5) snd_conv)
      then show ?thesis
        using tt_prefix_subset.simps(3) by blast
    next
      case False
      then have "evt X \<notin> HS"
        using image_iff by fastforce
      then have tl_s:"(tl s) \<in> hide_trace (ttevt2F ` HS) e"
        using 2 False by auto

      then obtain ax where ax_bx:"Some (ax, b) = tt2F (tl s) \<and> evt X # ax = a"
        using "2.prems"(1) "2.prems"(2) False Some_tt2F_event_tl
        proof -
          assume a1: "\<And>ax. Some (ax, b) = tt2F (tl s) \<and> evt X # ax = a \<Longrightarrow> thesis"
          have "tt2T s = a"
            using "2.prems"(1) Some_tt2F_imp_tt2T' by blast
          then show ?thesis
            using a1 "2.prems"(1) "2.prems"(2) False Some_tt2F_event_tl by fastforce
        qed
      then have "\<exists>s. (\<exists>r. Some (s, b \<union> HS) = tt2F r \<and> r \<lesssim>\<^sub>C e) \<and> ax = filter (\<lambda>e. e \<notin> HS) s"
        using 2 tl_s by auto
      then have "\<exists>s. (\<exists>r. Some (s, b \<union> HS) = tt2F ([Event X]\<^sub>E # r) \<and> r \<lesssim>\<^sub>C e) \<and> (evt X # ax) = filter (\<lambda>e. e \<notin> HS) s"
        using 2 False
        by (smt \<open>evt X \<notin> HS\<close> filter.simps(2) fst_conv option.simps(5) snd_conv tt2F.simps(2))
      then show ?thesis using ax_bx
        using tt_prefix_subset.simps(3) by blast
    qed
  next
    case (3 X)
    then show ?case by auto
  next
    case (4 X Y s)
    have "Tock \<notin> (ttevt2F ` HS)"
      apply auto
      by (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))
    then have "tt2F s = None"
      using 4 by auto
    then show ?case
      using 4 by auto
  next
    case (5 X Y)
    then have "a = []"
      using 5 by auto
    then obtain Z where Z:"Y = [[Z]\<^sub>R] \<and> ttevt2F`(b) \<subseteq> Z" (* {t. \<exists> Z\<subseteq>Y. X \<subseteq> Y \<and> t = [[Z]\<^sub>R]} *)
      using 5 apply simp
      apply safe
      by auto
    then show ?case using 5
    proof (cases "(ttevt2F ` HS) \<subseteq> X")
      case True
      have "(ttevt2F ` (b \<union> HS)) \<subseteq> X"
        using 5 Z by auto
      have "Some (a, b) = tt2F [[Z]\<^sub>R] \<and> a = filter (\<lambda>e. e \<notin> HS) a"
        using 5 Z by auto
      then have "Some (a, (b \<union> HS)) = tt2F [[Z \<union> ttevt2F`HS]\<^sub>R] \<and> a = filter (\<lambda>e. e \<notin> HS) a"
       using 5 Z apply auto
       using Some_tt2F_set by fastforce
      then show ?thesis using 5 Z
        apply auto
        by (metis (no_types, lifting) \<open>Some (a, b \<union> HS) = tt2F [[Z \<union> ttevt2F ` HS]\<^sub>R] \<and> a = filter (\<lambda>e. e \<notin> HS) a\<close> sup.absorb_iff2 sup_assoc tt_prefix_subset.simps(2) tt_prefix_subset_refl)
    next
      case False
      then show ?thesis using 5 by auto
    qed
  next
    case (6 X t)
    then show ?case by auto
  next
    case (7 X Y e t)
    then show ?case by auto
  next
    case (8 X Y t)
    then show ?case by auto
  next
    case (9 X Y Z t)
    then show ?case by auto
  next
    case (10 X x t)
    then show ?case by auto
  qed

  then show "\<exists>s. (\<exists>y. Some (s, b \<union> HS) = tt2F y \<and> y \<in> P) \<and> a = filter (\<lambda>e. e \<notin> HS) s"
    using assm3 TT1_P TT1_def by blast
qed

lemma ttproc2F_HideF_traces_subseteq_HidingTT:
  assumes TTwf_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
  shows "snd ((ttproc2F P) \<setminus>\<^sub>F HS) \<subseteq> snd (ttproc2F (P \<setminus>\<^sub>C (ttevt2F`HS)))"
  using assms unfolding ttproc2F_def HidingTT_def HideF_def
proof(auto)
  fix y
  assume assm1:"y \<in> P"

  have "ttWF y"
    using TTwf_P TTwf_def assm1 by blast

  then have "\<exists>z r. filter (\<lambda>e. e \<notin> HS) (tt2T y) = tt2T z \<and> z \<in> hide_trace (ttevt2F ` HS) r \<and> r \<lesssim>\<^sub>C y"
  proof (induct "(ttevt2F `HS)" y rule:hide_trace.induct)
    case 1
    then show ?case
      by (rule_tac x="[]" in exI, auto)+
  next
    case (2 e s)
    then have hyp:"\<exists>z r. filter (\<lambda>e. e \<notin> HS) (tt2T s) = tt2T z \<and> z \<in> hide_trace (ttevt2F ` HS) r \<and> r \<lesssim>\<^sub>C s"
      by auto

    then show ?case
    proof (cases "Event e \<in> (ttevt2F ` HS)")
      case True
      then have "\<exists>z r. filter (\<lambda>e. e \<notin> HS) (tt2T s) = tt2T z \<and> z \<in> hide_trace (ttevt2F ` HS) ([Event e]\<^sub>E # r) \<and> [Event e]\<^sub>E # r \<lesssim>\<^sub>C [Event e]\<^sub>E # s"
        using hyp by auto
      then have "\<exists>z r. filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # s)) = tt2T z \<and> z \<in> hide_trace (ttevt2F ` HS) ([Event e]\<^sub>E # r) \<and> [Event e]\<^sub>E # r \<lesssim>\<^sub>C [Event e]\<^sub>E # s"
        using True
        by (smt evt.exhaust filter.simps(2) imageE tt2T.simps(2) ttevent.distinct(3) ttevt2F.simps(1) ttevt2F.simps(2))
      then show ?thesis using 2 by blast
    next
      case False
      then have "\<exists>z r. filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # s)) = tt2T ([Event e]\<^sub>E # z) \<and> ([Event e]\<^sub>E # z) \<in> hide_trace (ttevt2F ` HS) ([Event e]\<^sub>E # r) \<and> [Event e]\<^sub>E # r \<lesssim>\<^sub>C [Event e]\<^sub>E # s"
        using hyp apply auto
        by (simp add: rev_image_eqI)
      then show ?thesis by blast
    qed
  next
    case 3
    then show ?case
      apply auto
      apply (smt evt.exhaust hide_trace.simps(3) image_iff mem_Collect_eq tt2T.simps(1) tt_prefix_subset_refl ttevent.distinct(3) ttevt2F.simps(1))
      by (metis filter.simps(1) hide_trace.simps(1) lists.Nil lists_empty tt2T.simps(3) tt_prefix_subset.simps(1))

  next
    case (4 Y s)
    then show ?case
    proof (cases "Tock \<in> (ttevt2F ` HS)")
      case True
      then show ?thesis
        by (metis evt.exhaust image_iff ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))
    next
      case False
      then show ?thesis
        using 4 False apply auto
        apply (rule_tac x="[]" in exI, simp)
        by (rule_tac x="[]" in exI, simp)
    qed

  next
    case (5 Y)
    then show ?case
      by (rule_tac x="[]" in exI, simp)+
  next
    case (6 t)
    then show ?case by auto
  next
    case (7 Y e t)
    then show ?case by auto
  next
    case (8 Y t)
    then show ?case by auto
  next
    case (9 Y Z t)
    then show ?case by auto
  next
    case (10 x t)
    then show ?case by auto
  qed

  then show "\<exists>ya. filter (\<lambda>e. e \<notin> HS) (tt2T y) = tt2T ya \<and> (\<exists>x. (\<exists>p. x = hide_trace (ttevt2F ` HS) p \<and> p \<in> P) \<and> ya \<in> x)"
    using assm1
    using TT1_P TT1_def by blast
qed

lemma ttproc2F_HidingTT_traces_subseteq_HideF:
  assumes TTwf_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
  shows "snd (ttproc2F (P \<setminus>\<^sub>C (ttevt2F`HS))) \<subseteq> snd ((ttproc2F P) \<setminus>\<^sub>F HS)"
  using assms unfolding ttproc2F_def HidingTT_def HideF_def
proof (auto)
  fix y p
  assume assm1:"y \<in> hide_trace (ttevt2F ` HS) p"
    and  assm2:"p \<in> P"

  have "\<exists>r. tt2T y = filter (\<lambda>e. e \<notin> HS) (tt2T r) \<and> r \<lesssim>\<^sub>C p"
    using assm1
  proof (induct "(ttevt2F ` HS)" p arbitrary:y rule:hide_trace.induct)
    case 1
    then show ?case
      apply auto
      by (rule_tac x="[]" in exI, auto)+
  next
    case (2 e s)
    then show ?case
    proof (cases "Event e \<in> (ttevt2F ` HS)")
      case True
      then have evt_HS:"evt e \<in> HS"
        by (metis (no_types, hide_lams) evt.exhaust imageE ttevent.inject ttevent.simps(5) ttevt2F.simps(1) ttevt2F.simps(2))
      then have "y \<in> hide_trace (ttevt2F ` HS) s"
        using 2 True by auto

      then have "\<exists>r. tt2T y = filter (\<lambda>e. e \<notin> HS) (tt2T r) \<and> r \<lesssim>\<^sub>C s"
        using 2 by auto
      then have "\<exists>r. tt2T y = filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # r)) \<and> ([Event e]\<^sub>E # r) \<lesssim>\<^sub>C [Event e]\<^sub>E # s"
        by (simp add: evt_HS)
      then show ?thesis by blast
    next
      case False
      then have evt_no_HS:"evt e \<notin> HS"
        using image_iff by fastforce
      then have tl_s:"(tl y) \<in> hide_trace (ttevt2F ` HS) s"
        using 2 False by auto
      then have "\<exists>r. tt2T (tl y) = filter (\<lambda>e. e \<notin> HS) (tt2T r) \<and> r \<lesssim>\<^sub>C s"
        using 2 by auto
      then have "\<exists>r. tt2T ([Event e]\<^sub>E # (tl y)) = filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # r)) \<and> ([Event e]\<^sub>E # r) \<lesssim>\<^sub>C ([Event e]\<^sub>E # s)"
        by (simp add: evt_no_HS)
      then show ?thesis
      proof -
        have "y = [Event e]\<^sub>E # tl y"
          using "2.prems" False by auto
        then show ?thesis
          by (metis (full_types) \<open>\<exists>r. tt2T ([Event e]\<^sub>E # tl y) = filter (\<lambda>e. e \<notin> HS) (tt2T ([Event e]\<^sub>E # r)) \<and> [Event e]\<^sub>E # r \<lesssim>\<^sub>C [Event e]\<^sub>E # s\<close>)
      qed
    qed
  next
    case 3
    then show ?case
      by (smt filter.simps(1) filter.simps(2) hide_trace.simps(3) image_eqI mem_Collect_eq tt2T.simps(1) tt2T.simps(3) tt_prefix_subset.simps(1) tt_prefix_subset_refl ttevt2F.simps(2))
  next
    case (4 Y s)
    then show ?case
      apply auto
       apply (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))
      by (rule_tac x="[]" in exI, auto)
  next
    case (5 Y)
    then show ?case
      apply auto
      by (rule_tac x="[]" in exI, auto)
  next
    case (6 t)
    then show ?case by auto
  next
    case (7 Y e t)
    then show ?case by auto
  next
    case (8 Y t)
    then show ?case by auto
  next
    case (9 Y Z t)
    then show ?case by auto
  next
    case (10 x t)
    then show ?case by auto
  qed

  then show "\<exists>z. tt2T y = filter (\<lambda>e. e \<notin> HS) z \<and> (\<exists>y. z = tt2T y \<and> y \<in> P)"
    using TT1_P TT1_def assm2 by blast
qed

lemma ttproc2F_HidingTT_eq_HideF:
  assumes TTwf_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
  shows "ttproc2F (P \<setminus>\<^sub>C (ttevt2F`HS)) = (ttproc2F P) \<setminus>\<^sub>F HS"
  by (metis (no_types, lifting) HideF_def TT0_P TT1_P TTwf_P fst_conv snd_conv subset_antisym ttproc2F_HideF_failures_subseteq_HidingTT ttproc2F_HideF_traces_subseteq_HidingTT ttproc2F_HidingTT_failures_subseteq_HideF ttproc2F_HidingTT_traces_subseteq_HideF ttproc2F_def)

end


section \<open>Implementation of Heaps by Arrays\<close>
theory IICF_Impl_Heapmap
imports IICF_Abs_Heapmap "../IICF_Indexed_Array_List"
begin

(* TODO/FIXME: Division setup of the code generator is a mess.
  TODO: Why does [code_unfold] not work to rewrite "x div 2"?
*)
text \<open>Some setup to circumvent the really inefficient implementation
  of division in the code generator, which has to consider several
  cases for negative divisors and dividends. \<close>
definition [code_unfold]:
  "efficient_nat_div2 n
    \<equiv> nat_of_integer (fst (Code_Numeral.divmod_abs (integer_of_nat n) 2))"

lemma efficient_nat_div2[simp]: "efficient_nat_div2 n = n div 2"
  by (simp add: efficient_nat_div2_def nat_of_integer.rep_eq)

  type_synonym 'v hma = "nat list \<times> ('v list)"
  sepref_decl_intf 'v i_hma is "nat list \<times> (nat \<rightharpoonup> 'v)"

  locale hmstruct_impl = hmstruct prio for prio :: "'v::heap \<Rightarrow> 'p::linorder"
  begin
    lemma param_prio: "(prio,prio) \<in> Id \<rightarrow> Id" by simp
    lemmas [sepref_import_param] = param_prio
    sepref_register prio
  end

  context
    fixes maxsize :: nat
    fixes prio :: "'v::heap \<Rightarrow> 'p::linorder"
    notes [map_type_eqs] = map_type_eqI[Pure.of "TYPE((nat,'v) ahm)" "TYPE('v i_hma)"]
  begin

    interpretation hmstruct .
    interpretation hmstruct_impl .

    definition "hm_impl1_\<alpha> \<equiv> \<lambda>(pq,ml).
      (pq,\<lambda>k. if k\<in>set pq then Some (ml!k) else None)"

    definition "hm_impl1_invar \<equiv> \<lambda>(pq,ml).
        hmr_invar (hm_impl1_\<alpha> (pq,ml))
      \<and> set pq \<subseteq> {0..<maxsize}
      \<and> ((pq=[] \<and> ml=[]) \<or> (length ml = maxsize))"

    definition "hm_impl1_weak_invar \<equiv> \<lambda>(pq,ml).
        set pq \<subseteq> {0..<maxsize}
      \<and> ((pq=[] \<and> ml=[]) \<or> (length ml = maxsize))"

    definition "hm_impl1_rel \<equiv> br hm_impl1_\<alpha> hm_impl1_invar"
    definition "hm_weak_impl'_rel \<equiv> br hm_impl1_\<alpha> hm_impl1_weak_invar"

    lemmas hm_impl1_rel_defs =
      hm_impl1_rel_def hm_weak_impl'_rel_def hm_impl1_weak_invar_def hm_impl1_invar_def hm_impl1_\<alpha>_def in_br_conv

    lemma hm_impl_\<alpha>_fst_eq:
        "(x1, x2) = hm_impl1_\<alpha> (x1a, x2a) \<Longrightarrow> x1 = x1a"
      unfolding hm_impl1_\<alpha>_def by (auto split: if_split_asm)

    term hm_empty_op
    definition hm_empty_op' :: "'v hma nres"
      where "hm_empty_op' \<equiv> do {
        let pq = op_ial_empty_sz maxsize;
        let ml = op_list_empty;
        RETURN (pq,ml)
      }"

    lemma hm_empty_op'_refine: "(hm_empty_op', hm_empty_op) \<in> \<langle>hm_impl1_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_empty_op'_def hm_empty_op_def hm_impl1_rel_defs
      by (auto simp: in_br_conv)

    definition hm_length' :: "'v hma \<Rightarrow> nat" where "hm_length' \<equiv> \<lambda>(pq,ml). length pq"

    lemma hm_length'_refine: "(RETURN o hm_length',RETURN o hm_length) \<in> hm_impl1_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_length'_def hm_length_def hm_impl1_rel_defs
      by (auto)

    term hm_key_of_op
    definition "hm_key_of_op' \<equiv> \<lambda>(pq,ml) i. ASSERT (i>0) \<then> mop_list_get pq (i - 1)"
    lemma hm_key_of_op'_refine: "(hm_key_of_op', hm_key_of_op) \<in> hm_impl1_rel \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_key_of_op'_def hm_key_of_op_def hm_impl1_rel_defs
      by (auto)

    term hm_lookup
    definition "hm_lookup_op' \<equiv> \<lambda>(pq,ml) k. do {
      if (k<maxsize) then do {    \<comment> \<open>TODO: This check can be eliminated, but this will complicate refinement of keys in basic ops\<close>
        let c = op_list_contains k pq;
        if c then do {
          v \<leftarrow> mop_list_get ml k;
          RETURN (Some v)
        } else RETURN None
      } else RETURN None
    }"

    lemma hm_lookup_op'_refine: "(uncurry hm_lookup_op', uncurry (RETURN oo hm_lookup))
      \<in> (hm_impl1_rel \<times>\<^sub>r nat_rel) \<rightarrow>\<^sub>f \<langle>\<langle>Id\<rangle>option_rel\<rangle>nres_rel"
      apply (intro frefI nres_relI)
      unfolding hm_lookup_op_def hm_lookup_op'_def o_def uncurry_def
      apply refine_vcg
      apply (auto simp: hm_impl1_rel_defs heapmap_\<alpha>_def hmr_invar_def)
      done

    term hm_contains_key_op
    definition "hm_contains_key_op' \<equiv> \<lambda>k (pq,ml). do {
      if (k<maxsize) then do {    \<comment> \<open>TODO: This check can be eliminated, but this will complicate refinement of keys in basic ops\<close>
        RETURN (op_list_contains k pq)
      } else RETURN False
    }"

    lemma hm_contains_key_op'_refine: "(uncurry hm_contains_key_op', uncurry hm_contains_key_op)
      \<in> (nat_rel \<times>\<^sub>r hm_impl1_rel) \<rightarrow>\<^sub>f \<langle>bool_rel\<rangle>nres_rel"
      apply (intro frefI nres_relI)
      unfolding hm_contains_key_op_def hm_contains_key_op'_def o_def uncurry_def PR_CONST_def
      apply refine_vcg
      apply (auto simp: hm_impl1_rel_defs heapmap_\<alpha>_def hmr_invar_def)
      done

    term hm_valid

    definition "hm_exch_op' \<equiv> \<lambda>(pq,ml) i j. do {
      ASSERT (hm_valid (hm_impl1_\<alpha> (pq,ml)) i);
      ASSERT (hm_valid (hm_impl1_\<alpha> (pq,ml)) j);
      pq \<leftarrow> mop_list_swap pq (i - 1) (j - 1);
      RETURN (pq,ml)
    }"

    lemma hm_impl1_relI:
      assumes "hmr_invar b"
      assumes "(a,b)\<in>hm_weak_impl'_rel"
      shows "(a,b)\<in>hm_impl1_rel"
      using assms
      unfolding hmr_rel_def hm_impl1_rel_def hm_weak_impl'_rel_def in_br_conv
        hm_impl1_weak_invar_def hm_impl1_invar_def
      by auto

    lemma hm_impl1_nres_relI:
      assumes "b \<le>\<^sub>n SPEC hmr_invar"
      assumes "(a,b)\<in>\<langle>hm_weak_impl'_rel\<rangle>nres_rel"
      shows "(a,b)\<in>\<langle>hm_impl1_rel\<rangle>nres_rel"
      using assms hm_impl1_relI
      apply (auto simp: pw_le_iff pw_leof_iff refine_pw_simps in_br_conv nres_rel_def)
      apply blast
      done

    lemma hm_exch_op'_refine: "(hm_exch_op', hm_exch_op) \<in> hm_impl1_rel \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hm_impl1_rel\<rangle>nres_rel"
      apply (intro fun_relI hm_impl1_nres_relI[OF hm_exch_op_invar])
      unfolding hm_exch_op'_def hm_exch_op_def
      apply (auto simp: pw_le_iff refine_pw_simps nres_rel_def
          hm_impl1_rel_def in_br_conv split: prod.splits)
      apply (auto simp: hm_impl1_\<alpha>_def)
      unfolding hm_impl1_rel_defs
      apply auto
      done

    term hm_index_op

    definition "hm_index_op' \<equiv> \<lambda>(pq,ml) k.
      do {
        ASSERT (hm_impl1_invar (pq,ml) \<and> heapmap_\<alpha> (hm_impl1_\<alpha> (pq,ml)) k \<noteq> None \<and> k\<in>set pq);
        i \<leftarrow> mop_list_index pq k;
        RETURN (i+1)
      }"
    lemma hm_index_op'_refine: "(hm_index_op',hm_index_op)
      \<in> hm_impl1_rel \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_index_op'_def hm_index_op_def hm_impl1_rel_defs
      apply (auto simp: pw_le_iff refine_pw_simps heapmap_\<alpha>_def split: if_split_asm)
      done

    definition hm_update_op' where
      "hm_update_op' \<equiv> \<lambda>(pq,ml) i v. do {
        ASSERT (hm_valid (hm_impl1_\<alpha> (pq,ml)) i \<and> hm_impl1_invar (pq,ml));
        k \<leftarrow> mop_list_get pq (i - 1);
        ml \<leftarrow> mop_list_set ml k v;
        RETURN (pq, ml)
      }"
    lemma hm_update_op'_refine: "(hm_update_op', hm_update_op) \<in> hm_impl1_rel \<rightarrow> nat_rel \<rightarrow> Id \<rightarrow> \<langle>hm_impl1_rel\<rangle>nres_rel"
      apply (intro fun_relI hm_impl1_nres_relI[OF hm_update_op_invar])
      unfolding hm_update_op'_def hm_update_op_def
      apply (auto simp: pw_le_iff refine_pw_simps nres_rel_def
          hm_impl1_rel_def in_br_conv split: prod.splits)
      apply (auto simp: hm_impl1_\<alpha>_def)
      unfolding hm_impl1_rel_defs
      apply (auto simp: subset_code(1))
      done

    term hm_butlast_op

    lemma hm_butlast_op_invar: "hm_butlast_op hm \<le>\<^sub>n SPEC hmr_invar"
      unfolding hm_butlast_op_def h.butlast_op_def
      apply refine_vcg
      apply (clarsimp_all simp: hmr_rel_defs map_butlast distinct_butlast)
      apply safe

      apply (auto simp: in_set_conv_nth nth_butlast) []
      apply (metis Suc_pred len_greater_imp_nonempty length_greater_0_conv less_antisym)

      apply (auto dest: in_set_butlastD) []

      apply (metis One_nat_def append_butlast_last_id distinct_butlast last_conv_nth not_distinct_conv_prefix)
      done

    definition hm_butlast_op' where
      "hm_butlast_op' \<equiv> \<lambda>(pq,ml). do {
        ASSERT (hmr_invar (hm_impl1_\<alpha> (pq,ml)));
        pq \<leftarrow> mop_list_butlast pq;
        RETURN (pq,ml)
      }"

    lemma set_butlast_distinct_conv:
      "\<lbrakk>distinct l\<rbrakk> \<Longrightarrow> set (butlast l) = set l - {last l}"
      by (cases l rule: rev_cases; auto)

    lemma hm_butlast_op'_refine: "(hm_butlast_op', hm_butlast_op) \<in> hm_impl1_rel \<rightarrow> \<langle>hm_impl1_rel\<rangle>nres_rel"
      apply (intro fun_relI hm_impl1_nres_relI[OF hm_butlast_op_invar])
      unfolding hm_butlast_op'_def hm_butlast_op_def
      apply (auto simp: pw_le_iff refine_pw_simps nres_rel_def
          hm_impl1_rel_def in_br_conv split: prod.splits)
      apply (auto simp: hm_impl1_\<alpha>_def)
      unfolding hm_impl1_rel_defs
      apply (auto simp: restrict_map_def) []

      defer

      apply (auto dest: in_set_butlastD) []
      apply (auto intro!: ext
        simp: hmr_invar_def set_butlast_distinct_conv last_conv_nth
        dest: in_set_butlastD) []
      done

    definition hm_append_op'
      where "hm_append_op' \<equiv> \<lambda>(pq,ml) k v. do {
        ASSERT (k \<notin> set pq \<and> k<maxsize);
        ASSERT (hm_impl1_invar (pq,ml));
        pq \<leftarrow> mop_list_append pq k;
        ml \<leftarrow> (if length ml = 0 then mop_list_replicate maxsize v else RETURN ml);
        ml \<leftarrow> mop_list_set ml k v;
        RETURN (pq,ml)
      }"

    lemma hm_append_op'_refine: "(uncurry2 hm_append_op', uncurry2 hm_append_op)
      \<in> [\<lambda>((hm,k),v). k<maxsize]\<^sub>f (hm_impl1_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r Id \<rightarrow> \<langle>hm_impl1_rel\<rangle>nres_rel"
      apply (intro frefI hm_impl1_nres_relI[OF hm_append_op_invar])
      unfolding hm_append_op'_def hm_append_op_def
      apply (auto simp: pw_le_iff refine_pw_simps nres_rel_def
          hm_impl1_rel_def in_br_conv split: prod.splits)
      unfolding hm_impl1_rel_defs
      apply (auto simp: restrict_map_def hmr_invar_def split: prod.splits if_split_asm)
      done

    definition "hm_impl2_rel \<equiv> prod_assn (ial_assn maxsize id_assn) (array_assn id_assn)"
    definition "hm_impl_rel \<equiv> hr_comp hm_impl2_rel hm_impl1_rel"

    lemmas [fcomp_norm_unfold] = hm_impl_rel_def[symmetric]

    (*lemma hm_impl_rel_precise[constraint_rules]: "precise hm_impl_rel"
      unfolding hm_impl_rel_def hm_impl1_rel_def hm_impl2_rel_def
      by (constraint_rules)*)

    subsection \<open>Implement Basic Operations\<close>

    lemma param_parent: "(efficient_nat_div2,h.parent) \<in> Id \<rightarrow> Id"
      by (intro fun_relI) (simp add: h.parent_def)
    lemmas [sepref_import_param] = param_parent
    sepref_register h.parent

    lemma param_left: "(h.left,h.left) \<in> Id \<rightarrow> Id" by simp
    lemmas [sepref_import_param] = param_left
    sepref_register h.left

    lemma param_right: "(h.right,h.right) \<in> Id \<rightarrow> Id" by simp
    lemmas [sepref_import_param] = param_right
    sepref_register h.right

    abbreviation (input) "prio_rel \<equiv> (Id::('p\<times>'p) set)"

    lemma param_prio_le: "((\<le>), (\<le>)) \<in> prio_rel \<rightarrow> prio_rel \<rightarrow> bool_rel" by simp
    lemmas [sepref_import_param] = param_prio_le

    lemma param_prio_lt: "((<), (<)) \<in> prio_rel \<rightarrow> prio_rel \<rightarrow> bool_rel" by simp
    lemmas [sepref_import_param] = param_prio_lt

    abbreviation "I_HM_UNF \<equiv> TYPE(nat list \<times> 'v list)"

    sepref_definition hm_length_impl is "RETURN o hm_length'" :: "hm_impl2_rel\<^sup>k\<rightarrow>\<^sub>anat_assn"
      unfolding hm_length'_def hm_impl2_rel_def
      by sepref
    lemmas [sepref_fr_rules] = hm_length_impl.refine[FCOMP hm_length'_refine]
    sepref_register "hm_length::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_key_of_op_impl is "uncurry hm_key_of_op'" :: "hm_impl2_rel\<^sup>k*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>anat_assn"
      unfolding hm_key_of_op'_def hm_impl2_rel_def
      by sepref
    lemmas [sepref_fr_rules] = hm_key_of_op_impl.refine[FCOMP hm_key_of_op'_refine]
    sepref_register "hm_key_of_op::(nat,'v) ahm \<Rightarrow> _"

    context
      notes [id_rules] = itypeI[Pure.of maxsize "TYPE(nat)"]
      notes [sepref_import_param] = IdI[of maxsize]
    begin

    sepref_definition hm_lookup_impl is "uncurry hm_lookup_op'" :: "(hm_impl2_rel\<^sup>k*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>aoption_assn id_assn)"
      unfolding hm_lookup_op'_def hm_impl2_rel_def
      by sepref
    lemmas [sepref_fr_rules] =
      hm_lookup_impl.refine[FCOMP hm_lookup_op'_refine]
    sepref_register "hm_lookup::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_exch_op_impl is "uncurry2 hm_exch_op'" :: "hm_impl2_rel\<^sup>d*\<^sub>anat_assn\<^sup>k*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>a hm_impl2_rel"
      unfolding hm_exch_op'_def hm_impl2_rel_def
      by sepref
    lemmas [sepref_fr_rules] = hm_exch_op_impl.refine[FCOMP hm_exch_op'_refine]
    sepref_register "hm_exch_op::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_index_op_impl is "uncurry hm_index_op'" :: "hm_impl2_rel\<^sup>k*\<^sub>aid_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding hm_index_op'_def hm_impl2_rel_def
      by sepref
    lemmas [sepref_fr_rules] = hm_index_op_impl.refine[FCOMP hm_index_op'_refine]
    sepref_register "hm_index_op::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_update_op_impl is "uncurry2 hm_update_op'" :: "hm_impl2_rel\<^sup>d*\<^sub>aid_assn\<^sup>k*\<^sub>aid_assn\<^sup>k \<rightarrow>\<^sub>a hm_impl2_rel"
      unfolding hm_update_op'_def hm_impl2_rel_def
      by sepref
    lemmas [sepref_fr_rules] = hm_update_op_impl.refine[FCOMP hm_update_op'_refine]
    sepref_register "hm_update_op::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_butlast_op_impl is "hm_butlast_op'" :: "hm_impl2_rel\<^sup>d \<rightarrow>\<^sub>a hm_impl2_rel"
      unfolding hm_butlast_op'_def hm_impl2_rel_def by sepref
    lemmas [sepref_fr_rules] = hm_butlast_op_impl.refine[FCOMP hm_butlast_op'_refine]
    sepref_register "hm_butlast_op::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_append_op_impl is "uncurry2 hm_append_op'" :: "hm_impl2_rel\<^sup>d *\<^sub>a id_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a hm_impl2_rel"
      unfolding hm_append_op'_def hm_impl2_rel_def
      apply (rewrite array_fold_custom_replicate)
      by sepref
    lemmas [sepref_fr_rules] = hm_append_op_impl.refine[FCOMP hm_append_op'_refine]
    sepref_register "hm_append_op::(nat,'v) ahm \<Rightarrow> _"

    subsection \<open>Auxiliary Operations\<close>

    lemmas [intf_of_assn] = intf_of_assnI[where R="hm_impl_rel :: (nat,'v) ahm \<Rightarrow> _" and 'a="'v i_hma"]

    sepref_definition hm_valid_impl is "uncurry (RETURN oo hm_valid)" :: "hm_impl_rel\<^sup>k*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn "
      unfolding hm_valid_def[abs_def]
      by sepref
    lemmas [sepref_fr_rules] = hm_valid_impl.refine
    sepref_register "hm_valid::(nat,'v) ahm \<Rightarrow> _"

    (* Optimization *)
    definition "hm_the_lookup_op' hm k \<equiv> do {
      let (pq,ml) = hm;
      ASSERT (heapmap_\<alpha> (hm_impl1_\<alpha> hm) k \<noteq> None \<and> hm_impl1_invar hm);
      v \<leftarrow> mop_list_get ml k;
      RETURN v
    }"
    lemma hm_the_lookup_op'_refine:
      "(hm_the_lookup_op', hm_the_lookup_op) \<in> hm_impl1_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Id\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_the_lookup_op'_def hm_the_lookup_op_def
      apply refine_vcg
      apply (auto simp: hm_impl1_rel_defs heapmap_\<alpha>_def hmr_invar_def split: if_split_asm)
      done

    sepref_definition hm_the_lookup_op_impl is "uncurry hm_the_lookup_op'" :: "hm_impl2_rel\<^sup>k*\<^sub>aid_assn\<^sup>k \<rightarrow>\<^sub>aid_assn"
      unfolding hm_the_lookup_op'_def[abs_def] hm_impl2_rel_def
      by sepref
    lemmas hm_the_lookup_op_impl[sepref_fr_rules] = hm_the_lookup_op_impl.refine[FCOMP hm_the_lookup_op'_refine]
    sepref_register "hm_the_lookup_op::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_val_of_op_impl is "uncurry hm_val_of_op" :: "hm_impl_rel\<^sup>k*\<^sub>aid_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding hm_val_of_op_def by sepref
    lemmas [sepref_fr_rules] = hm_val_of_op_impl.refine
    sepref_register "hm_val_of_op::(nat,'v) ahm \<Rightarrow> _"

    sepref_definition hm_prio_of_op_impl is "uncurry (PR_CONST hm_prio_of_op)" :: "hm_impl_rel\<^sup>k*\<^sub>aid_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding hm_prio_of_op_def[abs_def] PR_CONST_def by sepref
    lemmas [sepref_fr_rules] = hm_prio_of_op_impl.refine
    sepref_register "PR_CONST hm_prio_of_op::(nat,'v) ahm \<Rightarrow> _"

    text \<open>No code theorem preparation, as we define optimized version later\<close>
    sepref_definition (no_prep_code) hm_swim_op_impl is "uncurry (PR_CONST hm_swim_op)" :: "hm_impl_rel\<^sup>d*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>a hm_impl_rel"
      unfolding hm_swim_op_def[abs_def] PR_CONST_def
      using [[goals_limit = 1]]
      by sepref
    lemmas [sepref_fr_rules] = hm_swim_op_impl.refine
    sepref_register "PR_CONST hm_swim_op::(nat,'v) ahm \<Rightarrow> _"
    lemma [def_pat_rules]: "hmstruct.hm_swim_op$prio \<equiv> PR_CONST hm_swim_op" by simp

    text \<open>No code theorem preparation, as we define optimized version later\<close>
    sepref_definition (no_prep_code) hm_sink_op_impl is "uncurry (PR_CONST hm_sink_op)" :: "hm_impl_rel\<^sup>d*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>a hm_impl_rel"
      unfolding hm_sink_op_def[abs_def] PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_sink_op_impl.refine
    sepref_register "PR_CONST hm_sink_op::(nat,'v) ahm \<Rightarrow> _"
    lemma [def_pat_rules]: "hmstruct.hm_sink_op$prio \<equiv> PR_CONST hm_sink_op" by simp

    sepref_definition hm_repair_op_impl is "uncurry (PR_CONST hm_repair_op)" :: "hm_impl_rel\<^sup>d*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>a hm_impl_rel"
      unfolding hm_repair_op_def[abs_def] PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_repair_op_impl.refine
    sepref_register "PR_CONST hm_repair_op::(nat,'v) ahm \<Rightarrow> _"
    lemma [def_pat_rules]: "hmstruct.hm_repair_op$prio \<equiv> PR_CONST hm_repair_op" by simp

  subsection \<open>Interface Operations\<close>
  definition hm_rel_np where
    "hm_rel_np \<equiv> hr_comp hm_impl_rel heapmap_rel"
  lemmas [fcomp_norm_unfold] = hm_rel_np_def[symmetric]

  definition hm_rel where
    "hm_rel K V \<equiv> hr_comp hm_rel_np (\<langle>the_pure K,the_pure V\<rangle>map_rel)"
  lemmas [fcomp_norm_unfold] = hm_rel_def[symmetric]

  lemmas [intf_of_assn] = intf_of_assnI[where R="hm_rel K V" and 'a="('kk,'vv) i_map" for K V]

  lemma hm_rel_id_conv: "hm_rel id_assn id_assn = hm_rel_np"
    \<comment> \<open>Used for generic algorithms: Unfold with this, then let decl-impl compose with \<open>map_rel\<close> again.\<close>
    unfolding hm_rel_def by simp

  subsubsection \<open>Synthesis\<close>
  definition op_hm_empty_sz :: "nat \<Rightarrow> 'kk\<rightharpoonup>'vv"
    where [simp]: "op_hm_empty_sz sz \<equiv> op_map_empty"
  sepref_register "PR_CONST (op_hm_empty_sz maxsize)" :: "('k,'v) i_map"
  lemma [def_pat_rules]: "op_hm_empty_sz$maxsize \<equiv> UNPROTECT (op_hm_empty_sz maxsize)" by simp

  lemma hm_fold_custom_empty_sz:
    "op_map_empty = op_hm_empty_sz sz"
    "Map.empty = op_hm_empty_sz sz"
    by auto

  sepref_definition hm_empty_op_impl is "uncurry0 hm_empty_op'" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a hm_impl2_rel"
    unfolding hm_empty_op'_def hm_impl2_rel_def array.fold_custom_empty
    by sepref

  sepref_definition hm_insert_op_impl is "uncurry2 hm_insert_op" :: "[\<lambda>((k,_),_). k<maxsize]\<^sub>a id_assn\<^sup>k*\<^sub>aid_assn\<^sup>k*\<^sub>ahm_impl_rel\<^sup>d \<rightarrow> hm_impl_rel"
    unfolding hm_insert_op_def
    by sepref

  sepref_definition hm_is_empty_op_impl is "hm_is_empty_op" :: "hm_impl_rel\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding hm_is_empty_op_def
    by sepref

  sepref_definition hm_lookup_op_impl is "uncurry hm_lookup_op" :: "id_assn\<^sup>k*\<^sub>ahm_impl_rel\<^sup>k \<rightarrow>\<^sub>a option_assn id_assn"
    unfolding hm_lookup_op_def by sepref

  sepref_definition hm_contains_key_impl is "uncurry hm_contains_key_op'" :: "id_assn\<^sup>k*\<^sub>ahm_impl2_rel\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding hm_contains_key_op'_def hm_impl2_rel_def
    by sepref

  sepref_definition hm_decrease_key_op_impl is "uncurry2 hm_decrease_key_op" :: "id_assn\<^sup>k*\<^sub>aid_assn\<^sup>k*\<^sub>ahm_impl_rel\<^sup>d \<rightarrow>\<^sub>a hm_impl_rel"
    unfolding hm_decrease_key_op_def by sepref

  sepref_definition hm_increase_key_op_impl is "uncurry2 hm_increase_key_op" :: "id_assn\<^sup>k*\<^sub>aid_assn\<^sup>k*\<^sub>ahm_impl_rel\<^sup>d \<rightarrow>\<^sub>a hm_impl_rel"
    unfolding hm_increase_key_op_def by sepref

  sepref_definition hm_change_key_op_impl is "uncurry2 hm_change_key_op" :: "id_assn\<^sup>k*\<^sub>aid_assn\<^sup>k*\<^sub>ahm_impl_rel\<^sup>d \<rightarrow>\<^sub>a hm_impl_rel"
    unfolding hm_change_key_op_def by sepref

  sepref_definition hm_pop_min_op_impl is hm_pop_min_op :: "hm_impl_rel\<^sup>d \<rightarrow>\<^sub>a prod_assn (prod_assn nat_assn id_assn) hm_impl_rel "
    unfolding hm_pop_min_op_def[abs_def]
    by sepref

  sepref_definition hm_remove_op_impl is "uncurry hm_remove_op" :: "id_assn\<^sup>k *\<^sub>a hm_impl_rel\<^sup>d \<rightarrow>\<^sub>a hm_impl_rel"
    unfolding hm_remove_op_def[abs_def] by sepref

  sepref_definition hm_peek_min_op_impl is "hm_peek_min_op" :: "hm_impl_rel\<^sup>k \<rightarrow>\<^sub>a prod_assn nat_assn id_assn"
    unfolding hm_peek_min_op_def[abs_def] hm_kv_of_op_def
    by sepref

  subsubsection \<open>Setup of Refinements\<close>

  sepref_decl_impl (no_register) hm_empty:
    hm_empty_op_impl.refine[FCOMP hm_empty_op'_refine, FCOMP hm_empty_aref] .

  context fixes K assumes "IS_BELOW_ID K" begin
    lemmas mop_map_update_new_fref' = mop_map_update_new.fref[of K]
    lemmas op_map_update_fref' = op_map_update.fref[of K]
  end

  sepref_decl_impl (ismop) hm_insert: hm_insert_op_impl.refine[FCOMP hm_insert_op_aref]
    uses mop_map_update_new_fref'
    unfolding IS_BELOW_ID_def
    apply (parametricity; auto simp: single_valued_below_Id)
    done

  sepref_decl_impl hm_is_empty: hm_is_empty_op_impl.refine[FCOMP hm_is_empty_op_aref] .
  sepref_decl_impl hm_lookup: hm_lookup_op_impl.refine[FCOMP hm_lookup_op_aref] .

  sepref_decl_impl hm_contains_key:
    hm_contains_key_impl.refine[FCOMP hm_contains_key_op'_refine, FCOMP hm_contains_key_op_aref]
    .

  sepref_decl_impl (ismop) hm_decrease_key: hm_decrease_key_op_impl.refine[FCOMP hm_decrease_key_op_aref] .
  sepref_decl_impl (ismop) hm_increase_key: hm_increase_key_op_impl.refine[FCOMP hm_increase_key_op_aref] .
  sepref_decl_impl (ismop) hm_change_key: hm_change_key_op_impl.refine[FCOMP hm_change_key_op_aref] .

  sepref_decl_impl (ismop) hm_remove: hm_remove_op_impl.refine[FCOMP hm_remove_op_aref] .

  sepref_decl_impl (ismop) hm_pop_min: hm_pop_min_op_impl.refine[FCOMP hm_pop_min_op_aref] .
  sepref_decl_impl (ismop) hm_peek_min: hm_peek_min_op_impl.refine[FCOMP hm_peek_min_op_aref] .

  \<comment> \<open>Realized as generic algorithm. Note that we use @{term id_assn} for the elements.\<close>
  sepref_definition hm_upd_op_impl is "uncurry2 (RETURN ooo op_map_update)" :: "[\<lambda>((k,_),_). k<maxsize]\<^sub>a id_assn\<^sup>k *\<^sub>a id_assn\<^sup>k *\<^sub>a (hm_rel id_assn id_assn)\<^sup>d \<rightarrow> hm_rel id_assn id_assn"
    unfolding op_pm_set_gen_impl by sepref

  sepref_decl_impl hm_upd_op_impl.refine[unfolded hm_rel_id_conv] uses op_map_update_fref'
    unfolding IS_BELOW_ID_def
    apply (parametricity; auto simp: single_valued_below_Id)
    done

end
end

interpretation hm: map_custom_empty "PR_CONST (op_hm_empty_sz maxsize)"
  apply unfold_locales by simp

lemma op_hm_empty_sz_hnr[sepref_fr_rules]:
  "(uncurry0 (hm_empty_op_impl maxsize), uncurry0 (RETURN (PR_CONST (op_hm_empty_sz maxsize)))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a hm_rel maxsize prio K V"
  using hm_empty_hnr by simp

subsection \<open>Manual fine-tuning of code-lemmas\<close>
(* TODO: Integrate into Sepref-tool optimization phase! *)

context
notes [simp del] = CNV_def efficient_nat_div2
begin

lemma nested_case_bind:
  "(case p of (a,b) \<Rightarrow> bind (case a of (a1,a2) \<Rightarrow> m a b a1 a2) (f a b))
  = (case p of ((a1,a2),b) \<Rightarrow> bind (m (a1,a2) b a1 a2) (f (a1,a2) b))"
  "(case p of (a,b) \<Rightarrow> bind (case b of (b1,b2) \<Rightarrow> m a b b1 b2) (f a b))
  = (case p of (a,b1,b2) \<Rightarrow> bind (m a (b1,b2) b1 b2) (f a (b1,b2)))"
  by (simp_all split: prod.splits)

lemma it_case: "(case p of (a,b) \<Rightarrow> f p a b) = (case p of (a,b) \<Rightarrow> f (a,b) a b)"
  by (auto split: prod.split)

lemma c2l: "(case p of (a,b) \<Rightarrow> bind (m a b) (f a b)) =
  do { let (a,b) = p; bind (m a b) (f a b)}" by simp

lemma bind_Let: "do { x \<leftarrow> do { let y = v; (f y :: 'a Heap)}; g x } = do { let y=v; x \<leftarrow> f y; g x }" by auto
lemma bind_case: "do { x \<leftarrow> (case y of (a,b) \<Rightarrow> f a b); (g x :: 'a Heap) } = do { let (a,b) = y; x \<leftarrow> f a b; g x }"
  by (auto split: prod.splits)

lemma bind_case_mvup: "do { x \<leftarrow> f; case y of (a,b) \<Rightarrow> g a b x }
  = do { let (a,b) = y; x \<leftarrow> f; (g a b x :: 'a Heap) }"
  by (auto split: prod.splits)

lemma if_case_mvup: "(if b then case p of (x1,x2) \<Rightarrow> f x1 x2 else e)
  = (case p of (x1,x2) \<Rightarrow> if b then f x1 x2 else e)" by auto

lemma nested_case: "(case p of (a,b) \<Rightarrow> (case p of (c,d) \<Rightarrow> f a b c d)) =
  (case p of (a,b) \<Rightarrow> f a b a b)"
  by (auto split: prod.split)

lemma split_prod_bound: "(\<lambda>p. f p) = (\<lambda>(a,b). f (a,b))" by auto

lemma bpc_conv: "do { (a,b) \<leftarrow> (m::(_*_) Heap); f a b } = do {
  ab \<leftarrow> (m);
  f (fst ab) (snd ab)
}"
  apply (subst (2) split_prod_bound)
  by simp

lemma it_case_pp: "(case p of ((p1,p2)) \<Rightarrow> case p of ((p1',p2')) \<Rightarrow> f p1 p2 p1' p2')
  = (case p of ((p1,p2)) \<Rightarrow> f p1 p2 p1 p2)"
  by (auto split: prod.split)

lemma it_case_ppp: "(case p of ((p1,p2),p3) \<Rightarrow> case p of ((p1',p2'),p3') \<Rightarrow> f p1 p2 p3 p1' p2' p3')
  = (case p of ((p1,p2),p3) \<Rightarrow> f p1 p2 p3 p1 p2 p3)"
  by (auto split: prod.split)

lemma it_case_pppp: "(case a1 of
              (((a, b), c), d) \<Rightarrow>
                case a1 of
                (((a', b'), c'), d') \<Rightarrow> f a b c d a' b' c' d') =
       (case a1 of
              (((a, b), c), d) \<Rightarrow> f a b c d a b c d)"
  by (auto split: prod.splits)

private lemmas inlines = hm_append_op_impl_def ial_append_def
    marl_length_def marl_append_def hm_length_impl_def ial_length_def
    hm_valid_impl_def hm_prio_of_op_impl_def hm_val_of_op_impl_def hm_key_of_op_impl_def
    ial_get_def hm_the_lookup_op_impl_def heap_array_set_def marl_get_def
    it_case_ppp it_case_pppp bind_case bind_case_mvup nested_case if_case_mvup
    it_case_pp

schematic_goal [code]: "hm_insert_op_impl maxsize prio hm k v = ?f"
  unfolding hm_insert_op_impl_def
  apply (rule CNV_eqD)
  apply (simp add: inlines  cong: if_cong)
  by (rule CNV_I)

schematic_goal "hm_swim_op_impl prio hm i \<equiv> ?f"
  unfolding hm_swim_op_impl_def
  apply (rule eq_reflection)
  apply (rule CNV_eqD)
  apply (simp add: inlines efficient_nat_div2
    cong: if_cong)
  by (rule CNV_I)

lemma hm_swim_op_impl_code[code]: "hm_swim_op_impl prio hm i \<equiv> ccpo.fixp (fun_lub Heap_lub) (fun_ord Heap_ord)
       (\<lambda>cf (a1, a2).
           case a1 of
           ((a1b, a2b), a2a) \<Rightarrow>
             case a1b of
             (a, b) \<Rightarrow> do {
               let d2 = efficient_nat_div2 a2;
               if 0 < d2 \<and> d2 \<le> b
               then do {
                      x \<leftarrow> (case a1b of (a, n) \<Rightarrow> Array.nth a) (d2 - Suc 0);
                      x \<leftarrow> Array.nth a2a x;
                      xa \<leftarrow> (case a1b of (a, n) \<Rightarrow> Array.nth a) (a2 - Suc 0);
                      xa \<leftarrow> Array.nth a2a xa;
                      if prio x \<le> prio xa then return a1
                      else do {
                             x'g \<leftarrow> hm_exch_op_impl a1 a2 (d2);
                             cf (x'g, d2)
                           }
                    }
               else return a1
             })
       (hm, i)"
  unfolding hm_swim_op_impl_def
  apply (rule eq_reflection)
  apply (simp add: inlines efficient_nat_div2 Let_def
    cong: if_cong)
  done

prepare_code_thms hm_swim_op_impl_code

schematic_goal hm_sink_opt_impl_code[code]: "hm_sink_op_impl prio hm i \<equiv> ?f"
  unfolding hm_sink_op_impl_def
  apply (rule eq_reflection)
  apply (rule CNV_eqD)
  apply (simp add: inlines
    cong: if_cong)
  by (rule CNV_I)

prepare_code_thms hm_sink_opt_impl_code

export_code hm_swim_op_impl in SML_imp module_name Test

schematic_goal hm_change_key_opt_impl_code[code]: "
  hm_change_key_op_impl prio k v hm \<equiv> ?f"
  unfolding hm_change_key_op_impl_def
  apply (rule eq_reflection)
  apply (rule CNV_eqD)
  apply (simp add: inlines hm_contains_key_impl_def ial_contains_def
    hm_change_key_op_impl_def hm_index_op_impl_def hm_update_op_impl_def
    ial_index_def
    cong: if_cong split: prod.splits)
  oops

schematic_goal hm_change_key_opt_impl_code[code]: "
  hm_change_key_op_impl prio k v hm \<equiv> case hm of (((a, b), ba), x2) \<Rightarrow>
       (do {
              x \<leftarrow> Array.nth ba k;
              xa \<leftarrow> Array.nth a x;
              xa \<leftarrow> Array.upd xa v x2;
              hm_repair_op_impl prio (((a, b), ba), xa) (Suc x)
            })"
  unfolding hm_change_key_op_impl_def
  apply (rule eq_reflection)
  apply (simp add: inlines hm_contains_key_impl_def ial_contains_def
    hm_change_key_op_impl_def hm_index_op_impl_def hm_update_op_impl_def
    ial_index_def
    cong: if_cong split: prod.splits)
  done

schematic_goal hm_set_opt_impl_code[code]: "hm_upd_op_impl maxsize prio hm k v \<equiv> ?f"
  unfolding hm_upd_op_impl_def
  apply (rule eq_reflection)
  apply (rule CNV_eqD)
  apply (simp add: inlines hm_contains_key_impl_def ial_contains_def
    hm_change_key_op_impl_def hm_index_op_impl_def hm_update_op_impl_def
    ial_index_def
    cong: if_cong)
  by (rule CNV_I)

schematic_goal hm_pop_min_opt_impl_code[code]: "hm_pop_min_op_impl prio hm \<equiv> ?f"
  unfolding hm_pop_min_op_impl_def
  apply (rule eq_reflection)
  apply (rule CNV_eqD)
  apply (simp add: inlines hm_contains_key_impl_def ial_contains_def
    hm_change_key_op_impl_def hm_index_op_impl_def hm_update_op_impl_def
    hm_butlast_op_impl_def ial_butlast_def
    ial_index_def
    cong: if_cong)
  by (rule CNV_I)

end

export_code
  hm_empty_op_impl
  hm_insert_op_impl
  hm_is_empty_op_impl
  hm_lookup_op_impl
  hm_contains_key_impl
  hm_decrease_key_op_impl
  hm_increase_key_op_impl
  hm_change_key_op_impl
  hm_upd_op_impl
  hm_pop_min_op_impl
  hm_remove_op_impl
  hm_peek_min_op_impl
  checking SML_imp

end


section \<open>Exploration of Deterministic Rabin Automata\<close>

theory DRA_Nodes
imports
  DFS_Framework.Reachable_Nodes
  DRA_Implement
begin

  definition dra_G :: "('label, 'state) dra \<Rightarrow> 'state graph_rec" where
    "dra_G A \<equiv> \<lparr> g_V = UNIV, g_E = E_of_succ (successors A), g_V0 = {initial A} \<rparr>"

  lemma dra_G_graph[simp]: "graph (dra_G A)" unfolding dra_G_def graph_def by simp
  lemma dra_G_reachable_nodes: "op_reachable (dra_G A) = nodes A"
  unfolding op_reachable_def dra_G_def graph_rec.simps E_of_succ_def
  proof safe
    show "p \<in> nodes A" if "(initial A, p) \<in> {(u, v). v \<in> successors A u}\<^sup>*" for p
      using that by induct auto
    show "(initial A, p) \<in> {(u, v). v \<in> successors A u}\<^sup>*" if "p \<in> nodes A" for p
      using that by (induct) (auto intro: rtrancl_into_rtrancl)
  qed

  context
  begin

    interpretation autoref_syn by this

    lemma dra_G_ahs: "dra_G A = \<lparr> g_V = UNIV, g_E = E_of_succ (\<lambda> p. CAST
      ((\<lambda> a. transition A a p ::: S) ` alphabet A ::: \<langle>S\<rangle> ahs_rel bhc)), g_V0 = {initial A} \<rparr>"
      unfolding dra_G_def CAST_def id_apply E_of_succ_def autoref_tag_defs by auto

    schematic_goal drai_Gi:
      notes map2set_to_list[autoref_ga_rules]
      fixes S :: "('statei \<times> 'state) set"
      assumes [autoref_ga_rules]: "is_bounded_hashcode S seq bhc"
      assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('statei) hms"
      assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
      assumes [autoref_rules]: "(Ai, A) \<in> \<langle>L, S\<rangle> drai_dra_rel"
      shows "(?f :: ?'a, RETURN (dra_G A)) \<in> ?A"
      unfolding dra_G_ahs[where S = S and bhc = bhc] by (autoref_monadic (plain))
    concrete_definition drai_Gi uses drai_Gi
    (* TODO: why are term local.drai_Gi and term BA_Nodes.drai_Gi not the same *)
    lemma drai_Gi_refine[autoref_rules]:
      fixes S :: "('statei \<times> 'state) set"
      assumes "SIDE_GEN_ALGO (is_bounded_hashcode S seq bhc)"
      assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('statei) hms)"
      assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
      shows "(DRA_Nodes.drai_Gi seq bhc hms, dra_G) \<in> \<langle>L, S\<rangle> drai_dra_rel \<rightarrow> \<langle>unit_rel, S\<rangle> g_impl_rel_ext"
      using drai_Gi.refine[THEN RETURN_nres_relD] assms unfolding autoref_tag_defs by blast

    schematic_goal dra_nodes:
      fixes S :: "('statei \<times> 'state) set"
      assumes [simp]: "finite ((g_E (dra_G A))\<^sup>* `` g_V0 (dra_G A))"
      assumes [autoref_ga_rules]: "is_bounded_hashcode S seq bhc"
      assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('statei) hms"
      assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
      assumes [autoref_rules]: "(Ai, A) \<in> \<langle>L, S\<rangle> drai_dra_rel"
      shows "(?f :: ?'a, op_reachable (dra_G A)) \<in> ?R" by autoref
    concrete_definition dra_nodes uses dra_nodes
    lemma dra_nodes_refine[autoref_rules]:
      fixes S :: "('statei \<times> 'state) set"
      assumes "SIDE_PRECOND (finite (nodes A))"
      assumes "SIDE_GEN_ALGO (is_bounded_hashcode S seq bhc)"
      assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('statei) hms)"
      assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
      assumes "(Ai, A) \<in> \<langle>L, S\<rangle> drai_dra_rel"
      shows "(DRA_Nodes.dra_nodes seq bhc hms Ai,
        (OP nodes ::: \<langle>L, S\<rangle> drai_dra_rel \<rightarrow> \<langle>S\<rangle> ahs_rel bhc) $ A) \<in> \<langle>S\<rangle> ahs_rel bhc"
    proof -
      have "finite ((g_E (dra_G A))\<^sup>* `` g_V0 (dra_G A))"
        using assms(1) unfolding autoref_tag_defs dra_G_reachable_nodes[symmetric] by simp
      then show ?thesis using dra_nodes.refine assms
        unfolding autoref_tag_defs dra_G_reachable_nodes[symmetric] by blast
    qed

  end

end


theory TrivialArityAnal
imports ArityAnalysisSpec "../Launchbury/Env-Nominal"
begin

definition Trivial_Aexp :: "exp \<Rightarrow> Arity \<rightarrow> AEnv"
  where "Trivial_Aexp e = (\<Lambda> n. (\<lambda> x. up\<cdot>0) f|` fv e)"

lemma Trivial_Aexp_simp: "Trivial_Aexp e \<cdot> n = (\<lambda> x. up\<cdot>0) f|` fv e"
  unfolding Trivial_Aexp_def by simp

lemma edom_Trivial_Aexp[simp]: "edom (Trivial_Aexp e \<cdot> n) = fv e"
  by (auto simp add: edom_def env_restr_def Trivial_Aexp_def)

lemma Trivial_Aexp_eq[iff]: "Trivial_Aexp e \<cdot> n = Trivial_Aexp e' \<cdot> n' \<longleftrightarrow> fv e = (fv e' :: var set)"
  apply (auto simp add: Trivial_Aexp_simp env_restr_def)
  apply (metis up_defined)+
  done

lemma below_Trivial_Aexp[simp]: "(ae \<sqsubseteq> Trivial_Aexp e \<cdot> n) \<longleftrightarrow> edom ae \<subseteq> fv e"
  by (auto dest:fun_belowD intro!: fun_belowI  simp add: Trivial_Aexp_def env_restr_def edom_def split:if_splits)

interpretation ArityAnalysis Trivial_Aexp.
interpretation EdomArityAnalysis Trivial_Aexp
  by standard simp

interpretation ArityAnalysisSafe Trivial_Aexp
proof
(*
  fix \<pi>
  show "\<pi> \<bullet> Trivial_Aexp = Trivial_Aexp" by perm_simp rule
next
*)
  fix n x
  show "up\<cdot>n \<sqsubseteq> (Trivial_Aexp (Var x)\<cdot>n) x"
    by (simp add: Trivial_Aexp_simp)
next
  fix e x n
  show "Trivial_Aexp e\<cdot>(inc\<cdot>n) \<squnion> esing x\<cdot>(up\<cdot>0) \<sqsubseteq> Trivial_Aexp (App e x)\<cdot>n"
    by (auto intro: fun_belowI simp add: Trivial_Aexp_def env_restr_def )
next
  fix y e n
  show "env_delete y (Trivial_Aexp e\<cdot>(pred\<cdot>n)) \<sqsubseteq> Trivial_Aexp (Lam [y]. e)\<cdot>n"
    by (auto simp add: Trivial_Aexp_simp env_delete_restr Diff_eq inf_commute)
next
  fix x y :: var and S e a
  assume "x \<notin> S" and "y \<notin> S"
  thus "Trivial_Aexp e[x::=y]\<cdot>a f|` S = Trivial_Aexp e\<cdot>a f|` S"
    by (auto simp add: Trivial_Aexp_simp fv_subst_eq intro!: arg_cong[where f = "\<lambda> S. env_restr S e" for e])
next
  fix scrut e1 a e2
  show "Trivial_Aexp scrut\<cdot>0 \<squnion> Trivial_Aexp e1\<cdot>a \<squnion> Trivial_Aexp e2\<cdot>a \<sqsubseteq> Trivial_Aexp (scrut ? e1 : e2)\<cdot>a"
    by (auto intro: env_restr_mono2 simp add: Trivial_Aexp_simp join_below_iff )
qed

definition Trivial_Aheap :: "heap \<Rightarrow> exp \<Rightarrow> Arity \<rightarrow> AEnv" where
  "Trivial_Aheap \<Gamma> e = (\<Lambda> a. (\<lambda> x. up\<cdot>0) f|` domA \<Gamma>)"

lemma Trivial_Aheap_eqvt[eqvt]: "\<pi> \<bullet>  (Trivial_Aheap \<Gamma> e) = Trivial_Aheap (\<pi> \<bullet> \<Gamma>) (\<pi> \<bullet> e)"
  unfolding Trivial_Aheap_def
  apply perm_simp
  apply (simp add: Abs_cfun_eqvt)
  done

lemma Trivial_Aheap_simp: "Trivial_Aheap \<Gamma> e\<cdot> a = (\<lambda> x. up\<cdot>0) f|` domA \<Gamma>"
  unfolding Trivial_Aheap_def by simp

lemma Trivial_fup_Aexp_below_fv: "fup\<cdot>(Trivial_Aexp e)\<cdot>a \<sqsubseteq> (\<lambda> x . up\<cdot>0) f|` fv e"
  by (cases a)(auto simp add: Trivial_Aexp_simp)

lemma Trivial_Abinds_below_fv: "ABinds \<Gamma>\<cdot>ae \<sqsubseteq> (\<lambda> x . up\<cdot>0) f|` fv \<Gamma>"
  by (induction \<Gamma> rule:ABinds.induct)
     (auto simp add: join_below_iff intro!: below_trans[OF Trivial_fup_Aexp_below_fv] env_restr_mono2 elim: below_trans dest: set_mp[OF fv_delete_subset] simp del: fun_meet_simp)

interpretation ArityAnalysisLetSafe Trivial_Aexp Trivial_Aheap
proof
  fix \<pi>
  show "\<pi> \<bullet> Trivial_Aheap = Trivial_Aheap" by perm_simp rule
next
  fix \<Gamma> e ae show "edom (Trivial_Aheap \<Gamma> e\<cdot>ae) \<subseteq> domA \<Gamma>"
  by (simp add: Trivial_Aheap_simp)
next
  fix \<Gamma> :: heap and e and a
  show "ABinds \<Gamma>\<cdot>(Trivial_Aheap \<Gamma> e\<cdot>a) \<squnion> Trivial_Aexp e\<cdot>a \<sqsubseteq> Trivial_Aheap \<Gamma> e\<cdot>a \<squnion> Trivial_Aexp (Terms.Let \<Gamma> e)\<cdot>a"
    by (auto simp add: Trivial_Aheap_simp Trivial_Aexp_simp join_below_iff env_restr_join2 intro!: env_restr_mono2 below_trans[OF Trivial_Abinds_below_fv])
next
  fix x y :: var and \<Gamma> :: heap and e
  assume "x \<notin> domA \<Gamma>" and "y \<notin> domA \<Gamma>"
  thus "Trivial_Aheap \<Gamma>[x::h=y] e[x::=y] = Trivial_Aheap \<Gamma> e"
    by (auto intro: cfun_eqI simp add: Trivial_Aheap_simp)
qed

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      StateSpace.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section \<open>State Space Template\<close>
theory StateSpace imports Hoare
begin

record 'g state = "globals"::'g

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> ('g,'z) state_scheme \<Rightarrow> ('g,'z) state_scheme"
where
  "upd_globals upd s = s\<lparr>globals := upd (globals s)\<rparr>"

record ('g, 'n, 'val) stateSP = "'g state" +
  locals :: "'n \<Rightarrow> 'val"

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. s\<lparr>globals := f (globals s)\<rparr>)"
  by (rule ext) (simp add: upd_globals_def)

end