header "Formalization of Promela semantics"
theory Promela
imports
  PromelaDatastructures
  PromelaInvariants
  PromelaStatistics
begin

text {*
  After having defined the datastructures, we present in this theory how to construct the transition system and how to generate the successors of a state, \ie the real semantics of a Promela program.
  For the first task, we take the enriched AST as input, the second one operates on the transition system.
*}

subsection {* Misc Helpers*}
definition add_label :: "String.literal \<Rightarrow> labels \<Rightarrow> nat \<Rightarrow> labels" where
  "add_label l lbls pos = (
     case lm.lookup l lbls of
       None \<Rightarrow> lm.update l pos lbls
     | Some _ \<Rightarrow> abortv ''Label given twice: '' l (\<lambda>_. lbls))"

definition min_prio :: "edge list \<Rightarrow> integer \<Rightarrow> integer" where
  "min_prio es start = Min ((prio ` set es) \<union> {start})"

lemma min_prio_code [code]:
  "min_prio es start = fold  (\<lambda>e pri. if prio e < pri then prio e else pri) es start"
proof -
  from Min.set_eq_fold have "Min (set (start # map prio es)) = fold min (map prio es) start" by metis
  also have "... = fold (min \<circ> prio) es start" by (simp add: fold_map)
  also have "... = fold  (\<lambda>e pri. if prio e < pri then prio e else pri) es start" by (auto intro!: fold_cong)
  finally show ?thesis by (simp add: min_prio_def)
qed

definition for_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "for_all f xs \<longleftrightarrow> (\<forall>x \<in> set xs. f x)"

lemma for_all_code[code]:
  "for_all f xs \<longleftrightarrow> foldli xs id (\<lambda>kv \<sigma>. f kv) True"
  by (simp add: for_all_def foldli_conj)

definition find_remove :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option \<times> 'a list" where
  "find_remove P xs = (case List.find P xs of None \<Rightarrow> (None, xs)
                                            | Some x \<Rightarrow> (Some x, List.remove1 x xs))"

lemma find_remove_code [code]:
  "find_remove P [] = (None, [])"
  "find_remove P (x#xs) = (if P x then (Some x, xs)
                           else apsnd (Cons x) (find_remove P xs))"
  by (induct xs) (auto simp add: find_remove_def dest: find_SomeD split: option.split)

lemma find_remove_subset:
  "find_remove P xs = (res, xs') \<Longrightarrow> set xs' \<subseteq> set xs"
unfolding find_remove_def
using set_remove1_subset
by (force split: option.splits)

lemma find_remove_length:
  "find_remove P xs = (res, xs') \<Longrightarrow> length xs' \<le> length xs"
unfolding find_remove_def
by (induct xs arbitrary: res xs') (auto split: if_splits option.splits)

subsection {* Variable handling *}

text {*
  Handling variables, with their different scopes (global vs. local),
  and their different types (array vs channel vs bounded) is one of the main challenges
  of the implementation.
*}

fun lookupVar :: "variable \<Rightarrow> integer option \<Rightarrow> integer" where
  "lookupVar (Var _ val) None = val"
| "lookupVar (Var _ _) (Some _) = abort ''Array used on var'' (\<lambda>_.0)"
| "lookupVar (VArray _ _ vals) None = vals !! 0" (* sic! *)
| "lookupVar (VArray _ siz vals) (Some idx) = vals !! nat_of_integer idx"

primrec checkVarValue :: "varType \<Rightarrow> integer \<Rightarrow> integer" where
  "checkVarValue (VTBounded lRange hRange) val = (
     if val \<le> hRange \<and> val \<ge> lRange then val
     else (* overflowing is well-defined and may actually be used (e.g. bool) *)
        if lRange = 0 \<and> val > 0
        then val mod (hRange + 1)
        else (* we do not want to implement C-semantics (ie type casts) *)
           abort ''Value overflow'' (\<lambda>_. lRange))"
| "checkVarValue VTChan val = (
     if val < min_var_value \<or> val > max_var_value
     then abort ''Value overflow'' (\<lambda>_. 0)
     else val)"

lemma checkVarValue_bounds:
  "varType_inv type \<Longrightarrow> checkVarValue type val \<le> max_var_value"
  "varType_inv type \<Longrightarrow> min_var_value \<le> checkVarValue type val"
by (cases type, auto intro: mod_le mod_ge)+

lemma checkVarValue_Var:
  "varType_inv type \<Longrightarrow> variable_inv (Var type (checkVarValue type val))"
by (simp add: checkVarValue_bounds)

fun editVar :: "variable \<Rightarrow> integer option \<Rightarrow> integer \<Rightarrow> variable" where
  "editVar (Var type _ ) None val = Var type (checkVarValue type val)"
| "editVar (Var _ _) (Some _) _ = abort ''Array used on var'' (\<lambda>_. Var VTChan 0)"
| "editVar (VArray type siz vals) None val = (
     let lv = IArray.list_of vals in
     let v' = lv[0:=checkVarValue type val] in
     VArray type siz (IArray v'))"
| "editVar (VArray type siz vals) (Some idx) val = (
     let lv = IArray.list_of vals in
     let v' = lv[(nat_of_integer idx):=checkVarValue type val] in
     VArray type siz (IArray v'))"

lemma editVar_variable_inv:
  assumes "variable_inv v"
  shows "variable_inv (editVar v idx val)"
proof (cases v)
  case (Var type val) with assms have "varType_inv type" by simp
  with Var show ?thesis
    by (cases idx)
       (auto intro!: checkVarValue_Var
             simp del: checkVarValue.simps variable_inv.simps)
next
  case (VArray type siz vals)
  with assms have [simp, intro!]: "varType_inv type" by simp

  show ?thesis
  proof (cases idx)
    case None with assms VArray show ?thesis
      by (cases "IArray.list_of vals") (auto intro!: checkVarValue_bounds)
  next
    case (Some i)
    note upd_cases = in_set_upd_cases[where l="IArray.list_of vals" and i="nat_of_integer i"]

    from Some VArray assms show ?thesis
      by (cases type) (auto elim!: upd_cases intro!: mod_ge mod_le simp: min_var_value_def)
  qed
qed

definition getVar'
  :: "bool \<Rightarrow> String.literal \<Rightarrow> integer option
      \<Rightarrow> 'a gState_scheme \<Rightarrow> pState
      \<Rightarrow> integer option"
where
  "getVar' gl v idx g p = (
          let vars = if gl then gState.vars g else pState.vars p in
          map_option (\<lambda>x. lookupVar x idx) (lm.lookup v vars))"

definition setVar'
  :: "bool \<Rightarrow> String.literal \<Rightarrow> integer option
      \<Rightarrow> integer
      \<Rightarrow> 'a gState_scheme \<Rightarrow> pState
      \<Rightarrow> 'a gState_scheme * pState"
 where
  "setVar' gl v idx val g p = (
     if gl then
        if v = STR ''_'' then (g,p) (* '_' is a write-only scratch variable *)
        else case lm.lookup v (gState.vars g) of
               None \<Rightarrow> abortv ''Unknown global variable: '' v (\<lambda>_. (g,p))
             | Some x \<Rightarrow> (g\<lparr>gState.vars := lm.update v (editVar x idx val)
                                                       (gState.vars g)\<rparr>
                         , p)
     else
        case lm.lookup v (pState.vars p) of
          None \<Rightarrow> abortv ''Unknown proc variable: '' v (\<lambda>_. (g,p))
        | Some x \<Rightarrow> (g, p\<lparr>pState.vars := lm.update v (editVar x idx val)
                                                     (pState.vars p)\<rparr>))"

lemma setVar'_gState_inv:
  assumes "gState_inv prog g"
  shows "gState_inv prog (fst (setVar' gl v idx val g p))"
unfolding setVar'_def using assms
by (auto simp add: gState_inv_def lm.correct
         intro: editVar_variable_inv
         split: option.splits)

lemma setVar'_gState_progress_rel:
  assumes "gState_inv prog g"
  shows "(g, fst (setVar' gl v idx val g p)) \<in> gState_progress_rel prog"
apply (intro gState_progress_relI)
      apply (fact assms)
    apply (fact setVar'_gState_inv[OF assms])
  apply (auto simp: setVar'_def lm.correct split: option.splits)
done

lemma vardict_inv_process_names:
  assumes "vardict_inv ss proc v"
  and "lm.lookup k v = Some x"
  shows "k \<in> process_names ss proc"
using assms
by (auto simp add: lm.correct vardict_inv_def)

lemma vardict_inv_variable_inv:
  assumes "vardict_inv ss proc v"
  and "lm.lookup k v = Some x"
  shows "variable_inv x"
using assms
by (auto simp add: lm.correct vardict_inv_def)

lemma vardict_inv_updateI:
  assumes "vardict_inv ss proc vs"
  and "x \<in> process_names ss proc"
  and "variable_inv v"
  shows "vardict_inv ss proc (lm.update x v vs)"
using assms
by (auto simp add: lm.correct vardict_inv_def)

lemma update_vardict_inv:
  assumes "vardict_inv ss proc v"
  and "lm.lookup k v = Some x"
  and "variable_inv x'"
  shows "vardict_inv ss proc (lm.update k x' v)"
using assms
by (auto intro!: vardict_inv_updateI vardict_inv_process_names)

lemma setVar'_pState_inv:
  assumes "pState_inv prog p"
  shows "pState_inv prog (snd (setVar' gl v idx val g p))"
unfolding setVar'_def using assms
by (auto split: if_splits option.splits
         simp add: pState_inv_def
         intro: update_vardict_inv editVar_variable_inv vardict_inv_variable_inv)

lemma setVar'_cl_inv:
  assumes "cl_inv (g,p)"
  shows "cl_inv (setVar' gl v idx val g p)"
unfolding setVar'_def using assms
by (auto split: if_splits option.splits)

definition withVar'
  :: "bool \<Rightarrow> String.literal \<Rightarrow> integer option
      \<Rightarrow> (integer \<Rightarrow> 'x)
      \<Rightarrow> 'a gState_scheme \<Rightarrow> pState
      \<Rightarrow> 'x"
where
  "withVar' gl v idx f g p = f (the (getVar' gl v idx g p))"

definition withChannel'
  :: "bool \<Rightarrow> String.literal \<Rightarrow> integer option
      \<Rightarrow> (nat \<Rightarrow> channel \<Rightarrow> 'x)
      \<Rightarrow> 'a gState_scheme \<Rightarrow> pState
      \<Rightarrow> 'x"
where
  "withChannel' gl v idx f g p = (
     let error = \<lambda>_. abortv ''Variable is not a channel: '' v
                                (\<lambda>_. f 0 InvChannel) in
     let abort = \<lambda>_. abortv ''Channel already closed / invalid: '' v
                                (\<lambda>_. f 0 InvChannel)
     in withVar' gl v idx (\<lambda>i. let i = nat_of_integer i in
                               if i \<ge> length (channels g) then error ()
                               else let c = channels g ! i in
                                    case c of
                                      InvChannel \<Rightarrow> abort ()
                                    | _ \<Rightarrow> f i c) g p)"

subsection {* Expressions *}

text {* Expressions are free of side-effects.

This is in difference to SPIN, where @{term run} is an expression with side-effect. We treat @{term run} as a statement. *}

abbreviation "trivCond x \<equiv> if x then 1 else 0"

fun exprArith :: "'a gState_scheme \<Rightarrow> pState \<Rightarrow> expr \<Rightarrow> integer"
and pollCheck :: "'a gState_scheme \<Rightarrow> pState \<Rightarrow> channel \<Rightarrow> recvArg list \<Rightarrow> bool
                   \<Rightarrow> bool"
and recvArgsCheck :: "'a gState_scheme \<Rightarrow> pState \<Rightarrow> recvArg list \<Rightarrow> integer list
                       \<Rightarrow> bool"
where
  "exprArith g p (ExprConst x) = x"
| "exprArith g p (ExprMConst x _) = x"

| "exprArith g p ExprTimeOut = trivCond (timeout g)"

| "exprArith g p (ExprLen (ChanRef (VarRef gl name None))) =
     withChannel' gl name None (
       \<lambda>_ c. case c of
                Channel _ _ q \<Rightarrow> integer_of_nat (length q)
              | HSChannel _ \<Rightarrow> 0) g p"

| "exprArith g p (ExprLen (ChanRef (VarRef gl name (Some idx)))) =
     withChannel' gl name (Some (exprArith g p idx)) (
      \<lambda>_ c. case c of
              Channel _ _ q \<Rightarrow> integer_of_nat (length q)
            | HSChannel _ \<Rightarrow> 0) g p"

| "exprArith g p (ExprEmpty (ChanRef (VarRef gl name None))) =
     trivCond (withChannel' gl name None (
       \<lambda>_ c. case c of Channel _ _ q \<Rightarrow> (q = [])
                     | HSChannel _ \<Rightarrow> True) g p)"

| "exprArith g p (ExprEmpty (ChanRef (VarRef gl name (Some idx)))) =
     trivCond (withChannel' gl name (Some (exprArith g p idx)) (
       \<lambda>_ c. case c of Channel _ _ q \<Rightarrow> (q = [])
                     | HSChannel _ \<Rightarrow> True) g p)"

| "exprArith g p (ExprFull (ChanRef(VarRef gl name None))) =
     trivCond (withChannel' gl name None (
       \<lambda>_ c. case c of
               Channel cap _ q \<Rightarrow> integer_of_nat (length q) \<ge> cap
             | HSChannel _ \<Rightarrow> False) g p)"

| "exprArith g p (ExprFull (ChanRef(VarRef gl name (Some idx)))) =
     trivCond (withChannel' gl name (Some (exprArith g p idx)) (
       \<lambda>_ c. case c of
               Channel cap _ q \<Rightarrow> integer_of_nat (length q) \<ge> cap
             | HSChannel _ \<Rightarrow> False) g p)"

| "exprArith g p (ExprVarRef (VarRef gl name None)) =
     withVar' gl name None id g p"

| "exprArith g p (ExprVarRef (VarRef gl name (Some idx))) =
     withVar' gl name (Some (exprArith g p idx)) id g p"

| "exprArith g p (ExprUnOp UnOpMinus expr) = 0 - exprArith g p expr"
| "exprArith g p (ExprUnOp UnOpNeg expr) = ((exprArith g p expr) + 1) mod 2"

| "exprArith g p (ExprBinOp BinOpAdd lexpr rexpr) =
     (exprArith g p lexpr) + (exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpSub lexpr rexpr) =
     (exprArith g p lexpr) - (exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpMul lexpr rexpr) =
     (exprArith g p lexpr) * (exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpDiv lexpr rexpr) =
     (exprArith g p lexpr) div (exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpMod lexpr rexpr) =
     (exprArith g p lexpr) mod (exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpGr lexpr rexpr) =
     trivCond (exprArith g p lexpr > exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpLe lexpr rexpr) =
     trivCond (exprArith g p lexpr < exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpGEq lexpr rexpr) =
     trivCond (exprArith g p lexpr \<ge> exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpLEq lexpr rexpr) =
     trivCond (exprArith g p lexpr \<le> exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpEq lexpr rexpr) =
     trivCond (exprArith g p lexpr = exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpNEq lexpr rexpr) =
     trivCond (exprArith g p lexpr \<noteq> exprArith g p rexpr)"

| "exprArith g p (ExprBinOp BinOpAnd lexpr rexpr) =
     trivCond (exprArith g p lexpr \<noteq> 0 \<and> exprArith g p rexpr \<noteq> 0)"

| "exprArith g p (ExprBinOp BinOpOr lexpr rexpr) =
     trivCond (exprArith g p lexpr \<noteq> 0 \<or> exprArith g p rexpr \<noteq> 0)"

| "exprArith g p (ExprCond cexpr texpr fexpr) =
     (if exprArith g p cexpr \<noteq> 0 then exprArith g p texpr
      else exprArith g p fexpr)"

| "exprArith g p (ExprPoll (ChanRef (VarRef gl name None)) rs srt) =
     trivCond (withChannel' gl name None (
       \<lambda>_ c. pollCheck g p c rs srt) g p)"

| "exprArith g p (ExprPoll (ChanRef (VarRef gl name (Some idx))) rs srt) =
     trivCond (withChannel' gl name (Some (exprArith g p idx)) (
       \<lambda>_ c. pollCheck g p c rs srt) g p)"

| "pollCheck g p InvChannel _ _ =
     abort ''Channel already closed / invalid.'' (\<lambda>_. False)"
| "pollCheck g p (HSChannel _) _ _ = False"
| "pollCheck g p (Channel _ _ q) rs srt = (
     if q = [] then False
     else if \<not> srt then recvArgsCheck g p rs (hd q)
     else List.find (recvArgsCheck g p rs) q \<noteq> None)"

| "recvArgsCheck _ _ [] [] = True"
| "recvArgsCheck _ _ _  [] =
     abort ''Length mismatch on receiving.'' (\<lambda>_. False)"
| "recvArgsCheck _ _ []  _ =
     abort ''Length mismatch on receiving.'' (\<lambda>_. False)"
| "recvArgsCheck g p (r#rs) (v#vs) = ((
       case r of
          RecvArgConst c \<Rightarrow> c = v
        | RecvArgMConst c _ \<Rightarrow> c = v
        | RecvArgVar var \<Rightarrow> True
        | RecvArgEval e \<Rightarrow> exprArith g p e = v ) \<and> recvArgsCheck g p rs vs)"

text {* @{const getVar'} etc.\ do operate on name, index, \ldots directly. Lift them to use @{const VarRef} instead. *}

fun liftVar where
  "liftVar f (VarRef gl v idx) arg g p =
      f gl v (map_option (exprArith g p) idx) arg g p"

definition "getVar v = liftVar (\<lambda>gl v idx arg. getVar' gl v idx) v ()"
definition "setVar = liftVar setVar'"
definition "withVar = liftVar withVar'"

primrec withChannel
  where "withChannel (ChanRef v) = liftVar withChannel' v"

lemma setVar_gState_progress_rel:
  assumes "gState_inv prog g"
  shows "(g, fst (setVar v val g p)) \<in> gState_progress_rel prog"
unfolding setVar_def
by (cases v) (simp add: setVar'_gState_progress_rel[OF assms])

lemmas setVar_gState_inv =
  setVar_gState_progress_rel[THEN gState_progress_rel_gState_invI2]

lemma setVar_pState_inv:
  assumes "pState_inv prog p"
  shows "pState_inv prog (snd (setVar v val g p))"
unfolding setVar_def
by (cases v) (auto simp add: setVar'_pState_inv assms)

lemma setVar_cl_inv:
  assumes "cl_inv (g,p)"
  shows "cl_inv (setVar v val g p)"
unfolding setVar_def
by (cases v) (auto simp add: setVar'_cl_inv assms)

subsection {* Variable declaration *}

lemma channel_inv_code [code]:
  "channel_inv (Channel cap ts q)
  \<longleftrightarrow> cap \<le> max_array_size
    \<and> 0 \<le> cap
    \<and> for_all varType_inv ts
    \<and> length ts \<le> max_array_size
    \<and> length q \<le> max_array_size
    \<and> for_all (\<lambda>x. length x = length ts
                   \<and> for_all (\<lambda>y. y \<ge> min_var_value
                                 \<and> y \<le> max_var_value) x) q"
  "channel_inv (HSChannel ts)
  \<longleftrightarrow> for_all varType_inv ts \<and> length ts \<le> max_array_size"
  by (auto simp add: for_all_def) force+

primrec toVariable
  :: "'a gState_scheme \<Rightarrow> pState \<Rightarrow> varDecl \<Rightarrow> String.literal * variable * channels"
where
  "toVariable g p (VarDeclNum lb hb name siz init) = (
     let type = VTBounded lb hb in
     if \<not> varType_inv type then abortv ''Invalid var def (varType_inv failed): '' name
                                       (\<lambda>_. (name, Var VTChan 0, []))
     else
       let
         init = checkVarValue type (case init of
                                      None \<Rightarrow> 0
                                    | Some e \<Rightarrow> exprArith g p e);
         v = (case siz of
                None \<Rightarrow> Var type init
              | Some s \<Rightarrow> if nat_of_integer s \<le> max_array_size
                         then VArray type (nat_of_integer s)
                                          (IArray.tabulate (s, \<lambda>_. init))
                         else abortv ''Invalid var def (array too large): '' name
                                      (\<lambda>_. Var VTChan 0))
        in
           (name, v, []))"

| "toVariable g p (VarDeclChan name siz types) = (
     let
       size = (case siz of None \<Rightarrow> 1 | Some s \<Rightarrow> nat_of_integer s);
       chans = (case types of
                  None \<Rightarrow> []
                | Some (cap, tys) \<Rightarrow>
                    let C = (if cap = 0 then HSChannel tys
                             else Channel cap tys []) in
                    if \<not> channel_inv C
                    then abortv ''Invalid var def (channel_inv failed): ''
                                name (\<lambda>_. [])
                    else replicate size C);
       cidx = (case types of
                 None \<Rightarrow> 0
               | Some _ \<Rightarrow> integer_of_nat (length (channels g)));
       v = (case siz of
              None \<Rightarrow> Var VTChan cidx
            | Some s \<Rightarrow> if nat_of_integer s \<le> max_array_size
                       then VArray VTChan (nat_of_integer s)
                                          (IArray.tabulate (s,
                                             \<lambda>i. if cidx = 0 then 0
                                                 else i + cidx))
                       else abortv ''Invalid var def (array too large): ''
                                   name (\<lambda>_. Var VTChan 0))
     in
        (name, v, chans))"

lemma toVariable_variable_inv:
  assumes "gState_inv prog g"
  shows "variable_inv (fst (snd (toVariable g p v)))"
using assms
apply (cases v)
  prefer 2
  apply hypsubst_thin
  apply (auto intro!: checkVarValue_Var
              simp del: variable_inv.simps checkVarValue.simps varType_inv.simps
              split: if_splits option.splits)
      apply (auto intro!: mod_ge mod_le simp add: min_var_value_def)
    apply (simp_all add: assms gState_inv_def
               max_channels_def max_var_value_def min_var_value_def max_array_size_def)
    including integer.lifting
    apply (transfer, simp)+
done

lemma toVariable_channels_inv:
  shows "\<forall>x \<in> set (snd (snd (toVariable g p v))). channel_inv x"
by (cases v) auto

lemma toVariable_channels_inv':
  shows "toVariable g p v = (a,b,c) \<Longrightarrow> \<forall>x \<in> set c. channel_inv x"
using toVariable_channels_inv
by (metis snd_conv)

lemma toVariable_variable_inv':
  shows "gState_inv prog g \<Longrightarrow> toVariable g p v = (a,b,c) \<Longrightarrow> variable_inv b"
by (metis snd_conv fst_conv toVariable_variable_inv)

definition mkChannels
  :: "'a gState_scheme \<Rightarrow> pState \<Rightarrow> channels \<Rightarrow> 'a gState_scheme * pState"
 where
  "mkChannels g p cs = (
     if cs = [] then (g,p) else
     let l = length (channels g) in
     if l + length cs > max_channels
     then abort ''Too much channels'' (\<lambda>_.  (g,p))
     else let
            cs\<^sub>p = map integer_of_nat [l..<l + length cs];
            g' = g\<lparr>channels := channels g @ cs\<rparr>;
            p' = p\<lparr>pState.channels := pState.channels p @ cs\<^sub>p\<rparr>
          in
            (g', p'))"

lemma mkChannels_gState_progress_rel:
  "gState_inv prog g
   \<Longrightarrow> set cs \<subseteq> Collect channel_inv
   \<Longrightarrow> (g, fst (mkChannels g p cs)) \<in> gState_progress_rel prog"
unfolding mkChannels_def
by (intro gState_progress_relI)
   (auto simp add: gState_inv_def gState.defs cl_inv_def)

lemmas mkChannels_gState_inv =
  mkChannels_gState_progress_rel[THEN gState_progress_rel_gState_invI2]

lemma mkChannels_pState_inv:
  "pState_inv prog p
   \<Longrightarrow> cl_inv (g,p)
   \<Longrightarrow> pState_inv prog (snd (mkChannels g p cs))"
unfolding mkChannels_def
including integer.lifting
  apply (auto simp add: pState_inv_def pState.defs gState_inv_def dest!: cl_inv_lengthD)
    apply (transfer', simp)+
    done

lemma mkChannels_cl_inv:
  "cl_inv (g,p) \<Longrightarrow> cl_inv (mkChannels g p cs)"
unfolding mkChannels_def
by (auto simp add: pState.defs dest: cl_inv_lengthD intro!: cl_invI)

definition mkVarChannel
  :: "varDecl
      \<Rightarrow> ((var_dict \<Rightarrow> var_dict) \<Rightarrow> 'a gState_scheme * pState
         \<Rightarrow> 'a gState_scheme * pState)
      \<Rightarrow> 'a gState_scheme \<Rightarrow> pState
      \<Rightarrow> 'a gState_scheme * pState"
where
  "mkVarChannel v upd g p = (
         let
             (k,v,cs) = toVariable g p v;
             (g',p') = upd (lm.update k v) (g,p)
         in
            mkChannels g' p' cs)"

lemma mkVarChannel_gState_inv:
  assumes "gState_inv prog g"
  and "\<And>k v' cs. toVariable g p v = (k,v',cs)
                 \<Longrightarrow> gState_inv prog (fst (upd (lm.update k v') (g,p)))"
  shows "gState_inv prog (fst (mkVarChannel v upd g p))"
using assms unfolding mkVarChannel_def
by (force split: varDecl.split prod.split
          intro!: mkChannels_gState_inv
          dest: toVariable_channels_inv')

lemma mkVarChannel_gState_progress_rel:
  assumes "gState_inv prog g"
  and "\<And>k v' cs. toVariable g p v = (k,v',cs)
             \<Longrightarrow> (g, fst (upd (lm.update k v') (g,p))) \<in> gState_progress_rel prog"
  shows "(g, fst (mkVarChannel v upd g p)) \<in> gState_progress_rel prog"
proof -
  obtain k v' cs where 1: "toVariable g p v = (k,v',cs)" by (metis prod.exhaust)
  obtain g' p' where 2: "(g',p') = upd (lm.update k v') (g,p)" by (metis prod.exhaust)
  with 1 assms have *: "(g, g') \<in> gState_progress_rel prog" by (metis fst_conv)

  also from 1 2 have "(g', fst (mkChannels g' p' cs)) \<in> gState_progress_rel prog"
    by (force intro!: mkChannels_gState_progress_rel gState_progress_rel_gState_invI2[OF *]
              dest: toVariable_channels_inv')
  finally have "(g, fst (mkChannels g' p' cs)) \<in> gState_progress_rel prog" .
  thus ?thesis using 1 2 by (auto simp add: mkVarChannel_def split: prod.split)
qed

lemma mkVarChannel_pState_inv:
  assumes "pState_inv prog p"
  and "cl_inv (g,p)"
  and "\<And>k v' cs. toVariable g p v = (k,v',cs)
                  \<Longrightarrow> cl_inv (upd (lm.update k v') (g,p))"
  and "\<And>k v' cs. toVariable g p v = (k,v',cs)
                  \<Longrightarrow> pState_inv prog (snd (upd (lm.update k v') (g,p)))"
  shows "pState_inv prog (snd (mkVarChannel v upd g p))"
using assms unfolding mkVarChannel_def
by (force split: varDecl.split prod.split
          intro!: mkChannels_pState_inv)

lemma mkVarChannel_cl_inv:
  assumes "cl_inv (g,p)"
  and "\<And>k v' cs. toVariable g p v = (k,v',cs)
                 \<Longrightarrow> cl_inv (upd (lm.update k v') (g,p))"
  shows "cl_inv (mkVarChannel v upd g p)"
using assms unfolding mkVarChannel_def
by (force split: varDecl.split prod.splits
          intro!: mkChannels_cl_inv)

definition mkVarChannelProc
  :: "procVarDecl \<Rightarrow> 'a gState_scheme \<Rightarrow> pState \<Rightarrow> 'a gState_scheme * pState"
where
  "mkVarChannelProc v g p = (
     let
       v' = case v of
              ProcVarDeclNum lb hb name siz init \<Rightarrow>
                  VarDeclNum lb hb name siz init
           | ProcVarDeclChan name siz \<Rightarrow>
                 VarDeclChan name siz None;
       (k,v,cs) = toVariable g p v'
     in
       mkVarChannel v' (apsnd \<circ> pState.vars_update) g p)"

lemma mkVarChannelProc_gState_progress_rel:
  assumes "gState_inv prog g"
  shows "(g, fst (mkVarChannelProc v g p)) \<in> gState_progress_rel prog"
unfolding mkVarChannelProc_def
using assms
by (auto intro!: mkVarChannel_gState_progress_rel)

lemmas mkVarChannelProc_gState_inv =
  mkVarChannelProc_gState_progress_rel[THEN gState_progress_rel_gState_invI2]

lemma toVariable_name:
  "toVariable g p (VarDeclNum lb hb name sz init) = (x,a,b) \<Longrightarrow> x = name"
  "toVariable g p (VarDeclChan name sz t) = (x, a, b) \<Longrightarrow> x = name"
by (auto split: if_splits)

declare toVariable.simps[simp del]

lemma statesDecls_process_names:
  assumes "v \<in> statesDecls (states prog !! (pState.idx p))"
  shows "procVarDeclName v \<in> process_names (states prog !! (pState.idx p))
                                           (processes prog !! (pState.idx p))"
using assms
by (cases "processes prog !! (pState.idx p)") (auto simp add: statesNames_def)

lemma mkVarChannelProc_pState_inv:
  assumes "pState_inv prog p"
  and "gState_inv prog g"
  and "cl_inv (g, p)"
  and decl: "v \<in> statesDecls (states prog !! (pState.idx p))"
  shows "pState_inv prog (snd (mkVarChannelProc v g p))"
unfolding mkVarChannelProc_def
using assms statesDecls_process_names[OF decl]
by (auto intro!: mkVarChannel_pState_inv)
   (auto dest: toVariable_name
         split: procVarDecl.splits
         intro: toVariable_variable_inv' vardict_inv_updateI
         simp add: pState_inv_def)

lemma mkVarChannelProc_cl_inv:
  assumes "cl_inv (g,p)"
  shows "cl_inv (mkVarChannelProc v g p)"
unfolding mkVarChannelProc_def using assms
by (auto intro!: mkVarChannel_cl_inv)

subsection {* Folding *}
text {*
  Fold over lists (and lists of lists) of @{typ step}/@{typ stmnt}. The folding functions are
  doing a bit more than that, e.g.\ ensuring the offset into the program array is correct.
*}

definition step_fold' where
  "step_fold' g steps (lbls :: labels) pri pos
             (nxt :: edgeIndex) (onxt :: edgeIndex option) iB =
     foldr (\<lambda>step (pos, nxt, lbls, es).
              let (e,enxt,lbls) = g step (lbls, pri, pos, nxt, onxt, iB)
              in (pos + length e, enxt, lbls, es@e)
    ) steps (pos, nxt, lbls, [])"

definition step_fold where
  "step_fold g steps lbls pri pos nxt onxt iB = (
         let (_,nxt,lbls,s) = step_fold' g steps lbls pri pos nxt onxt iB
          in (s,nxt,lbls))"

lemma step_fold'_cong:
  assumes "lbls = lbls'"
  and "pri = pri'"
  and "pos = pos'"
  and "steps = steps'"
  and "nxt = nxt'"
  and "onxt = onxt'"
  and "iB = iB'"
  and "\<And>x d. x \<in> set steps \<Longrightarrow> g x d = g' x d"
  shows "step_fold' g steps lbls pri pos nxt onxt iB =
         step_fold' g' steps' lbls' pri' pos' nxt' onxt' iB'"
unfolding step_fold'_def
by (auto intro: foldr_cong simp add: assms)

lemma step_fold_cong[fundef_cong]:
  assumes "lbls = lbls'"
  and "pri = pri'"
  and "pos = pos'"
  and "steps = steps'"
  and "nxt = nxt'"
  and "onxt = onxt'"
  and "iB = iB'"
  and "\<And>x d. x \<in> set steps \<Longrightarrow> g x d = g' x d"
  shows "step_fold g steps lbls pri pos nxt onxt iB =
         step_fold g' steps' lbls' pri' pos' nxt' onxt' iB'"
unfolding step_fold_def
by (auto simp: assms cong: step_fold'_cong)

fun step_foldL_step where
  "step_foldL_step _ _ _ [] (pos, nxt, lbls, es, is) = (pos, nxt, lbls, es, is)"
| "step_foldL_step g pri onxt (s#steps) (pos, nxt, lbls, es, is) = (
     let (pos', nxt', lbls', ss') = step_fold' g steps lbls pri pos nxt onxt False in
     let (s', nxt'', lbls'') = g s (lbls',pri,pos',nxt',onxt,True) in
     let rs = butlast s'; s'' = last s' in
     (pos' + length rs, nxt, lbls'', es@ss'@rs, s''#is))"

definition step_foldL where
  "step_foldL g stepss lbls pri pos nxt onxt =
     foldr (step_foldL_step g pri onxt) stepss (pos,nxt,lbls,[],[])"

lemma step_foldL_step_cong:
  assumes "pri = pri'"
  and "onxt = onxt'"
  and "s = s'"
  and "d = d'"
  and "\<And>x d. x \<in> set s \<Longrightarrow> g x d = g' x d"
  shows "step_foldL_step g pri onxt s d = step_foldL_step g' pri' onxt' s' d'"
using assms
by (cases d', cases s') (simp_all cong: step_fold'_cong)

lemma step_foldL_cong[fundef_cong]:
  assumes "lbls = lbls'"
  and "pri = pri'"
  and "pos = pos'"
  and "stepss = stepss'"
  and "nxt = nxt'"
  and "onxt = onxt'"
  and "\<And>x x' d. x \<in> set stepss \<Longrightarrow> x' \<in> set x \<Longrightarrow> g x' d = g' x' d"
  shows "step_foldL g stepss lbls pri pos nxt onxt =
         step_foldL g' stepss' lbls' pri' pos' nxt' onxt'"
unfolding step_foldL_def
using assms
apply (cases stepss')
  apply simp
  apply (force intro!: foldr_cong step_foldL_step_cong)
done

subsection {* Starting processes *}
definition modProcArg
  :: "(procArg * integer) \<Rightarrow> String.literal * variable"
where
  "modProcArg x = (
     case x of
       (ProcArg ty name, val) \<Rightarrow> if varType_inv ty
                                then let init = checkVarValue ty val
                                     in (name, Var ty init)
                                else abortv ''Invalid proc arg (varType_inv failed)''
                                            name (\<lambda>_. (name, Var VTChan 0)))"

definition emptyProc :: "pState"
  -- "The empty process."
where
  "emptyProc = \<lparr>pid = 0, vars = lm.empty (), pc = 0, channels = [], idx = 0 \<rparr>"

lemma vardict_inv_empty:
  "vardict_inv ss proc (lm.empty())"
unfolding vardict_inv_def
by (simp add: lm.correct)

lemma emptyProc_cl_inv[simp]:
  "cl_inv (g, emptyProc)"
by (simp add: cl_inv_def emptyProc_def)

lemma emptyProc_pState_inv:
  assumes "program_inv prog"
  shows "pState_inv prog emptyProc"
proof -
  from assms have "IArray.length (states prog !! 0) > 0"
    by (intro program_inv_length_states) (auto simp add: program_inv_def)
  with assms show ?thesis
    unfolding pState_inv_def program_inv_def emptyProc_def
    by (auto simp add: vardict_inv_empty)
qed

fun mkProc
  :: "'a gState_scheme \<Rightarrow> pState
    \<Rightarrow> String.literal \<Rightarrow> expr list \<Rightarrow> process \<Rightarrow> nat
    \<Rightarrow> 'a gState_scheme * pState"
where
  "mkProc g p name args (sidx, start, argDecls, decls) pidN = (
     let start = case start of
                   Index x \<Rightarrow> x
                 | _ \<Rightarrow> abortv ''Process start is not index: '' name (\<lambda>_. 0)
     in
      (* sanity check *)
      if length args \<noteq> length argDecls
      then abortv ''Signature mismatch: '' name (\<lambda>_. (g,emptyProc))
      else
        let
          (* evaluate args (in the context of the calling process) *)
          eArgs = map (exprArith g p) args;

          (* replace the init part of argDecls *)
          argVars = map modProcArg (zip argDecls eArgs);

          (* add _pid to vars *)
          pidI = integer_of_nat pidN;
          argVars = (STR ''_pid'', Var (VTBounded 0 pidI) pidI)#argVars;
          argVars = lm.to_map argVars;

          (* our new process *)
          p = \<lparr> pid = pidN, vars = argVars, pc = start, channels = [], idx = sidx \<rparr>
        in
          (* apply the declarations *)
          foldl (\<lambda>(g,p) d. mkVarChannel d (apsnd \<circ> pState.vars_update) g p)
                (g,p)
                decls)"

lemma mkProc_gState_progress_rel:
  assumes "gState_inv prog g"
  shows "(g, fst (mkProc g p name args (processes prog !! sidx) pidN)) \<in>
          gState_progress_rel prog"
proof -
  obtain sidx' start argDecls decls  where
    p: "processes prog !! sidx = (sidx', start, argDecls, decls)"
    by (metis prod.exhaust)

  from assms have
    "\<And>p. (g, fst (foldl (\<lambda>(g,p) d. mkVarChannel d (apsnd \<circ> pState.vars_update) g p)
                         (g,p) decls))
          \<in> gState_progress_rel prog"
  proof (induction decls arbitrary: g p)
    case (Cons d decls)
    obtain g' p' where
      new: "(g',p') = (mkVarChannel d (apsnd \<circ> pState.vars_update) g p)"
      by (metis prod.exhaust)
    hence "g' = fst ..." by (metis fst_conv)
    with Cons.prems have "(g,g') \<in> gState_progress_rel prog"
      by (auto intro: mkVarChannel_gState_progress_rel)
    also note Cons.IH[OF this[THEN gState_progress_rel_gState_invI2], of p']
    finally show ?case by (auto simp add: o_def new)
  qed simp
  thus ?thesis using assms p by auto
qed

lemmas mkProc_gState_inv =
  mkProc_gState_progress_rel[THEN gState_progress_rel_gState_invI2]

lemma mkProc_pState_inv:
  assumes "program_inv prog"
  and "gState_inv prog g"
  and "pidN \<le> max_procs" and "pidN > 0"
  and "sidx < IArray.length (processes prog)"
  and "fst (processes prog !! sidx) = sidx"
  shows "pState_inv prog (snd (mkProc g p name args (processes prog !! sidx) pidN))"
proof -
  obtain sidx' start argDecls decls  where
    "processes prog !! sidx = (sidx', start, argDecls, decls)"
    by (metis prod.exhaust)
  with assms have
    p_def: "processes prog !! sidx = (sidx, start, argDecls, decls)"
           "IArray.list_of (processes prog) ! sidx = (sidx, start, argDecls, decls)"
    by simp_all
  with assms have "(sidx,start,argDecls,decls) \<in> set (IArray.list_of (processes prog))"
    by (force dest: nth_mem)

  with assms obtain s where s: "start = Index s" "s < IArray.length (states prog !! sidx)"
    unfolding program_inv_def by auto

  hence P_inv: "pState_inv prog \<lparr>
                   pid = pidN,
                   vars = lm.to_map
                          ((STR ''_pid'', Var (VTBounded 0 (integer_of_nat pidN))
                             (integer_of_nat pidN))
                          # map modProcArg (zip argDecls (map (exprArith g p) args))),
                   pc = s, channels = [], idx = sidx\<rparr>"
    unfolding pState_inv_def
    using assms[unfolded program_inv_def]
    including integer.lifting
    apply (simp add: p_def)
    apply (intro lm_to_map_vardict_inv)
    apply auto
              apply (simp add: max_procs_def max_var_value_def)
              apply transfer'
              apply simp
            apply transfer'
            apply simp
          apply (simp add: min_var_value_def)
          apply transfer'
          apply simp
        apply (simp add: max_var_value_def max_procs_def)
        apply transfer'
        apply simp
      apply (drule set_zip_leftD)
      apply (force simp add: modProcArg_def
                   split: procArg.splits if_splits
                   intro!: image_eqI)
    apply (clarsimp simp add: modProcArg_def
                    split: procArg.splits if_splits
                    simp del: variable_inv.simps)
    apply (intro checkVarValue_Var)
    apply assumption
    done

  from p_def have
    "varDeclName ` set decls \<subseteq>
      process_names (states prog !! sidx) (processes prog !! sidx)"
    by auto
  with `gState_inv prog g` have
    F_inv: "\<And>p. \<lbrakk> pState_inv prog p; sidx = pState.idx p; cl_inv (g,p) \<rbrakk>
                \<Longrightarrow> pState_inv prog
                   (snd (foldl (\<lambda>(g,p) d. mkVarChannel d (apsnd \<circ> pState.vars_update) g p)
                               (g,p) decls))"
  proof (induction decls arbitrary: g p)
    case (Cons d ds) hence
      decl: "varDeclName d \<in> process_names (states prog !! pState.idx p)
                                           (processes prog !! pState.idx p)"
      by simp

    obtain g' p' where
      new: "(g',p') = (mkVarChannel d (apsnd \<circ> pState.vars_update) g p)"
      by (metis prod.exhaust)
    hence p': "p' = snd ..." and g': "g' = fst ..."
      by (metis snd_conv fst_conv)+
    with Cons.prems have "pState_inv prog p'"
      apply (auto intro!: mkVarChannel_pState_inv)
      apply (simp add: pState_inv_def)
      apply (intro vardict_inv_updateI)
          apply simp
        apply (cases d)
          apply (force dest!: toVariable_name)
        apply (force dest!: toVariable_name)
      apply (intro toVariable_variable_inv')
        apply assumption+
      done
    moreover
    from p' Cons.prems have "pState.idx p' = sidx"
      by (auto simp add: mkVarChannel_def mkChannels_def split: prod.split)
    moreover
    from new Cons.prems have "cl_inv (g',p')"
      by (auto intro!: mkVarChannel_cl_inv)
    moreover
    from g' Cons.prems have "gState_inv prog g'"
      by (auto intro!: mkVarChannel_gState_inv)
    moreover
    from Cons.prems have
      "varDeclName ` set ds \<subseteq>
          process_names (states prog !! sidx) (processes prog !! sidx)"
      by simp
    ultimately
    have
      "pState_inv prog
         (snd (foldl (\<lambda>(g,p) d. mkVarChannel d (apsnd \<circ> pState.vars_update) g p)
                     (g',p') ds))"
      using Cons.IH[of p' g'] by (simp add: o_def)
    with new show ?case by (simp add: o_def)
  qed simp

  show ?thesis
    by (auto simp add: p_def s cl_inv_def
             intro: F_inv[OF P_inv])
       (blast intro: emptyProc_pState_inv assms)
qed

lemma mkProc_cl_inv:
  assumes "cl_inv (g,p)"
  shows "cl_inv (mkProc g p name args (processes prog !! sidx) pidN)"
proof -
  note IArray.sub_def [simp del]
  obtain sidx' start argDecls decls
    where [simp]: "processes prog !! sidx = (sidx', start, argDecls, decls)"
    by (metis prod.exhaust)

  have
    P_inv: "\<And>s v. cl_inv (g, \<lparr>pid = pidN, vars = v, pc = s, channels = [], idx = sidx' \<rparr>)"
    by (simp add: cl_inv_def)

  have
    "\<And>p. cl_inv(g,p) \<Longrightarrow>
         cl_inv (foldl (\<lambda>(g,p) d. mkVarChannel d (apsnd \<circ> pState.vars_update) g p)
                       (g,p) decls)"
  proof (induction decls arbitrary: g p)
    case (Cons d ds)
    obtain g' p' where
      new: "(g',p') = (mkVarChannel d (apsnd \<circ> pState.vars_update) g p)"
      by (metis prod.exhaust)
    with Cons.prems have "cl_inv (g',p')"
      by (auto intro!: mkVarChannel_cl_inv)

    from Cons.IH[OF this] new show ?case by (simp add: o_def)
  qed simp

  from this[OF P_inv] show ?thesis by auto
qed

declare mkProc.simps[simp del]

definition runProc
  :: "String.literal \<Rightarrow> expr list \<Rightarrow> program
      \<Rightarrow> 'a gState_scheme \<Rightarrow> pState
      \<Rightarrow> 'a gState_scheme * pState"
where
  "runProc name args prog g p = (
     if length (procs g) \<ge> max_procs
     then abort ''Too many processes'' (\<lambda>_. (g,p))
     else let pid = length (procs g) + 1 in
          case lm.lookup name (proc_data prog) of
            None \<Rightarrow> abortv ''No such process: '' name
                          (\<lambda>_. (g,p))
          | Some proc_idx \<Rightarrow>
               let (g', proc) = mkProc g p name args (processes prog !! proc_idx) pid
               in (g'\<lparr>procs := procs g @ [proc]\<rparr>, p))"

lemma runProc_gState_progress_rel:
  assumes "program_inv prog"
  and "gState_inv prog g"
  and "pState_inv prog p"
  and "cl_inv (g,p)"
  shows "(g, fst (runProc name args prog g p)) \<in> gState_progress_rel prog"
proof (cases "length (procs g) < max_procs")
  note IArray.sub_def [simp del]

  case True thus ?thesis
  proof (cases "lm.lookup name (proc_data prog)")
    case (Some proc_idx)
    hence *: "proc_idx < IArray.length (processes prog)"
             "fst (processes prog !! proc_idx) = proc_idx"
      using assms
      by (simp_all add: lm.correct program_inv_def)

    obtain g' p' where
      new: "(g',p') = mkProc g p name args (processes prog !! proc_idx) (length (procs g) + 1)"
      by (metis prod.exhaust)
    hence g': "g' = fst ..." and p': "p' = snd ..."
      by (metis snd_conv fst_conv)+
    from assms g' have "(g, g') \<in> gState_progress_rel prog "
      by (auto intro!: mkProc_gState_progress_rel)

    moreover
    from * assms True p' have "pState_inv prog p'"
      by (auto intro!: mkProc_pState_inv)
    moreover
    from assms new have "cl_inv (g',p')"
      by (auto intro!: mkProc_cl_inv)
    ultimately show ?thesis
      using True Some new assms
      unfolding runProc_def gState_progress_rel_def
      by (clarsimp split: prod.split)
         (auto simp add: gState_inv_def cl_inv_def)
  next
    case None with assms show ?thesis by (auto simp add: runProc_def)
  qed
next
  case False with assms show ?thesis by (auto simp add: runProc_def)
qed

lemmas runProc_gState_inv =
  runProc_gState_progress_rel[THEN gState_progress_rel_gState_invI2]

lemma runProc_pState_id:
  "snd (runProc name args prog g p) = p"
unfolding runProc_def
by (auto split: if_splits split: option.split prod.split)

lemma runProc_pState_inv:
  assumes "pState_inv prog p"
  shows "pState_inv prog (snd (runProc name args prog g p))"
by (simp add: assms runProc_pState_id)

lemma runProc_cl_inv:
  assumes "program_inv prog"
  and "gState_inv prog g"
  and "pState_inv prog p"
  and "cl_inv (g,p)"
  shows "cl_inv (runProc name args prog g p)"
proof -
  obtain g' p' where *: "runProc name args prog g p = (g',p')"
    by (metis prod.exhaust)
  with runProc_gState_progress_rel[OF assms, of name args] have
    "length (channels g) \<le> length (channels g')"
    by (simp add: gState_progress_rel_def)
  moreover from * runProc_pState_id have "p' = p" by (metis snd_conv)
  ultimately show ?thesis by (metis `cl_inv (g,p)` * cl_inv_trans)
qed

subsection {* AST to edges *}

text {* In this section, the AST is translated into the transition system. *}

text {*
  Handling atomic blocks is non-trivial. Therefore, we do this in an extra pass:
  @{term lp} and @{term hp} are the positions of the start and the end of
  the atomic block. Every edge pointing into this range is therefore marked as
  @{term Atomic}. If they are pointing somewhere else, they are set to @{term InAtomic},
  meaning: they start \emph{in} an atomic block, but leave it afterwards.
*}
definition atomize :: "nat \<Rightarrow> nat \<Rightarrow> edge list \<Rightarrow> edge list" where
  "atomize lp hp es = fold (\<lambda>e es.
     let e' = case target e of
                 LabelJump _ None \<Rightarrow>
                    (*
                       Labels are checked again later on, when they
                       are going to be resolved. Hence it is safe to say
                       'atomic' here, especially as the later algorithm
                       relies on targets in atomic blocks to be marked as such.
                    *)
                    e\<lparr> atomic := InAtomic \<rparr>
                | LabelJump _ (Some via) \<Rightarrow>
                    if lp \<le> via \<and> hp \<ge> via then e\<lparr> atomic := Atomic \<rparr>
                    else e\<lparr> atomic := InAtomic \<rparr>
                | Index p' \<Rightarrow>
                    if lp \<le> p' \<and> hp \<ge> p' then e\<lparr> atomic := Atomic \<rparr>
                    else e\<lparr> atomic := InAtomic \<rparr>
      in e'#es) es []"

fun skip -- "No-op edge"
where
  "skip (lbls, pri, pos, nxt, _) =
  ([[\<lparr>cond = ECExpr (ExprConst 1),
       effect = EEId, target = nxt, prio = pri,
       atomic = NonAtomic\<rparr>]], Index pos, lbls)"

text {*
   The AST is walked backwards. This allows to know the next state directly.

   Parameters used:
   \begin{description}
      \item[lbls] Map of Labels
      \item[pri] Current priority
      \item[pos] Current position in the array
      \item[nxt] Next state
      \item[onxt] Previous 'next state' (where to jump after a 'do')
      \item[inBlock] Needed for certain constructs to calculate the layout of the array
   \end{description}
*}

fun stepToState
  :: "step
      \<Rightarrow> (labels * integer * nat * edgeIndex * edgeIndex option * bool)
      \<Rightarrow> edge list list * edgeIndex * labels"
and stmntToState
  :: "stmnt
      \<Rightarrow> (labels * integer * nat * edgeIndex * edgeIndex option * bool)
      \<Rightarrow> edge list list * edgeIndex * labels"
where
  "stepToState (StepStmnt s None) data = stmntToState s data"
| "stepToState (StepStmnt s (Some u)) (lbls, pri, pos, nxt, onxt, _) = (
     let
        (* the 'unless' part *)
        (ues,_,lbls') = stmntToState u (lbls, pri, pos, nxt, onxt, True);
        u = last ues; ues = butlast ues;
        pos' = pos + length ues;

        (* find minimal current priority *)
        pri = min_prio u pri;

        (* the guarded part --
           priority is decreased, because there is now a new unless part with
           higher prio *)
        (ses,spos,lbls'') = stmntToState s (lbls', pri - 1, pos', nxt, onxt, False);

        (* add an edge to the unless part for each generated state *)
        ses = map (List.append u) ses
     in
        (ues@ses,spos,lbls''))"

| "stepToState (StepDecl decls) (lbls, pri, pos, nxt, onxt, _) = (
     let edgeF = \<lambda>d (lbls,pri,pos,nxt,_).
        ([[\<lparr>cond = ECTrue, effect = EEDecl d, target = nxt,
             prio = pri, atomic = NonAtomic\<rparr>]], Index pos, lbls)
     in
        step_fold edgeF decls lbls pri pos nxt onxt False)"

| "stepToState StepSkip (lbls,_,_,nxt,_) = ([],nxt,lbls)"

| "stmntToState (StmntAtomic steps) (lbls, pri, pos, nxt, onxt, inBlock) = (
    let (es,pos',lbls') = step_fold stepToState steps lbls pri pos nxt onxt inBlock in
    let es' = map (atomize pos (pos + length es)) es in
    (es', pos', lbls'))"

| "stmntToState (StmntLabeled l s) (lbls, pri, pos, d) = (
     let
         (es, pos', lbls) = stmntToState s (lbls, pri, pos, d);

         (* We don't resolve goto-chains. If the labeled stmnt returns only a jump,
            use this goto state. *)
         lpos = case pos' of Index p \<Rightarrow> p | _ \<Rightarrow> pos;
         lbls' = add_label l lbls lpos
     in
       (es, pos', lbls'))"

| "stmntToState (StmntDo stepss) (lbls, pri, pos, nxt, onxt, inBlock) = (
    let
       (*
           construct the different branches
          'nxt' in those branches points current pos (it is a loop after all)
          'onxt' then is the current 'nxt' (needed for break, f.ex.)
       *)
       (_,_,lbls,es,is) = step_foldL stepToState stepss lbls pri
                                     (pos+1) (Index pos) (Some nxt);

       (* put the branch starting points ('is') into the array *)
       es' = concat is # es
    in
      if inBlock then
           (* inside another DO or IF or UNLESS
              \<longrightarrow> append branches again, so they can be consumed *)
           (es' @ [concat is], Index pos, lbls)
      else
          (es', Index pos, lbls)
   )"

| "stmntToState (StmntIf stepss) (lbls, pri, pos, nxt, onxt, _) = (
     let (pos,_,lbls,es,is) = step_foldL stepToState stepss lbls pri pos nxt onxt
     in (es @ [concat is], Index pos, lbls))"

| "stmntToState (StmntSeq steps) (lbls, pri, pos, nxt, onxt, inBlock) =
     step_fold stepToState steps lbls pri pos nxt onxt inBlock"

| "stmntToState (StmntAssign v e) (lbls, pri, pos, nxt, _) =
   ([[\<lparr>cond = ECTrue, effect = EEAssign v e, target = nxt, prio = pri,
        atomic = NonAtomic\<rparr>]], Index pos, lbls)"

| "stmntToState (StmntAssert e) (lbls, pri, pos, nxt, _) =
   ([[\<lparr>cond = ECTrue, effect = EEAssert e, target = nxt, prio = pri,
        atomic = NonAtomic\<rparr>]], Index pos, lbls)"

| "stmntToState (StmntCond e) (lbls, pri, pos, nxt, _) =
   ([[\<lparr>cond = ECExpr e, effect = EEId, target = nxt, prio = pri,
        atomic = NonAtomic\<rparr>]], Index pos, lbls)"

| "stmntToState StmntElse (lbls, pri, pos, nxt, _) =
   ([[\<lparr>cond = ECElse, effect = EEId, target = nxt, prio = pri,
        atomic = NonAtomic \<rparr>]], Index pos, lbls)"

| "stmntToState StmntBreak (lbls,pri,_,_,Some onxt,_) =
   ([[\<lparr>cond = ECTrue, effect = EEGoto, target = onxt, prio = pri,
        atomic = NonAtomic \<rparr>]], onxt, lbls)"
| "stmntToState StmntBreak (_,_,_,_,None,_) =
   abort ''Misplaced break'' (\<lambda>_. ([],Index 0,lm.empty()))"

| "stmntToState (StmntRun n args) (lbls, pri, pos, nxt, onxt, _) =
   ([[\<lparr>cond = ECRun n, effect = EERun n args, target = nxt, prio = pri,
        atomic = NonAtomic \<rparr>]], Index pos,lbls)"

| "stmntToState (StmntGoTo l) (lbls, pri, pos, _) =
   ([[\<lparr>cond = ECTrue, effect = EEGoto, target = LabelJump l None, prio = pri,
        atomic = NonAtomic \<rparr>]], LabelJump l (Some pos), lbls)"

| "stmntToState (StmntSend v e srt) (lbls, pri, pos, nxt, _) =
   ([[\<lparr>cond = ECSend v, effect = EESend v e srt, target = nxt, prio = pri,
        atomic = NonAtomic \<rparr>]], Index pos, lbls)"

| "stmntToState (StmntRecv v r srt rem) (lbls, pri, pos, nxt, _) =
   ([[\<lparr>cond = ECRecv v r srt, effect = EERecv v r srt rem, target = nxt, prio = pri,
        atomic = NonAtomic \<rparr>]], Index pos, lbls)"

| "stmntToState StmntSkip d = skip d"

subsubsection {* Setup *}
definition endState :: "edge list" where
  -- "An extra state added to each process marking its end."
  "endState = [\<lparr> cond = ECFalse, effect = EEEnd, target = Index 0, prio = 0,
                  atomic = NonAtomic\<rparr>]"

definition resolveLabel :: "String.literal \<Rightarrow> labels \<Rightarrow> nat" where
  "resolveLabel l lbls = (
     case lm.lookup l lbls of
       None \<Rightarrow> abortv ''Unresolved label: '' l (\<lambda>_. 0)
     | Some pos \<Rightarrow> pos)"

primrec resolveLabels :: "edge list list \<Rightarrow> labels \<Rightarrow> edge list \<Rightarrow> edge list" where
  "resolveLabels _ _ [] = []"
| "resolveLabels edges lbls (e#es) = (
    let check_atomic = \<lambda>pos. fold (\<lambda>e a. a \<and> inAtomic e) (edges ! pos) True in
    case target e of
      Index _ \<Rightarrow> e
    | LabelJump l None \<Rightarrow>
         let pos = resolveLabel l lbls in
           e\<lparr>target := Index pos,
              atomic := if inAtomic e then
                           if check_atomic pos then Atomic
                           else InAtomic
                        else NonAtomic \<rparr>
     | LabelJump l (Some via) \<Rightarrow>
          let pos = resolveLabel l lbls in
            e\<lparr>target := Index pos,
               (* NB: isAtomic instead of inAtomic, cf atomize() *)
               atomic := if isAtomic e then
                            if check_atomic pos \<and> check_atomic via then Atomic
                            else InAtomic
                         else atomic e \<rparr>
   ) # (resolveLabels edges lbls es)"

definition calculatePrios :: "edge list list \<Rightarrow> (integer * edge list) list" where
  "calculatePrios ess = map (\<lambda>es. (min_prio es 0, es)) ess"

definition toStates :: "step list \<Rightarrow> states * edgeIndex * labels" where
  "toStates steps = (
    let
       (states,pos,lbls) = step_fold stepToState steps (lm.empty())
                                     0 1 (Index 0) None False;
       pos = (case pos of
                Index _ \<Rightarrow> pos
              | LabelJump l _ \<Rightarrow> Index (resolveLabel l lbls));
       states = endState # states;
       states = map (resolveLabels states lbls) states;
       states = calculatePrios states
    in
    case pos of Index s \<Rightarrow>
          if s < length states then (IArray states, pos, lbls)
          else abort ''Start index out of bounds'' (\<lambda>_. (IArray states, Index 0, lbls)))"

lemma toStates_inv:
  assumes "toStates steps = (ss,start,lbls)"
  shows "\<exists>s. start = Index s \<and> s < IArray.length ss"
    and "IArray.length ss > 0"
  using assms
  unfolding toStates_def calculatePrios_def
  by (auto split: prod.splits edgeIndex.splits if_splits)

(* returns: states * is_active * name * labels * process *)
primrec toProcess
  :: "nat \<Rightarrow> proc \<Rightarrow> states * nat * String.literal * (labels * process)"
 where
  "toProcess sidx (ProcType act name args decls steps) = (
     let
       (states, start, lbls) = toStates steps;
       act = (case act of
                None \<Rightarrow> 0
              | Some None \<Rightarrow> 1
              | Some (Some x) \<Rightarrow> nat_of_integer x)
     in
        (states, act, name, lbls, sidx, start, args, decls))"
| "toProcess sidx (Init decls steps) = (
      let (states, start, lbls) = toStates steps in
      (states, 1, STR '':init:'', lbls, sidx, start, [], decls))"

lemma toProcess_sidx:
  "toProcess sidx p = (ss,a,n,l,idx,r) \<Longrightarrow> idx = sidx"
by (cases p) (simp_all split: prod.splits)

lemma toProcess_states_nonempty:
  "toProcess sidx p = (ss,a,n,l,idx,r) \<Longrightarrow> IArray.length ss > 0"
by (cases p) (force split: prod.splits dest: toStates_inv(2))+

lemma toProcess_start:
  "toProcess sidx p = (ss,a,n,l,idx,start,r)
   \<Longrightarrow> \<exists>s. start = Index s \<and> s < IArray.length ss"
by (cases p) (force split: prod.splits dest: toStates_inv(1))+

lemma toProcess_startE:
  assumes "toProcess sidx p = (ss,a,n,l,idx,start,r)"
  obtains s where "start = Index s" "s < IArray.length ss"
  using toProcess_start[OF assms]
  by blast

text {*
  The main construction function. Takes an enriched AST and returns
  the list of LTL formulae, an initial state,
  and the program (= transition system).
*}

definition setUp :: "promela \<Rightarrow> (ltls * gState * program)" where
  "setUp prom = (
      let
       (decls, procs, ltls) = prom;
       assertVar = Var (VTBounded 0 1) 0;
       ltls = lm.to_map ltls;

       pre_procs = map (split toProcess) (List.enumerate 1 procs);

       procs = IArray ((0, Index 0, [], []) # map (\<lambda>(_,_,_,_,p). p) pre_procs);
       labels = IArray (lm.empty() # map (\<lambda>(_,_,_,l,_). l) pre_procs);
       states = IArray (IArray [(0,[])] # map (\<lambda>(s,_). s) pre_procs);
       names = IArray (STR ''invalid'' # map (\<lambda>(_,_,n,_). n) pre_procs);

       proc_data = lm.to_map (map (\<lambda>(_,_,n,_,idx,_). (n,idx)) pre_procs);

       prog = \<lparr> processes = procs, labels = labels, states = states,
                 proc_names = names, proc_data = proc_data \<rparr>;

       g = \<lparr> vars = lm.sng (STR ''__assert__'') assertVar,
              channels = [InvChannel], timeout = False, procs = [] \<rparr>;
       g' = foldl (\<lambda>g d.
                    fst (mkVarChannel d (apfst \<circ> gState.vars_update) g emptyProc)
                  ) g decls;
       g'' = foldl (\<lambda>g (_,a,name,_).
                    foldl (\<lambda>g name.
                              fst (runProc name [] prog g emptyProc)
                          ) g (replicate a name)
                   ) g' pre_procs
      in
       (ltls, g'', prog))"

lemma setUp_program_inv':
  "program_inv (snd (snd (setUp prom)))"
proof (rule program_invI)
  case goal1 show ?case by (simp add: setUp_def split: prod.split)
next
  case goal2 show ?case by (simp add: setUp_def split: prod.split)
next
  case goal3 thus ?case
    by (auto simp add: setUp_def o_def
             split: prod.splits
             dest!: toProcess_states_nonempty)
next
  case goal4 thus ?case
    unfolding setUp_def
    by (auto simp add: lm.correct o_def in_set_enumerate_eq nth_enumerate_eq
            dest!: subsetD[OF Misc.ran_map_of] toProcess_sidx
            split: prod.splits)
  (* TODO: Change name Misc.ran_map_of \<longrightarrow> ran_map_of_ss, as it collides
      with AList.ran_map_of *)
next
  case goal5 thus ?case
    apply (auto simp add: setUp_def o_def split: prod.splits)
    apply (frule toProcess_sidx)
    apply (frule toProcess_start)
    apply (auto simp: in_set_enumerate_eq nth_enumerate_eq)
    done
qed

lemma setUp_program_inv:
  assumes "setUp prom = (ltl,g,prog)"
  shows "program_inv prog"
using assms setUp_program_inv'
by (metis snd_conv)

lemma setUp_gState_inv:
  assumes "setUp prom = (ltl,g,prog)"
  shows "gState_inv prog g"
proof -
  from assms have p_INV: "program_inv prog" by (fact setUp_program_inv)

  {
    fix prog :: program
    assume *: "program_inv prog"
    let ?g = "\<lparr> vars = lm.sng (STR ''__assert__'') (Var (VTBounded 0 1) 0),
                 channels = [InvChannel], timeout = False, procs = [] \<rparr>"

    have g1: "gState_inv prog ?g"
      by (simp add: gState_inv_def max_channels_def lm_correct max_var_value_def)
    {
      fix g decls
      assume "gState_inv prog g"
      hence "gState_inv prog (foldl (\<lambda>g d.
                   fst (mkVarChannel d (apfst \<circ> gState.vars_update) g emptyProc)
                  ) g decls)"
        apply (rule foldl_rule)
        apply (intro mkVarChannel_gState_inv)
          apply simp
        apply (frule_tac g=\<sigma> in toVariable_variable_inv')
          apply assumption
        apply (auto simp add: gState_inv_def lm.correct)
        done
    }
    note g2 = this[OF g1]

    {
      fix g :: "'a gState_scheme" and pre_procs
      assume "gState_inv prog g"
      hence "gState_inv prog (foldl (\<lambda>g (_,a,name,_).
                 foldl (\<lambda>g name.
                         fst (runProc name [] prog g emptyProc)
                       ) g (replicate a name)
              ) g pre_procs)"
        apply (rule foldl_rule)
        apply (clarsimp split: prod.splits)
        apply (rule foldl_rule)
          apply (auto intro!: runProc_gState_inv emptyProc_pState_inv *)
        done
    }
    note this[OF g2]
  } note g_INV = this

  from assms p_INV show ?thesis
    unfolding setUp_def
    by (auto split: prod.splits intro!: g_INV)
qed

subsection {* Semantic Engine *}

text {*
  After constructing the transition system, we are missing the final part:
  The successor function on this system. We use SPIN-nomenclature and call it
  \emph{semantic engine}.
*}

definition "assertVar \<equiv> VarRef True (STR ''__assert__'') None"

subsubsection {* Evaluation of Edges *}

fun evalRecvArgs
  :: "recvArg list \<Rightarrow> integer list \<Rightarrow> gState\<^sub>I \<Rightarrow> pState \<Rightarrow> gState\<^sub>I * pState"
where
  "evalRecvArgs [] [] g l = (g,l)"
| "evalRecvArgs _  [] g l =
     abort ''Length mismatch on receiving.'' (\<lambda>_. (g,l))"
| "evalRecvArgs []  _ g l =
     abort ''Length mismatch on receiving.'' (\<lambda>_. (g,l))"
| "evalRecvArgs (r#rs) (v#vs) g l = (
     let (g,l) =
       case r of
          RecvArgVar var \<Rightarrow> setVar var v g l
        | _ \<Rightarrow> (g,l)
     in evalRecvArgs rs vs g l)"

primrec evalCond
  :: "edgeCond \<Rightarrow> gState\<^sub>I \<Rightarrow> pState \<Rightarrow> bool"
where
  "evalCond ECTrue _ _ \<longleftrightarrow> True"
| "evalCond ECFalse _ _ \<longleftrightarrow> False"
| "evalCond (ECExpr e) g l \<longleftrightarrow> exprArith g l e \<noteq> 0"
| "evalCond (ECRun _) g l \<longleftrightarrow> length (procs g) < 255"
| "evalCond ECElse g l \<longleftrightarrow> gState\<^sub>I.else g"
| "evalCond (ECSend v) g l \<longleftrightarrow>
     withChannel v (\<lambda>_ c.
       case c of
         Channel cap _ q \<Rightarrow> integer_of_nat (length q) < cap
       | HSChannel _ \<Rightarrow> True) g l"
| "evalCond (ECRecv v rs srt) g l \<longleftrightarrow>
     withChannel v (\<lambda>i c.
       case c of
         HSChannel _ \<Rightarrow> handshake g \<noteq> 0 \<and> recvArgsCheck g l rs (hsdata g)
       | _ \<Rightarrow> pollCheck g l c rs srt) g l"

fun evalHandshake
  :: "edgeCond \<Rightarrow> nat \<Rightarrow>  gState\<^sub>I \<Rightarrow> pState \<Rightarrow> bool"
where
  "evalHandshake (ECRecv v _ _) h g l
    \<longleftrightarrow> h = 0
     \<or> withChannel v (\<lambda>i c. case c of
                             HSChannel _ \<Rightarrow> i = h
                           | Channel _ _ _ \<Rightarrow> False) g l"
| "evalHandshake _ h _ _ \<longleftrightarrow> h = 0"

primrec evalEffect
  :: "edgeEffect \<Rightarrow> program \<Rightarrow> gState\<^sub>I \<Rightarrow> pState \<Rightarrow> gState\<^sub>I * pState"
where
  "evalEffect EEEnd _ g l = (g,l)"
| "evalEffect EEId _ g l = (g,l)"
| "evalEffect EEGoto _ g l = (g,l)"
| "evalEffect (EEAssign v e) _ g l = setVar v (exprArith g l e) g l"
| "evalEffect (EEDecl d) _ g l = mkVarChannelProc d g l"
| "evalEffect (EERun name args) prog g l = runProc name args prog g l"
| "evalEffect (EEAssert e) _ g l = (
     if exprArith g l e = 0
     then setVar assertVar 1 g l
     else (g,l))"
| "evalEffect (EESend v es srt) _ g l = withChannel v (\<lambda>i c.
     let
       ab = \<lambda>_. abort ''Length mismatch on sending.'' (\<lambda>_. (g,l));
       es = map (exprArith g l) es
     in
       if \<not> for_all (\<lambda>x. x \<ge> min_var_value \<and> x \<le> max_var_value) es
       then abort ''Invalid Channel'' (\<lambda>_. (g,l))
       else
          case c of
            Channel cap ts q \<Rightarrow>
              if length ts \<noteq> length es \<or> \<not> (length q < max_array_size)
              then ab()
              else let
                     q' = if \<not> srt then q@[es]
                          else insort es q;
                     g = gState.channels_update (\<lambda>cs.
                              cs[ i := Channel cap ts q' ]) g
                   in (g,l)
          | HSChannel ts \<Rightarrow>
              if length ts \<noteq> length es then ab()
              else (g\<lparr>hsdata := es, handshake := i\<rparr>, l)
          | InvChannel \<Rightarrow> abort ''Trying to send on invalid channel'' (\<lambda>_. (g,l))
    ) g l"
| "evalEffect (EERecv v rs srt rem) _ g l = withChannel v (\<lambda>i c.
     case c of
       Channel cap ts qs \<Rightarrow>
          if qs = [] then abort ''Recv from empty channel'' (\<lambda>_. (g,l))
          else
             let
               (q', qs') = if \<not> srt then (hd qs, tl qs)
                           else apfst the (find_remove (recvArgsCheck g l rs) qs);
               (g,l) = evalRecvArgs rs q' g l;
               g = if rem
                   then gState.channels_update (\<lambda>cs. cs[ i := Channel cap ts qs']) g
                   else g
                     (* messages are not removed -- so no need to update anything *)
             in (g,l)
      | HSChannel _ \<Rightarrow>
             let (g,l) = evalRecvArgs rs (hsdata g) g l in
             let g = g\<lparr> handshake := 0, hsdata := [] \<rparr>
             in (g,l)
      | InvChannel \<Rightarrow> abort ''Receiving on invalid channel'' (\<lambda>_. (g,l))
   ) g l"

lemma statesDecls_effect:
  assumes "ef \<in> effect ` edgeSet ss"
  and "ef = EEDecl d"
  shows "d \<in> statesDecls ss"
proof -
  from assms obtain e where "e \<in> edgeSet ss" "ef = effect e" by auto
  thus ?thesis  using assms
    unfolding statesDecls_def
    by (auto simp add: edgeDecls_def
             intro!: bexI[where x = e]
             split: edgeEffect.split)
qed

lemma evalRecvArgs_pState_inv:
  assumes "pState_inv prog p"
  shows "pState_inv prog (snd (evalRecvArgs rargs xs g p))"
  using assms
proof (induction rargs xs arbitrary: p g rule: list_induct2')
  case (4 r rs x xs) thus ?case
  proof (cases r)
    case (RecvArgVar v)
    obtain g' p' where  new: "setVar v x g p = (g',p')" by (metis prod.exhaust)
    hence "p' = snd (setVar v x g p)" by simp
    with "4" have "pState_inv prog p'" by (auto intro!: setVar_pState_inv)
    from "4.IH"[OF this] RecvArgVar new show ?thesis by simp
  qed simp_all
qed simp_all

lemma evalRecvArgs_pState_inv':
  assumes "evalRecvArgs rargs xs g p = (g', p')"
  and "pState_inv prog p"
  shows "pState_inv prog p'"
using assms evalRecvArgs_pState_inv
by (metis snd_conv)

lemma evalRecvArgs_gState_progress_rel:
  assumes "gState_inv prog g"
  shows "(g, fst (evalRecvArgs rargs xs g p)) \<in> gState_progress_rel prog"
  using assms
proof (induction rargs xs arbitrary: p g rule: list_induct2')
  case (4 r rs x xs) thus ?case
  proof (cases r)
    case (RecvArgVar v)
    obtain g' p' where new: "setVar v x g p = (g',p')" by (metis prod.exhaust)
    hence "g' = fst (setVar v x g p)" by simp
    with "4" have "(g, g') \<in> gState_progress_rel prog"
      by (auto intro!: setVar_gState_progress_rel)
    also hence "gState_inv prog g'"
      by (rule gState_progress_rel_gState_invI2)
    note "4.IH"[OF this, of p']
    finally show ?thesis using RecvArgVar new by simp
  qed simp_all
qed simp_all

lemmas evalRecvArgs_gState_inv =
  evalRecvArgs_gState_progress_rel[THEN gState_progress_rel_gState_invI2]

lemma evalRecvArgs_cl_inv:
  assumes "cl_inv (g,p)"
  shows "cl_inv (evalRecvArgs rargs xs g p)"
  using assms
proof (induction rargs xs arbitrary: p g rule: list_induct2')
  case (4 r rs x xs) thus ?case
  proof (cases r)
    case (RecvArgVar v)
    with 4 have "cl_inv (setVar v x g p)"
      by (auto intro!: setVar_cl_inv)
    with "4.IH" RecvArgVar show ?thesis
      by (auto split: prod.splits)
  qed simp_all
qed simp_all

lemma evalEffect_pState_inv:
  assumes "pState_inv prog p"
  and "gState_inv prog g"
  and "cl_inv (g,p)"
  and "e \<in> effect ` edgeSet (states prog !! pState.idx p)"
  shows "pState_inv prog (snd (evalEffect e prog g p))"
  using assms
proof (cases e)
  case (EEDecl d)
  with assms have "d \<in> statesDecls (states prog !! pState.idx p)"
    using statesDecls_effect
    by simp
  with assms EEDecl show ?thesis
    by (auto simp del: IArray.sub_def
             intro!: mkVarChannelProc_pState_inv)
next
  case (EESend c es srt)
  then obtain v where "ChanRef v = c" by (cases c) simp
  with EESend assms show ?thesis
    by (cases v) (auto simp add: withChannel'_def withVar'_def split: channel.split)
next
  case (EERecv c es srt)
  then obtain v where "ChanRef v = c" by (cases c) simp
  with EERecv assms show ?thesis
    by (cases v)
       (auto simp: withChannel'_def withVar'_def
             split: prod.splits channel.split
             dest: evalRecvArgs_pState_inv')
qed (clarsimp_all intro!: setVar_pState_inv runProc_pState_inv)

lemma evalEffect_gState_progress_rel:
  assumes "program_inv prog"
  and "gState_inv prog g"
  and "pState_inv prog p"
  and "cl_inv (g,p)"
  shows "(g, fst (evalEffect e prog g p)) \<in> gState_progress_rel prog"
using assms
proof (cases e)
  case EEAssert
  with assms show ?thesis
    by (auto intro: setVar_gState_progress_rel)
next
  case EEAssign
  with assms show ?thesis
    by (auto intro: setVar_gState_progress_rel)
next
  case EEDecl
  with assms show ?thesis
    by (auto intro: mkVarChannelProc_gState_progress_rel)
next
  case EERun
  with assms show ?thesis
    by (auto intro: runProc_gState_progress_rel)
next
  case (EESend c es srt)
  then obtain v where v: "c = ChanRef v" by (metis chanRef.exhaust)
  obtain idx where idx: "nat_of_integer (the (getVar v g p)) = idx" by blast
  note idx' = idx[symmetric, unfolded getVar_def]
  show ?thesis
  proof (cases "idx < length (gState.channels g)")
    case True
    note DEF = True EESend v idx' assms

    show ?thesis
    proof (cases "gState.channels g ! idx")
      case (Channel cap ts q)
      with True have "Channel cap ts q \<in> set (gState.channels g)"
        by (metis nth_mem)
      with assms have "channel_inv (Channel cap ts q)"
        by (auto simp add: gState_inv_def simp del: channel_inv.simps)
      with Channel DEF show ?thesis
        by (cases v)
           (auto simp add: withChannel'_def withVar'_def for_all_def
                      split: channel.split
                      intro!: gState_progress_rel_channels_update)
    next
      case HSChannel with DEF show ?thesis
        by (cases v)
           (auto simp: withChannel'_def withVar'_def gState_progress_rel_def
                       gState_inv_def
                split: channel.split)
    next
      case InvChannel with DEF show ?thesis
        by (cases v) (auto simp add: withChannel'_def withVar'_def)
    qed
  next
    case False with EESend idx' v assms show ?thesis
      by (cases v) (auto simp add: withChannel'_def withVar'_def)
  qed
next
  case (EERecv c rs srt rem)
  then obtain v where v: "c = ChanRef v" by (metis chanRef.exhaust)
  obtain idx where idx: "nat_of_integer (the (getVar v g p)) = idx" by blast
  note idx' = idx[symmetric, unfolded getVar_def]
  show ?thesis
  proof (cases "idx < length (gState.channels g)")
    case True
    note DEF = True EERecv v idx' assms
    show ?thesis
    proof (cases "gState.channels g ! idx")
      note channel_inv.simps[simp del]
      case (Channel cap ts q)
      with True have "Channel cap ts q \<in> set (gState.channels g)"
        by (metis nth_mem)
      with assms have c_inv: "channel_inv (Channel cap ts q)"
        by (auto simp add: gState_inv_def simp del: channel_inv.simps)
      moreover obtain res q' where
        "apfst the (find_remove (recvArgsCheck g p rs) q) = (res, q')"
        by (metis prod.exhaust)
      moreover hence "q' = snd (find_remove (recvArgsCheck g p rs) q)"
        by (simp add: apfst_def map_prod_def split: prod.splits)
      with find_remove_subset find_remove_length have
        "set q' \<subseteq> set q" "length q' \<le> length q"
        by (metis surjective_pairing)+
      with c_inv have "channel_inv (Channel cap ts q')"
        by (auto simp add: channel_inv.simps)
      moreover {
        assume "q \<noteq> []"
        hence "set (tl q) \<subseteq> set q" using tl_subset by auto
        with c_inv have "channel_inv (Channel cap ts (tl q))"
          by (auto simp add: channel_inv.simps)
      }
      moreover {
        fix res g' p'
        assume "evalRecvArgs rs res g p = (g',p')"
        with evalRecvArgs_gState_progress_rel assms have
          "(g,g') \<in> gState_progress_rel prog"
          by (metis fst_conv)
        hence "length (channels g) \<le> length (channels g')"
          by (simp add: gState_progress_rel_def)
      }
      ultimately show ?thesis using Channel DEF
        apply (cases v)
        apply (auto simp add: withChannel'_def withVar'_def for_all_def
                    split: channel.split prod.split
                    elim: fstE
                    intro!: evalRecvArgs_gState_progress_rel
                            gState_progress_rel_channels_update_step)
          apply force+
        done
    next
      case HSChannel
      obtain g' p' where *: "evalRecvArgs rs (hsdata g) g p = (g',p')"
        by (metis prod.exhaust)
      with assms have "(g,g') \<in> gState_progress_rel prog"
        by (auto elim!: fstE intro!: evalRecvArgs_gState_progress_rel)
      also hence "gState_inv prog g'" by blast
      hence "(g',g'\<lparr>handshake := 0, hsdata := []\<rparr>) \<in> gState_progress_rel prog"
        by (auto simp add: gState_progress_rel_def gState_inv_def)
      finally
      have "(g,g'\<lparr>handshake := 0, hsdata := []\<rparr>) \<in> gState_progress_rel prog" .
      with DEF HSChannel * show ?thesis
        by (cases v) (auto simp add: withChannel'_def withVar'_def for_all_def
                           split: channel.split prod.split)
    next
      case InvChannel with DEF show ?thesis
        by (cases v) (auto simp add: withChannel'_def withVar'_def)
    qed
  next
    case False with EERecv idx' v assms show ?thesis
      by (cases v) (auto simp add: withChannel'_def withVar'_def)
  qed
qed simp_all

lemma evalEffect_cl_inv:
  assumes "cl_inv (g,p)"
  and "program_inv prog"
  and "gState_inv prog g"
  and "pState_inv prog p"
  shows "cl_inv  (evalEffect e prog g p)"
  using assms
proof (cases e)
  case EERun with assms show ?thesis by (force intro!: runProc_cl_inv)
next
  case (EESend c es srt) then obtain v where "ChanRef v = c" by (cases c) simp
  with EESend assms show ?thesis
    by (cases v)
       (auto simp add: withChannel'_def withVar'_def split: channel.split
             intro!: cl_inv_channels_update)
next
  case (EERecv c es srt) then obtain v where "ChanRef v = c" by (cases c) simp
  with EERecv assms show ?thesis
    apply (cases v)
    apply (auto simp add: withChannel'_def withVar'_def split: channel.split prod.split
                intro!: cl_inv_channels_update)
    apply (metis evalRecvArgs_cl_inv)+
    done
qed (simp_all add: setVar_cl_inv mkVarChannelProc_cl_inv)

subsubsection {* Executable edges *}

text {*
  To find a successor global state, we first need to find all those edges which are executable
  (\ie the condition evaluates to true).
*}
type_synonym choices = "(edge * pState) list"
  -- "A choice is an executable edge and the process it belongs to."

definition getChoices :: "gState\<^sub>I \<Rightarrow> pState \<Rightarrow> edge list \<Rightarrow> choices" where
  "getChoices g p = foldl (\<lambda>E e.
      if evalHandshake (cond e) (handshake g) g p \<and> evalCond (cond e) g p
      then (e,p)#E
      else E) []"

lemma getChoices_sub_edges_fst:
  "fst ` set (getChoices g p es) \<subseteq> set es"
unfolding getChoices_def
by (rule foldl_rule_aux) auto

lemma getChoices_sub_edges:
  "(a,b) \<in> set (getChoices g p es) \<Longrightarrow> a \<in> set es"
using getChoices_sub_edges_fst
by force

lemma getChoices_p_snd:
  "snd ` set (getChoices g p es) \<subseteq> {p}"
unfolding getChoices_def
by (rule foldl_rule_aux) auto

lemma getChoices_p:
  "(a,b) \<in> set (getChoices g p es) \<Longrightarrow> b = p"
using getChoices_p_snd
by force

definition sort_by_pri where
  "sort_by_pri min_pri edges = foldl (\<lambda>es e.
      let idx = nat_of_integer (abs (prio e))
      in if idx > min_pri
         then abort ''Invalid priority'' (\<lambda>_. es)
         else let ep = e # (es ! idx) in es[idx := ep]
      ) (replicate (min_pri + 1) []) edges"

lemma sort_by_pri_edges':
  assumes "set edges \<subseteq> A"
  shows "set (sort_by_pri min_pri edges) \<subseteq> {xs. set xs \<subseteq> A}"
using assms
unfolding sort_by_pri_def
apply (rule_tac I="\<lambda>\<sigma> _. (\<forall>x \<in> set \<sigma>. set x \<subseteq> A) \<and> length \<sigma> = min_pri + 1" in foldl_rule_aux_P)
    apply simp
  apply (force dest!: subsetD[OF set_update_subset_insert]
               split: if_splits)
apply force
done

lemma sort_by_pri_edges:
  assumes "set edges \<subseteq> A"
  and "es \<in> set (sort_by_pri min_pri edges)"
  shows "set es \<subseteq> A"
using sort_by_pri_edges'[OF assms(1)] assms
by auto

lemma sort_by_pri_length:
  "length (sort_by_pri min_pri edges) = min_pri + 1"
unfolding sort_by_pri_def
by (rule foldl_rule_aux_P [where I="\<lambda>\<sigma> _. length \<sigma> = min_pri + 1"])
   simp_all

definition executable
  :: "states iarray \<Rightarrow> gState\<^sub>I \<Rightarrow> choices nres"
  -- "Find all executable edges"
 where
  "executable ss g = (
      let procs = procs g in
      nfoldli procs (\<lambda>_. True) (\<lambda>p E.
        if (exclusive g = 0 \<or> exclusive g = pid p) then do {
            let (min_pri, edges) = (ss !! pState.idx p) !! pc p;
            ASSERT(set edges \<subseteq> edgeSet (ss !! pState.idx p));

            (E',_,_) \<leftarrow>
               if min_pri = 0 then do {
                  WHILE\<^sub>T (\<lambda>(E,brk,_). E = [] \<and> brk = 0) (\<lambda> (_, _, ELSE). do {
                     let g = g\<lparr>gState\<^sub>I.else := ELSE\<rparr>;
                         E = getChoices g p edges
                     in
                         if E = [] then (
                            if \<not> ELSE then RETURN (E, 0::nat, True)
                            else RETURN (E, 1, False))
                         else RETURN (E, 1, ELSE) }) ([], 0::nat, False)
                } else do {
                  let min_pri = nat_of_integer (abs min_pri);
                  let pri_edges = sort_by_pri min_pri edges;
                  ASSERT (\<forall>es \<in> set pri_edges.
                             set es \<subseteq> edgeSet (ss !! pState.idx p));
                  let pri_edges = IArray pri_edges;

                  WHILE\<^sub>T (\<lambda>(E,pri,_). E = [] \<and> pri \<le> min_pri) (\<lambda>(_, pri, ELSE). do {
                     let es = pri_edges !! pri;
                     let g = g\<lparr>gState\<^sub>I.else := ELSE\<rparr>;
                     let E = getChoices g p es;
                     if E = [] then (
                         if \<not> ELSE then RETURN (E,pri,True)
                         else RETURN (E, pri + 1, False))
                     else RETURN (E, pri, ELSE) }) ([], 0, False)
                };
            RETURN (E'@E)
        } else RETURN E
      ) []
 )"

definition
  "while_rel1 =
          measure (\<lambda>x. if x = [] then 1 else 0)
  <*lex*> measure (\<lambda>x. if x = 0 then 1 else 0)
  <*lex*> measure (\<lambda>x. if \<not> x then 1 else 0)"

lemma wf_while_rel1:
  "wf while_rel1"
unfolding while_rel1_def
by auto

definition
  "while_rel2 mp =
          measure (\<lambda>x. if x = [] then 1 else 0)
  <*lex*> measure (\<lambda>x. (mp + 1) - x)
  <*lex*> measure (\<lambda>x. if \<not> x then 1 else 0)"

lemma wf_while_rel2:
  "wf (while_rel2 mp)"
unfolding while_rel2_def
by auto

lemma executable_edgeSet:
  assumes "gState_inv prog g"
  and "program_inv prog"
  and "ss = states prog"
  shows "executable ss g
    \<le> SPEC (\<lambda>cs. \<forall>(e,p) \<in> set cs.
                    e \<in> edgeSet (ss !! pState.idx p)
                  \<and> pState_inv prog p
                  \<and> cl_inv (g,p))"
  unfolding executable_def
  using assms
  apply (refine_rcg refine_vcg nfoldli_rule[where
              I="\<lambda>_ _ cs. \<forall>(e,p) \<in> set cs.
                              e \<in> edgeSet (ss !! pState.idx p)
                            \<and> pState_inv prog p
                            \<and> cl_inv (g,p)"])
          apply simp
        apply (rename_tac p l1 l2 \<sigma> e p')
        apply (subgoal_tac "pState_inv prog p")
          apply (clarsimp simp add: edgeSet_def pState_inv_def)[]
          apply (rule_tac x="IArray.list_of
                               (IArray.list_of (states prog) ! pState.idx p) ! pc p" in bexI)
            apply simp
          apply (force intro!: nth_mem)
        apply (force simp add: gState_inv_def)
      apply (refine_rcg refine_vcg wf_while_rel1 WHILET_rule[where
                 I="\<lambda>(cs,_,_). \<forall>(e,p) \<in> set cs.
                                  e \<in> edgeSet (ss !! pState.idx p)
                                \<and> pState_inv prog p
                                \<and> cl_inv (g,p)"
                 and R=while_rel1])
        apply (vc_solve solve: asm_rl simp add: while_rel1_def)
      apply (frule getChoices_p)
      using  getChoices_sub_edges apply (force simp add: gState_inv_def)
    using sort_by_pri_edges apply fastforce
  apply (rename_tac min_pri pri_edges)
  apply (rule_tac I="\<lambda>(cs,_,_). \<forall>(e,p) \<in> set cs.
                                  e \<in> edgeSet (ss !! pState.idx p)
                                \<and> pState_inv prog p
                                \<and> cl_inv (g,p)"
              and R="while_rel2 (nat_of_integer (abs min_pri))"
               in WHILET_rule)
        apply (simp add: wf_while_rel2)
      apply simp
    apply (refine_rcg refine_vcg)
        apply (clarsimp_all split: prod.split simp add: while_rel2_def)
      apply (metis diff_less_mono lessI)
    apply (rename_tac idx' else e p')
    apply (frule getChoices_p)
    apply (frule getChoices_sub_edges)
    apply (subgoal_tac
             "sort_by_pri (nat_of_integer \<bar>min_pri\<bar>) pri_edges ! idx'
                 \<in> set (sort_by_pri (nat_of_integer \<bar>min_pri\<bar>) pri_edges)")
      apply (auto simp add: assms gState_inv_def)[]
    apply (force simp add: sort_by_pri_length)
  apply (auto simp add: assms)
  done

lemma executable_edgeSet':
  assumes "gState_inv prog g"
  and "program_inv prog"
  shows "executable (states prog) g
  \<le> SPEC (\<lambda>cs. \<forall>(e,p) \<in> set cs.
                  e \<in> edgeSet ((states prog) !! pState.idx p)
                \<and> pState_inv prog p
                \<and> cl_inv(g,p))"
using executable_edgeSet[where ss = "states prog"] assms
by simp

schematic_lemma executable_refine:
  "RETURN (?ex s g) \<le> executable s g"
unfolding executable_def
by (refine_transfer)

concrete_definition executable_impl for s g uses executable_refine

subsubsection {* Successor calculation *}

function to\<^sub>I where
  "to\<^sub>I \<lparr> gState.vars = v, channels = ch, timeout = t, procs = p \<rparr>
     = \<lparr> gState.vars = v, channels = ch, timeout = False, procs = p,
          handshake = 0, hsdata = [], exclusive = 0, gState\<^sub>I.else = False \<rparr>"
by (metis gState.cases) (metis gState.ext_inject)
termination by lexicographic_order

function "from\<^sub>I" where
  "from\<^sub>I \<lparr> gState.vars = v, channels = ch, timeout = t, procs = p, \<dots> = m \<rparr>
       = \<lparr> gState.vars = v, channels = ch, timeout = t, procs = p \<rparr>"
by (metis gState.surjective) (metis gState.ext_inject)
termination by lexicographic_order

function reset\<^sub>I where
  "reset\<^sub>I \<lparr> gState.vars = v, channels = ch, timeout = t, procs = p,
             handshake = hs, hsdata = hsd, exclusive = _, gState\<^sub>I.else = _ \<rparr>
        = \<lparr> gState.vars = v, channels = ch, timeout = False, procs = p,
             handshake = 0, hsdata = if hs \<noteq> 0 then hsd else [], exclusive = 0,
             gState\<^sub>I.else = False \<rparr>"
by (metis (full_types)  gState\<^sub>I.surjective unit.exhaust)
   (metis gState.select_convs gState\<^sub>I.select_convs)
termination by lexicographic_order

lemma gState_inv_to\<^sub>I:
  "gState_inv prog g = gState_inv prog (to\<^sub>I g)"
by (cases g, simp add: gState_inv_def cl_inv_def)

lemma gState_inv_from\<^sub>I:
  "gState_inv prog g = gState_inv prog (from\<^sub>I g)"
by (cases g, simp add: gState_inv_def cl_inv_def)

lemma gState_inv_reset\<^sub>I:
  "gState_inv prog g = gState_inv prog (reset\<^sub>I g)"
by (cases g, simp add: gState_inv_def cl_inv_def)

lemmas gState_inv_I_simps =
  gState_inv_to\<^sub>I gState_inv_from\<^sub>I gState_inv_reset\<^sub>I

definition removeProcs
  -- "Remove ended processes, if there is no running one with a higher pid."
where
  "removeProcs ps = foldr (\<lambda>p (dead,sd,ps,dcs).
           if dead \<and> pc p = 0 then (True, True, ps, pState.channels p @ dcs)
           else (False, sd, p#ps, dcs)) ps (True, False, [], [])"

lemma removeProcs_subset':
  "set (fst (snd (snd (removeProcs ps)))) \<subseteq> set ps"
unfolding removeProcs_def
apply (subst foldr_conv_foldl)
apply (rule foldl_rule_aux_P[where I="\<lambda>(_,_,ps',_) _. set ps' \<subseteq> set ps"])
    apply simp
  apply (clarsimp split: if_splits)
    apply force
  apply (rename_tac p)
  apply (case_tac "p = x")
    apply (subst set_rev[symmetric])
    apply simp
  apply force
apply force
done

lemma removeProcs_length':
  "length (fst (snd (snd (removeProcs ps)))) \<le> length ps"
unfolding removeProcs_def
apply (subst foldr_conv_foldl)
apply (rule foldl_rule_aux_P[where
        I="\<lambda>(_,_,ps',_) ps''. length ps' + length ps'' \<le> length ps"])
    apply (auto split: if_splits)
done

lemma removeProcs_subset:
  "removeProcs ps = (dead,sd,ps',dcs) \<Longrightarrow> set ps' \<subseteq> set ps"
using removeProcs_subset'
by (metis fst_conv snd_conv)

lemma removeProcs_length:
  "removeProcs ps = (dead,sd,ps',dcs) \<Longrightarrow> length ps' \<le> length ps"
using removeProcs_length'
by (metis fst_conv snd_conv)

definition cleanChans :: "integer list \<Rightarrow> channels \<Rightarrow> channels"
  -- "Mark channels of closed processes as invalid."
where
  "cleanChans dchans cs = snd (foldl (\<lambda>(i,cs) c.
       if List.member dchans i then (i + 1, cs@[InvChannel])
       else (i + 1, cs@[c])) (0, []) cs)"

lemma cleanChans_channel_inv:
  assumes "set cs \<subseteq> Collect channel_inv"
  shows "set (cleanChans dchans cs) \<subseteq> Collect channel_inv"
using assms
unfolding cleanChans_def
apply (rule_tac foldl_rule_aux)
  apply (force split: if_splits)+
done

lemma cleanChans_length:
  "length (cleanChans dchans cs) = length cs"
unfolding cleanChans_def
by (rule foldl_rule_aux_P[where
       I="\<lambda>(_,cs') cs''. length cs' + length cs'' = length cs"])
   (force split: if_splits)+

definition checkDeadProcs :: "'a gState_scheme \<Rightarrow> 'a gState_scheme" where
  "checkDeadProcs g = (
     let (_, soDied, procs, dchans) = removeProcs (procs g) in
     if soDied then
         g\<lparr> procs := procs, channels := cleanChans dchans (channels g)\<rparr>
     else g)"

lemma checkDeadProcs_gState_progress_rel:
  assumes "gState_inv prog g"
  shows "(g, checkDeadProcs g) \<in> gState_progress_rel prog"
using assms cleanChans_length[where cs="channels g"]
      cleanChans_channel_inv[where cs="channels g"]
unfolding checkDeadProcs_def
apply (intro gState_progress_relI)
      apply assumption
    apply (clarsimp split: if_splits prod.splits)
    apply (frule removeProcs_length)
    apply (frule removeProcs_subset)
    apply (auto simp add: gState_inv_def cl_inv_def)[]
  apply (clarsimp split: if_splits prod.splits)+
done

lemma gState_progress_rel_exclusive:
  "(g, g') \<in> gState_progress_rel prog
   \<Longrightarrow> (g, g'\<lparr>exclusive := p\<rparr>) \<in> gState_progress_rel prog"
by (simp add:  gState_progress_rel_def gState_inv_def cl_inv_def)

definition applyEdge
  :: "program \<Rightarrow> edge \<Rightarrow> pState \<Rightarrow> gState\<^sub>I \<Rightarrow> gState\<^sub>I nres"
 where
  "applyEdge prog e p g = do {

         let (g',p') = evalEffect (effect e) prog g p;
         ASSERT ((g,g') \<in> gState_progress_rel prog);
         ASSERT (pState_inv prog p');
         ASSERT (cl_inv (g',p'));

         let p'' = (case target e of Index t \<Rightarrow>
                     if t < IArray.length (states prog !! pState.idx p') then p'\<lparr>pc := t\<rparr>
                     else abort ''Edge target out of bounds'' (\<lambda>_. p')
                   | _ \<Rightarrow>  abort ''Edge target not Index'' (\<lambda>_. p'));
         ASSERT (pState_inv prog p'');

         let g'' = g'\<lparr>procs := list_update (procs g') (pid p'' - 1) p''\<rparr>;
         ASSERT ((g',g'') \<in> gState_progress_rel prog);

         let g''' = (if isAtomic e \<and> handshake g'' = 0
                     then g''\<lparr> exclusive := pid p'' \<rparr>
                     else g'');
         ASSERT ((g',g''') \<in> gState_progress_rel prog);

         let g\<^sub>f = (if pc p'' = 0 then checkDeadProcs g''' else g''');
         ASSERT ((g''',g\<^sub>f) \<in> gState_progress_rel prog);
         RETURN g\<^sub>f }"

lemma applyEdge_gState_progress_rel:
  assumes "program_inv prog"
  and "gState_inv prog g"
  and "pState_inv prog p"
  and "cl_inv (g,p)"
  and "e \<in> edgeSet (states prog !! pState.idx p)"
  shows "applyEdge prog e p g \<le> SPEC (\<lambda>g'. (g,g') \<in> gState_progress_rel prog)"
using assms
unfolding applyEdge_def
apply (intro refine_vcg)

apply (force elim: fstE intro!: evalEffect_gState_progress_rel)

apply (force elim: sndE intro!: evalEffect_pState_inv)

apply (drule subst)
apply (rule evalEffect_cl_inv)
apply assumption+

apply (cases "target e")
apply (clarsimp simp add: pState_inv_def)
apply simp

apply (frule gState_progress_rel_gState_invI2)
apply (cases "target e")
  apply (clarsimp split: if_splits)
  apply (intro gState_progress_relI)
    apply assumption
    apply (auto simp add: gState_inv_def cl_inv_def
                dest!: subsetD[OF set_update_subset_insert])[]
    apply (simp add: cl_inv_def)
    apply simp
  apply (intro gState_progress_relI)
    apply assumption
    apply (auto simp add: gState_inv_def cl_inv_def
                dest!: subsetD[OF set_update_subset_insert])[]
    apply (simp add: cl_inv_def)
    apply simp
  apply (clarsimp split: if_splits)
  apply (intro gState_progress_relI)
    apply assumption
    apply (auto simp add: gState_inv_def cl_inv_def
                dest!: subsetD[OF set_update_subset_insert])[]
    apply (simp add: cl_inv_def)
    apply simp

apply (auto split: if_splits intro!: gState_progress_rel_exclusive)[]

apply (force intro!: checkDeadProcs_gState_progress_rel)

apply (blast intro!: gState_progress_rel_trans)
done

schematic_lemma applyEdge_refine:
  "RETURN (?ae prog e p g) \<le> applyEdge prog e p g"
unfolding applyEdge_def
by (refine_transfer)

concrete_definition applyEdge_impl for e p g uses applyEdge_refine

definition nexts
  :: "program \<Rightarrow> (gState \<Rightarrow> 'a) \<Rightarrow> gState \<Rightarrow> 'a ls nres"
  -- "The successor function"
where
  "nexts prog f g = (
     let
       f = f \<circ> from\<^sub>I;
       g = to\<^sub>I g
     in

        REC (\<lambda>D g. do {
          E \<leftarrow> executable (states prog) g;
          if E = [] then
            if handshake g \<noteq> 0 then
              (* HS not possible -- remove current step *)
              RETURN (ls.empty())
            else if exclusive g \<noteq> 0 then
              (* Atomic blocks -- just return current state *)
              RETURN (ls.sng (f g))
            else if \<not> timeout g then
              (* Set timeout *)
              D (g\<lparr>timeout := True\<rparr>)
            else
              (* If all else fails: stutter *)
              RETURN (ls.sng (f (reset\<^sub>I g)))
          else
             (*
              Setting the internal variables (exclusive, handshake, \<dots>) to 0
              is safe -- they are either set by the edges, or not thought
              to be used outside executable..
             *)
             let g = reset\<^sub>I g in
             nfoldli E (\<lambda>_. True) (\<lambda>(e,p) G.
                 applyEdge prog e p g \<guillemotright>= (\<lambda> g'.
                 if handshake g' \<noteq> 0 \<or> isAtomic e then do {
                    G\<^sub>R \<leftarrow> D g';
                    if ls.isEmpty G\<^sub>R \<and> handshake g' = 0 then
                       (* this only happens if the next step is a handshake, which fails
                          hence we stay at the current state *)
                       RETURN (ls.ins (f g') G)
                    else
                       RETURN (ls.union G\<^sub>R G)
                 } else RETURN (ls.ins (f g') G))) (ls.empty())
         }) g
         \<guillemotright>= (\<lambda>G. if ls.isEmpty G then RETURN (ls.sng (f g)) else RETURN G)
)"

lemma gState_progress_rel_intros:
  "(to\<^sub>I g, gI') \<in> gState_progress_rel prog
       \<Longrightarrow> (g, from\<^sub>I gI') \<in> gState_progress_rel prog"
  "(gI, gI') \<in> gState_progress_rel prog
       \<Longrightarrow> (gI, reset\<^sub>I gI') \<in> gState_progress_rel prog"
  "(to\<^sub>I g, gI') \<in> gState_progress_rel prog
       \<Longrightarrow> (to\<^sub>I g, gI'\<lparr>timeout := t\<rparr>) \<in> gState_progress_rel prog"
unfolding gState_progress_rel_def
by (cases g, cases gI', cases gI, force simp add: gState_inv_def cl_inv_def)+

lemma gState_progress_rel_step_intros:
  "(to\<^sub>I g, g') \<in> gState_progress_rel prog
      \<Longrightarrow> (reset\<^sub>I g', g'') \<in> gState_progress_rel prog
      \<Longrightarrow> (g, from\<^sub>I g'') \<in> gState_progress_rel prog"
  "(to\<^sub>I g, g') \<in> gState_progress_rel prog
      \<Longrightarrow> (reset\<^sub>I g', g'') \<in> gState_progress_rel prog
      \<Longrightarrow> (to\<^sub>I g, g'') \<in> gState_progress_rel prog"
unfolding gState_progress_rel_def
by (cases g, cases g', cases g'', force simp add: gState_inv_def cl_inv_def)+

lemma cl_inv_reset\<^sub>I:
  "cl_inv(g,p) \<Longrightarrow> cl_inv(reset\<^sub>I g, p)"
  by (cases g) (simp add: cl_inv_def)

lemmas refine_helpers =
  gState_progress_rel_intros gState_progress_rel_step_intros cl_inv_reset\<^sub>I

text {* @{const nexts} takes a postprocessing function @{term f} as argument. Hence we cannot show bluntly, that all generated results are in @{const gState_progress_rel}. Instead we have to take a detour over some generic invariant @{term I}. *}

lemma nexts_SPEC:
  assumes "\<And>g g'. (g,g') \<in> gState_progress_rel prog \<Longrightarrow> I (f g) (f g')"
  and "gState_inv prog g"
  and "program_inv prog"
  shows "nexts prog f g \<le> SPEC (\<lambda>gs. \<forall>g' \<in> ls.\<alpha> gs. I (f g) g')"
  using assms
  unfolding nexts_def
  apply (refine_rcg refine_vcg REC_rule[where
           \<Phi>="\<lambda>g'. (to\<^sub>I g,g') \<in> gState_progress_rel prog"])
    apply (simp add: gState_inv_to\<^sub>I)
  apply (rule order_trans[OF executable_edgeSet'])
      apply (drule gState_progress_rel_gState_invI2)
      apply assumption
    apply assumption
  apply (refine_rcg refine_vcg nfoldli_rule[where
             I="\<lambda>_ _ \<sigma>.  \<forall>g' \<in> ls.\<alpha> \<sigma>. I (f g) g'"]
          order_trans[OF applyEdge_gState_progress_rel])
        apply (vc_solve intro: refine_helpers solve: asm_rl simp add: ls.correct)
      apply (rule order_trans)
        apply (rprems)
        apply (vc_solve intro: refine_helpers solve: asm_rl simp add: ls.correct)
    apply (rprems)
    apply (force intro: refine_helpers)
  apply (rule order_trans)
    apply (rprems)
    apply (vc_solve intro: refine_helpers solve: asm_rl simp add: ls.correct)
  done

lemma RETURN_dRETURN:
  "RETURN f \<le> f' \<Longrightarrow> nres_of (dRETURN f) \<le> f'"
unfolding nres_of_def
by simp

lemma executable_dRETURN:
  "nres_of (dRETURN (executable_impl prog g)) \<le> executable prog g"
using executable_impl.refine
by (simp add: RETURN_dRETURN)

lemma applyEdge_dRETURN:
  "nres_of (dRETURN (applyEdge_impl prog e p g)) \<le> applyEdge prog e p g"
using applyEdge_impl.refine
by (simp add: RETURN_dRETURN)

schematic_lemma nexts_code_aux:
  "nres_of (?nexts prog f g) \<le> nexts prog f g"
  unfolding nexts_def
  by (refine_transfer the_resI executable_dRETURN applyEdge_dRETURN)

concrete_definition nexts_code for prog f g uses nexts_code_aux
prepare_code_thms nexts_code_def

subsection {* Traces *}

text {* When trying to generate a lasso, we have a problem: We only have a list of global
states. But what are the transitions to come from one to the other?

This problem shall be tackled by @{term replay}: Given two states, it generates a list of
transitions that was taken. *}

(* Give a list of edges that lead from g\<^sub>1 to g\<^sub>2 *)
definition replay :: "program \<Rightarrow> gState \<Rightarrow> gState \<Rightarrow> choices nres" where
  "replay prog g\<^sub>1 g\<^sub>2 = (
     let
       g\<^sub>1 = to\<^sub>I g\<^sub>1;
       check = \<lambda>g. from\<^sub>I g = g\<^sub>2
     in
       REC\<^sub>T (\<lambda>D g. do {
       E \<leftarrow> executable (states prog) g;
       if E = [] then
         if check g then RETURN []
         else if \<not> timeout g then D (g\<lparr>timeout := True\<rparr>)
         else abort ''Stuttering should not occur on replay''
                    (\<lambda>_. RETURN [])
       else
          let g = reset\<^sub>I g in
          nfoldli E (\<lambda>E. E = []) (\<lambda>(e,p) _.
             applyEdge prog e p g \<guillemotright>= (\<lambda>g'.
               if handshake g' \<noteq> 0 \<or> isAtomic e then do {
                 E\<^sub>R \<leftarrow> D g';
                 if E\<^sub>R = [] then
                    if check g' then RETURN [(e,p)] else RETURN []
                 else
                    RETURN ((e,p) # E\<^sub>R)
                } else if check g' then RETURN [(e,p)] else RETURN [])
             ) []
       }) g\<^sub>1
)"

lemma abort_refine[refine_transfer]:
  "nres_of (f ()) \<le> F () \<Longrightarrow> nres_of (abort s f) \<le> abort s F"
  "f() \<noteq> dSUCCEED \<Longrightarrow> abort s f \<noteq> dSUCCEED"
by auto

schematic_lemma replay_code_aux:
  "RETURN (?replay prog g\<^sub>1 g\<^sub>2) \<le> replay prog g\<^sub>1 g\<^sub>2"
unfolding replay_def applyEdge_def
by (refine_transfer the_resI executable_dRETURN)

concrete_definition replay_code for prog g\<^sub>1 g\<^sub>2 uses replay_code_aux
prepare_code_thms replay_code_def

subsubsection {* Printing of traces *}
(* Might go to another theory *)

definition procDescr
  :: "(integer \<Rightarrow> string) \<Rightarrow> program \<Rightarrow> pState \<Rightarrow> string"
where
  "procDescr f prog p = (
     let
        name = String.explode (proc_names prog !! pState.idx p);
        id = f (integer_of_nat (pid p))
     in
        name @ '' ('' @ id @ '')'')"

definition printInitial
  :: "(integer \<Rightarrow> string) \<Rightarrow> program \<Rightarrow> gState \<Rightarrow> string"
where
  "printInitial f prog g\<^sub>0 = (
       let psS = printList (procDescr f prog) (procs g\<^sub>0) [] [] ''  '' in
       ''Initially running: '' @ psS)"

abbreviation "lf \<equiv> Char Nibble0 NibbleA"

fun printConfig
  :: "(integer \<Rightarrow> string) \<Rightarrow> program \<Rightarrow> gState option \<Rightarrow> gState \<Rightarrow> string"
where
  "printConfig f prog None g\<^sub>0 = printInitial f prog g\<^sub>0"
| "printConfig f prog (Some g\<^sub>0) g\<^sub>1 = (
           let eps = replay_code prog g\<^sub>0 g\<^sub>1 in
           let print = (\<lambda>(e,p). procDescr f prog p @ '': '' @ printEdge f (pc p) e)
           in if eps = [] \<and> g\<^sub>1 = g\<^sub>0 then ''    -- stutter --''
              else printList print eps [] [] (lf#''    ''))"

subsection {* Code export *}

code_identifier
  code_module "PromelaInvariants" \<rightharpoonup> (SML) Promela
| code_module "PromelaDatastructures" \<rightharpoonup> (SML) Promela

definition "nexts_triv prog g = the_res (nexts_code prog id g)"
definition "executable_triv prog g = executable_impl (snd prog) g"
definition "apply_triv prog g ep = applyEdge_impl prog (fst ep) (snd ep) (reset\<^sub>I g)"

export_code
  preprocess setUp printProcesses printConfig nexts_triv executable_triv apply_triv
  in SML
  file "Promela.sml"

export_code
  preprocess setUp printProcesses printConfig nexts_triv executable_triv apply_triv
  checking SML

end