theory Term8
imports "../../Nominal-General/Nominal2_Atoms" "../../Nominal-General/Nominal2_Eqvt" "../../Nominal-General/Nominal2_Supp" "../Abs" "../Perm" "../Fv" "../Rsp" "../Lift" "../../Attic/Prove"
begin

atom_decl name

datatype rfoo8 =
  Foo0 "name"
| Foo1 "rbar8" "rfoo8" --"bind bv(bar) in foo"
and rbar8 =
  Bar0 "name"
| Bar1 "name" "name" "rbar8" --"bind second name in b"

primrec
  rbv8
where
  "rbv8 (Bar0 x) = {}"
| "rbv8 (Bar1 v x b) = {atom v}"

setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Term8.rfoo8") 2 *}
print_theorems

ML define_fv_alpha_export
local_setup {* snd o define_fv_alpha_export (Datatype.the_info @{theory} "Term8.rfoo8") [
  [[], [(SOME (@{term rbv8}, false), 0, 1, AlphaGen)]], [[], [(NONE, 1, 2, AlphaGen)]]]
  [(@{term "rbv8"}, 1, [[], [(0, NONE), (2, SOME @{term rbv8})]])] *}
notation
  alpha_rfoo8 ("_ \<approx>f' _" [100, 100] 100) and
  alpha_rbar8 ("_ \<approx>b' _" [100, 100] 100)
thm alpha_rfoo8_alpha_rbar8_alpha_rbv8.intros[no_vars]
thm fv_rbar8.simps fv_rfoo8_fv_rbv8.simps

inductive
  alpha8f :: "rfoo8 \<Rightarrow> rfoo8 \<Rightarrow> bool" ("_ \<approx>f _" [100, 100] 100)
and
  alpha8b :: "rbar8 \<Rightarrow> rbar8 \<Rightarrow> bool" ("_ \<approx>b _" [100, 100] 100)
and
  alpha8bv:: "rbar8 \<Rightarrow> rbar8 \<Rightarrow> bool" ("_ \<approx>bv _" [100, 100] 100)
where
  "name = namea \<Longrightarrow> Foo0 name \<approx>f Foo0 namea"
| "\<exists>pi. rbar8 \<approx>bv rbar8a \<and>
     (rbv8 rbar8, rfoo8) \<approx>gen alpha8f fv_rfoo8 pi (rbv8 rbar8a, rfoo8a) \<Longrightarrow>
  Foo1 rbar8 rfoo8 \<approx>f Foo1 rbar8a rfoo8a"
| "name = namea \<Longrightarrow> Bar0 name \<approx>b Bar0 namea"
| "\<exists>pi. name1 = name1a \<and> ({atom name2}, rbar8) \<approx>gen alpha8b fv_rbv8 pi ({atom name2a}, rbar8a) \<Longrightarrow>
  Bar1 name1 name2 rbar8 \<approx>b Bar1 name1a name2a rbar8a"
| "name = namea \<Longrightarrow> alpha8bv (Bar0 name) (Bar0 namea)"
| "({atom name2}, rbar8) \<approx>gen alpha8b fv_rbv8 pi ({atom name2a}, rbar8a) \<Longrightarrow>
   alpha8bv (Bar1 name1 name2 rbar8) (Bar1 name1a name2a rbar8a)"

lemma "(alpha8b ===> op =) rbv8 rbv8"
  apply rule
  apply (induct_tac a b rule: alpha8f_alpha8b_alpha8bv.inducts(2))
  apply (simp_all)
  done

lemma fv_rbar8_rsp_hlp: "x \<approx>b y \<Longrightarrow> fv_rbar8 x = fv_rbar8 y"
  apply (erule alpha8f_alpha8b_alpha8bv.inducts(2))
  apply (simp_all add: alpha_gen)
  apply clarify
  sorry

lemma "(alpha8b ===> op =) fv_rbar8 fv_rbar8"
  apply simp apply clarify apply (simp add: fv_rbar8_rsp_hlp)
  done

lemma "(alpha8f ===> op =) fv_rfoo8 fv_rfoo8"
  apply simp apply clarify
  apply (erule alpha8f_alpha8b_alpha8bv.inducts(1))
  apply (simp_all add: alpha_gen fv_rbar8_rsp_hlp)

done

end


section {* Abstract syntax for Hybrid CSP. *}

theory HCSP_Com
  imports  Main
"DCSequents/DCSequent"
begin

type_synonym cname = string
type_synonym time = real
type_synonym bexp = fform
type_synonym Inv = fform
type_synonym Rg = fform
type_synonym mid = "fform * fform"

datatype typeid = R | S | B

datatype proc
= "Skip"
| "Stop"
| Ass "exp" "exp"          ("_ := _" [99, 95] 94)
| Send "cname" "exp"         ("_!!_" [110,108] 100)
| Receive "cname" "exp"    ("_??_" [110,108] 100)
| Seq "proc" "mid" " proc"                   ("_; _ ; _"        [91,91,90 ] 90)
| Cond "bexp" "proc"                 ("IF _ _"   [95,94]93)
| Nondeter "typeid" "string" "bexp" "proc"                 ("NON _ _ : _ _"   [95,94]93)
| Pref   "proc" "proc"                  ("_\<rightarrow>_"   [95,94]93)
| join "proc" "proc"                   (infixr "[[" 90)
| meet "proc" "proc"                  ("_<<_" [90,90] 90)
| Par    "proc" "proc"                  (infixr "||" 89)
| Rep    "proc"                               ("_*"[91] 90)
| RepA    "proc"                              ("_***"[91] 90)
| RepN    "proc" "nat"                               ("_**_"[91,92] 90)
| Cont  "Inv" "bexp" "Rg"                ("<_&&_> : _" [95,96]94)
| Cont2  "flow" "Inv" "bexp" "Rg"                ("<_&&_&&_> : _" [95,95,96]94)
| TimeOut "proc" "time" "proc"    ("_|>_ _" [95,96,94]94)
| Interp   "proc" "proc" ("_[[>_"[95,94]94)
| empty "exp" ("empty _" [94] 94)
| addL "exp" "exp" ("addL _ _" [94,94] 94)
| delL "exp" ("delL _" [94] 94)

definition isEmpty :: "exp => fform" where
"isEmpty(e1) == (case e1 of
        (List ls) => (case ls of [] => WTrue | _ => WFalse) |
        _ => WFalse)"

definition readL :: "exp => exp" where
"readL(e1) == (case e1 of
      (List ls) => hd(ls) |
      _ => (Real 0))"

type_synonym pair = "exp * exp"

primrec map :: "pair list => exp => exp" where
"map ([]) (a) = a" |
"map (x#xs) (a) = (if (fst (x) = a) then (snd (x)) else (map (xs) (a)))"

lemma "map ([(RVar ''x'', Real 2), (RVar ''y'', RVar z)],  RVar ''x'') = (Real 2)"
apply (induct, auto)
done

lemma fact1 : "map ([(RVar ''x'', Real 2), (RVar ''y'', RVar z)]) (RVar ''z'') = RVar ''z''"
apply (induct, auto)
done

(*Expression substitution: "map" records the substitution mapping.*)
primrec substE :: "pair list => exp => exp" where
"substE (mp, (RVar x)) = map (mp, (RVar x))"  |
"substE (mp, (SVar x)) = map (mp, (SVar x))"  |
"substE (mp, (BVar x)) = map (mp, (BVar x))"  |
"substE (mp, (List x)) = List x"  |
"substE (mp, (Real m)) = map (mp, (Real m))"  |
"substE (mp, (Bool b)) = map (mp, (Bool b))"  |
"substE (mp, (String s)) = map (mp, (String s))"  |
"substE (mp, (e1 [+] e2)) = substE (mp, e1) [+] substE (mp, e2)"  |
"substE (mp, (e1 [-] e2)) = substE (mp, e1) [-] substE (mp, e2)"|
"substE (mp, (e1 [*] e2)) = substE (mp, e1) [*] substE (mp, e2)"|
"substE (mp, (e1 [**] e2)) = substE (mp, e1) [**] substE (mp, e2)"

lemma "(% x. x [+] x = RVar ''z'' [+] RVar ''z'') (RVar ''z'')"
apply auto
done

lemma "substE ([(RVar ''x'', Real 1), (RVar ''y'', RVar ''z'')], (RVar ''y'' [+] RVar ''z''))
        = RVar ''z'' [+] RVar ''z''"
apply (induct, auto)
done

(*Tip: for theory built on Pure, application is written by f(x) rather than f x as usual. *)

primrec lVarE :: "pair list => string => pair list" where
"lVarE ([],s) = []" |
"lVarE (x#xs,s) = (if (fst (x) = (RVar s)) then xs else x#lVarE(xs, s))"

primrec inExp :: "string => exp => bool" where
"inExp (s, (RVar x)) = (s=x)"  |
"inExp (s, (SVar x)) = (s=x)"  |
"inExp (s, (BVar x)) = (s=x)"  |
(*"inExp (s, (List x)) = (s=x)"  |*)
"inExp (s, (Real m)) = (False)"  |
"inExp (s, (Bool b)) = (False)"  |
"inExp (s, (String r)) = (False)"  |
"inExp (s, (e1 [+] e2)) = (inExp (s, e1) | inExp (s, e2))"  |
"inExp (s, (e1 [-] e2)) = (inExp (s, e1) | inExp (s, e2))"|
"inExp (s, (e1 [*] e2)) = (inExp (s, e1) | inExp (s, e2))"

primrec inPairL :: "pair list => string => bool" where
"inPairL ([],s) = False" |
"inPairL (x#xs,s) = (if (inExp (s, fst (x))) then True else inPairL(xs, s))"

primrec inPairR :: "pair list => string => bool" where
"inPairR ([],s) = False" |
"inPairR (x#xs,s) = (if (inExp (s, snd (x))) then True else inPairR(xs, s))"

(*Check if the quantifiers of a formula occur in mp*)
primrec inPairForm :: "pair list => fform => bool" where
 "inPairForm (mp) (WTrue) = False" |
 "inPairForm (mp) (WFalse) = False" |
 "inPairForm (mp) (e1 [=] e2) =False" |
 "inPairForm (mp) (e1 [<] e2) = False" |
 "inPairForm (mp) (e1 [>] e2) =False" |
 "inPairForm (mp) ([~]p) = (inPairForm (mp) (p))" |
 "inPairForm (mp) (p [&] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (p [|] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (p [-->] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (p [<->] q) = ((inPairForm (mp) (p)) | (inPairForm (mp) (q)))" |
 "inPairForm (mp) (WALL i p) = (inPairL (mp, i) | inPairR (mp, i) | inPairForm (mp)(p))" |
 "inPairForm (mp) (WEX i p) = (inPairL (mp, i) | inPairR (mp, i) | inPairForm (mp)(p))"

(*Formula sustitution.*)
primrec substF :: "pair list => fform => fform" where
 "substF (mp) (WTrue) = WTrue" |
 "substF (mp) (WFalse) = WFalse" |
 "substF (mp) (e1 [=] e2) = ((substE (mp, e1)) [=] (substE (mp, e2)))" |
 "substF (mp) (e1 [<] e2) = ((substE (mp, e1)) [<] (substE (mp, e2)))" |
 "substF (mp) (e1 [>] e2) = (substE (mp, e1) [>] substE (mp, e2))" |
 "substF (mp) ([~]p) = ([~](substF (mp) (p)))" |
 "substF (mp) (p [&] q) = ((substF (mp) (p)) [&] (substF (mp) (q)))" |
 "substF (mp) (p [|] q) = ((substF (mp) (p)) [|] (substF (mp) (q)))" |
 "substF (mp) (p [-->] q) = ((substF (mp) (p)) [-->] (substF (mp) (q)))" |
 "substF (mp) (p [<->] q) = ((substF (mp) (p)) [<->] (substF (mp) (q)))" |
 "substF (mp) (WALL i p) = (if ((~inPairL (mp, i)) & (~inPairR (mp, i))) then (WALL i (substF (mp)(p)))
                           else WFalse)" |
 "substF (mp) (WEX i p) = (if ((~inPairL (mp, i)) & (~inPairR (mp, i))) then (WEX i (substF (mp)(p)))
                           else WFalse)"

lemma allEX : "substF([(RVar ''x'', RVar ''m''), (RVar ''y'', RVar ''z'')],
                 ((RVar ''x'')[=]Real 2) [&] (WALL ''w'' ((RVar ''w'') [>] (RVar ''z''))))
             = (((RVar ''m'')[=]Real 2) [&] (WALL ''w'' ((RVar ''w'') [>] (RVar ''z''))))"
apply auto
done

lemma fact : "substF ([(RVar ''x'', Real 2), (RVar ''y'', RVar ''z'')]) (RVar ''x'' [>] Real 1) = (Real 2 [>] Real 1)"
apply (induct, auto)
done

end


section \<open> Semantics of State Machines \<close>

theory RoboChart_StateMachine
  imports "RoboChart_AST" "RoboChart_Semantic_Processors"
begin

subsection \<open> Semantic AST \<close>

text \<open> The following types represent state machines that have been supplied with typed contextual
  information. Predicates, actions, and expressions have all been enriched with type data, which
  is carried using the type parameters. \<close>

datatype ('pred, 'act, 'prob) STransition =
  STransition (tn_source: ID) (tn_target: ID) (tn_trigger: "'act option")
              (tn_probability: "'prob option") (tn_cond: "'pred option") (tn_act: "'act option")

datatype ('pred, 'act, 'prob) SNode =
  SNode (n_name: ID) (n_entry: "'act option") (n_during: "'act option") (n_exit: "'act option")
        (n_nodes: "('pred, 'act, 'prob) SNode list") (n_transitions: "('pred, 'act, 'prob) STransition list")

datatype ('pred, 'act, 'prob) SStateMachine =
  SStateMachine (sm_initial: "ID") (sm_finals: "ID list")
                (sm_nodes: "('pred, 'act, 'prob) SNode list")
                (sm_transitions: "('pred, 'act, 'prob) STransition list")

notation sm_initial ("Init\<index>")
notation sm_finals ("Finals\<index>")
notation sm_nodes ("Nodes\<index>")
notation sm_transitions ("\<^bold>T\<index>")

named_theorems sm_defs

subsection \<open> Query Functions \<close>

definition sm_node_names :: "('pred, 'act, 'prob) SStateMachine \<Rightarrow> String.literal set" ("Nnames\<index>") where
"sm_node_names sm \<equiv> n_name ` set(sm_nodes sm)"

definition sm_inters :: "('pred, 'act, 'prob) SStateMachine \<Rightarrow> ('pred, 'act, 'prob) SNode list" where
[sm_defs]: "sm_inters sm = filter (\<lambda> n. n_name n \<notin> set(sm_finals sm)) (sm_nodes sm)"

definition sm_inter_names ("Inames\<index>") where
"sm_inter_names sm \<equiv> n_name ` set (sm_inters sm)"

abbreviation sm_final_names ("Fnames\<index>") where
"sm_final_names M \<equiv> set (Finals\<^bsub>M\<^esub>)"

definition sm_node_map ::
  "('pred, 'act, 'prob) SStateMachine \<Rightarrow> (ID \<rightharpoonup> ('pred, 'act, 'prob) SNode)" ("Nmap\<index>") where
"sm_node_map M = map_of (map (\<lambda> n. (n_name n, n)) (sm_nodes M))"

definition sm_trans_map ::
  "('pred, 'act, 'prob) SStateMachine \<Rightarrow> (ID \<rightharpoonup> ('pred, 'act, 'prob) STransition list)" ("Tmap\<index>") where
[sm_defs]: "sm_trans_map M = map_of (map (\<lambda> n. (n_name n, filter (\<lambda> t. tn_source t = n_name n) (sm_transitions M))) (sm_nodes M))"

lemma dom_sm_node_map: "dom(Nmap\<^bsub>M\<^esub>) = Nnames\<^bsub>M\<^esub>"
  using image_iff by (force simp add: sm_node_map_def sm_node_names_def dom_map_of_conv_image_fst)

lemma dom_sm_trans_map: "dom(Tmap\<^bsub>M\<^esub>) = Nnames\<^bsub>M\<^esub>"
  using image_iff by (force simp add: sm_trans_map_def sm_node_names_def dom_map_of_conv_image_fst)

lemma nnames_finite: "finite(Nnames\<^bsub>M\<^esub>)"
  by (force simp add: sm_node_names_def)

abbreviation sm_init_node ::
  "('pred, 'act, 'prob) SStateMachine \<Rightarrow> ('pred, 'act, 'prob) SNode" ("Ninit\<index>") where
"sm_init_node M \<equiv> the (sm_node_map M (sm_initial M))"

subsection \<open> Well-formedness \<close>

locale WfStateMachine =
  fixes M :: "('pred, 'act, 'prob) SStateMachine" (structure)
  \<comment> \<open> The list of nnames is a set \<close>
  assumes nnames_distinct: "distinct (map n_name Nodes)"
  and init_is_state: "Init \<in> Nnames"
  and init_not_final: "Init \<notin> Fnames"
  and trans_wf: " \<And> t. t \<in> set(\<^bold>T) \<Longrightarrow> tn_source t \<in> Inames \<and> tn_target t \<in> Nnames"
begin
  lemma init_is_inter: "Init \<in> Inames"
    using init_is_state init_not_final by (auto simp add: sm_inters_def sm_inter_names_def sm_node_names_def)

  lemma nmap_init: "Nmap Init = Some Ninit"
    by (metis domIff dom_sm_node_map init_is_state option.exhaust_sel)

  lemma n_name_init: "n_name Ninit = Init"
  proof (simp add: sm_node_map_def)
    have "map_of (map (\<lambda>n. (n_name n, n)) Nodes) Init = Some (the (map_of (map (\<lambda>n. (n_name n, n)) Nodes) Init))"
      by (metis (no_types) nmap_init sm_node_map_def)
    then show "n_name (the (map_of (map (\<lambda>n. (n_name n, n)) Nodes) Init)) = Init"
      using map_of_SomeD by force
  qed

  lemma nmap_name:
    assumes "n \<in> set Nodes"
    shows "Nmap (n_name n) = Some n"
  proof -
    have "distinct (map fst (map (\<lambda>n. (n_name n, n)) Nodes))"
      by (simp add: comp_def nnames_distinct)
    with assms show ?thesis
      by (simp add: sm_node_map_def)
  qed

  lemma ninit_is_node: "Ninit \<in> set Nodes"
    using init_is_state nmap_name by (auto simp add: sm_node_names_def)

  lemma tmap_node_in_trans:
    assumes "n \<in> Nnames" "ts \<in> ran(Tmap)"
    shows "set(ts) \<subseteq> set(\<^bold>T)"
    using assms by (auto simp add: sm_trans_map_def ran_distinct nnames_distinct comp_def)

  lemma node_tran_exists:
    assumes "n \<in> Nnames" "t \<in> set(the(Tmap n))"
    shows "t \<in> set(\<^bold>T)"
    by (metis (mono_tags, opaque_lifting) assms(1) assms(2) domIff dom_sm_trans_map in_mono init_is_state option.collapse ranI tmap_node_in_trans)

end

method check_machine uses defs =
  (unfold_locales,
   simp_all add: defs sm_node_names_def sm_inter_names_def sm_inters_def, safe, simp_all)

subsection \<open> Compilation of Semantic State Machines \<close>

abbreviation "parse_opt_term ctx u \<equiv> mk_option (map_option (parse_term ctx) u)"

definition compile_Transition :: "Proof.context \<Rightarrow> RCTypes \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> Transition \<Rightarrow> term \<times> term list" where
"compile_Transition ctx rsp pT aT prbT t =
 (let from_term = mk_literal (from t);
      to_term = mk_literal (to t);
      trig_term = parse_opt_term (Config.put Syntax.root (action_syn rsp) ctx) (trigger t);
      prob_term = parse_opt_term (Config.put Syntax.root (prob_syn rsp) ctx) (probability t);
      cond_term = parse_opt_term (Config.put Syntax.root (pred_syn rsp) ctx) (condition t);
      act_term = parse_opt_term (Config.put Syntax.root (action_syn rsp) ctx) (action t)
  in
  (mk_equals
      (Free (ident t) (Type @{type_name STransition} [pT, aT, prbT]))
      (const @{const_name STransition} $ from_term $ to_term $ trig_term $ prob_term $ cond_term $ act_term)
  ,[const @{const_name Pure.eq}
      $ (const @{const_name tn_source} $ free (ident t))
      $ from_term
   ,const @{const_name Pure.eq}
      $ (const @{const_name tn_target} $ free (ident t))
      $ to_term
   ,const @{const_name Pure.eq}
      $ (const @{const_name tn_trigger} $ free (ident t))
      $ trig_term
   ,const @{const_name Pure.eq}
      $ (const @{const_name tn_probability} $ free (ident t))
      $ prob_term
   ,const @{const_name Pure.eq}
      $ (const @{const_name tn_cond} $ free (ident t))
      $ cond_term
   ,const @{const_name Pure.eq}
      $ (const @{const_name tn_act} $ free (ident t))
      $ act_term
   ]))"

fun compile_Map :: "(term \<times> term) list \<Rightarrow> term" where
"compile_Map [] = const @{const_name Map.empty}" |
"compile_Map ((k, v) # m) = const @{const_name fun_upd} $ compile_Map m $ k $ (const @{const_name Some} $ v)"

text \<open> Compile a mapping from states to lists of outgoing transitions \<close>

definition compile_Tmap :: "Node list \<Rightarrow> Transition list \<Rightarrow> term" where
"compile_Tmap nds ts =
    (let ns = map sname nds
     in compile_Map (map (\<lambda> n. (mk_literal n, mk_list dummyT (map (free \<circ> ident) (filter (\<lambda> t. from t = n) ts)))) ns))"

definition "basic_Node n = SNode n None None None [] []"

lemma name_basic_Node [simp]: "n_name (basic_Node n) = n"
  by (simp add: basic_Node_def)

lemma entry_basic_Node [simp]: "n_entry (basic_Node n) = None"
  by (simp add: basic_Node_def)

lemma during_basic_Node [simp]: "n_during (basic_Node n) = None"
  by (simp add: basic_Node_def)

lemma exit_basic_Node [simp]: "n_exit (basic_Node n) = None"
  by (simp add: basic_Node_def)

definition get_Entry :: "Action list \<Rightarrow> uterm option" where
"get_Entry acts = map_option act (find is_Entry acts)"

definition get_During :: "Action list \<Rightarrow> uterm option" where
"get_During acts = map_option act (find is_During acts)"

definition get_Exit :: "Action list \<Rightarrow> uterm option" where
"get_Exit acts = map_option act (find is_Exit acts)"

definition "null_Node_act_thms n =
[const @{const_name Pure.eq}
      $ (const @{const_name n_entry} $ free n)
      $ mk_None
   ,const @{const_name Pure.eq}
      $ (const @{const_name n_during} $ free n)
      $ mk_None
   ,const @{const_name Pure.eq}
      $ (const @{const_name n_exit} $ free n)
      $ mk_None]"

fun compile_Node :: "Proof.context \<Rightarrow> RCTypes \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> Node \<Rightarrow> term \<times> term list" where
"compile_Node ctx rsp prT actT prbT (Initial n) =
  (const @{const_name basic_Node} $ mk_literal n, null_Node_act_thms n)" |
"compile_Node ctx rsp prT actT prbT (Final n) =
  (const @{const_name basic_Node} $ mk_literal n, null_Node_act_thms n)" |
"compile_Node ctx rsp prT actT prbT (Junction n) =
  (const @{const_name basic_Node} $ mk_literal n, null_Node_act_thms n)" |
"compile_Node ctx rsp prT actT prbT (ProbabilisticJunction n) =
  (const @{const_name basic_Node} $ mk_literal n, null_Node_act_thms n)" |
"compile_Node ctx rsp prT actT prbT (State n ns ts acts) =
 (let entry_term = parse_opt_term (Config.put Syntax.root (action_syn rsp) ctx) (get_Entry acts);
      during_term = parse_opt_term (Config.put Syntax.root (action_syn rsp) ctx) (get_During acts);
      exit_term = parse_opt_term (Config.put Syntax.root (action_syn rsp) ctx) (get_Exit acts)
  in
  (
  const @{const_name SNode}
  $ mk_literal n
  $ entry_term
  $ during_term
  $ exit_term
  $ mk_list dummyT []
  $ mk_list dummyT []
  ,[const @{const_name Pure.eq}
      $ (const @{const_name n_entry} $ free n)
      $ entry_term
   ,const @{const_name Pure.eq}
      $ (const @{const_name n_during} $ free n)
      $ during_term
   ,const @{const_name Pure.eq}
      $ (const @{const_name n_exit} $ free n)
      $ exit_term]
  ))" (* (map (compile_Node ctx rsp prT actT prbT) ns) / (map (compile_Transition ctx rsp) ts *)

(* FIXME: How to deal with nested transitions and nodes? *)

definition compile_Node_name_thm :: "Proof.context \<Rightarrow> Node \<Rightarrow> term" where
"compile_Node_name_thm ctx node
  = const @{const_name Pure.eq}
      $ (const @{const_name n_name} $ free (sname node))
      $ (mk_literal (sname node))"

definition compile_Node_defn :: "Proof.context \<Rightarrow> RCTypes \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> Node \<Rightarrow> term \<times> term list" where
"compile_Node_defn ctx rsp prT actT prbT node
  = (let (nd, nthms) = compile_Node ctx rsp prT actT prbT node
     in (mk_equals (Free (sname node) (Type @{type_name SNode} [prT, actT, prbT])) nd
        , compile_Node_name_thm ctx node # nthms))"

definition get_Initial :: "Node list \<Rightarrow> ID" where
"get_Initial ns = sname (the (find is_Initial ns))"

definition get_Finals :: "Node list \<Rightarrow> ID list" where
"get_Finals ns = map sname (filter is_Final ns)"

definition get_Inters :: "Node list \<Rightarrow> ID list" where
"get_Inters ns = map sname (filter (Not \<circ> is_Final) ns)"

definition "machineN = STR ''machine''"

term sm_transitions

definition compile_StateMachineDef ::
  "Proof.context \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> typ \<Rightarrow> StateMachineDef \<Rightarrow> term \<times> term list" where
"compile_StateMachineDef ctx prT actT prbT sm =
  (let init_term = mk_literal (get_Initial (nodes sm));
       finals_term = mk_list dummyT (map mk_literal (get_Finals (nodes sm)));
       inters_term = mk_list dummyT (map free (get_Inters (nodes sm)));
       nodes_term = mk_list dummyT (map (free \<circ> sname) (nodes sm));
       trans_term = mk_list dummyT (map (free \<circ> ident) (transitions sm))
   in
   (
   mk_equals
      (Free machineN (Type @{type_name SStateMachine} [prT, actT, prbT]))
      (const @{const_name SStateMachine} $ init_term $ finals_term $ nodes_term $ trans_term)
   , [const @{const_name Pure.eq}
      $ (const @{const_name sm_initial} $ free machineN)
      $ init_term,
      const @{const_name Pure.eq}
      $ (const @{const_name sm_nodes} $ free machineN)
      $ nodes_term,
      const @{const_name Pure.eq}
      $ (const @{const_name sm_inters} $ free machineN)
      $ inters_term,
      const @{const_name Pure.eq}
      $ (const @{const_name sm_finals} $ free machineN)
      $ finals_term,
      const @{const_name Pure.eq}
      $ (const @{const_name sm_transitions} $ free machineN)
      $ trans_term,
      const @{const_name Pure.eq}
      $ (const @{const_name sm_trans_map} $ free machineN)
      $ compile_Tmap (nodes sm) (transitions sm)]
   ))"

code_reflect RC_Stm
  functions
    compile_Transition
    compile_Node
    compile_Node_defn
    compile_Node_name_thm
    compile_StateMachineDef

end


theory Proof_6_2
  imports Proofs_6 Extra2
begin

theorem proof_6_2: "VC2 inv6 env s0 user_value pressure_value"
  apply(simp only: VC2_def inv6_def R6_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply(rule allI)
   apply(rule impI)
  subgoal premises prems for s1
    using prems(2) apply (simp split: if_splits)
    using prems(1) apply simp
    using substate_refl apply presburger
    using prems(1) by blast
  apply(simp only: extraInv_def[symmetric])
  using extra2 VC2_def by auto

end


theory CodeFlattening
  imports ByteCode "../07TailCall/TailCall"
begin

primrec flatten_return :: "tco_return \<Rightarrow> byte_code" where
  "flatten_return TCOReturn = BReturn"
| "flatten_return TCOJump = BJump"

fun flatten_code' :: "nat \<Rightarrow> tco_code list \<Rightarrow> tco_return \<Rightarrow> byte_code list" where
  "flatten_code' lib [] r = [flatten_return r]"
| "flatten_code' lib (TCOLookup x # cd) r = flatten_code' lib cd r @ [BLookup x]"
| "flatten_code' lib (TCOPushCon k # cd) r = flatten_code' lib cd r @ [BPushCon k]"
| "flatten_code' lib (TCOPushLam cd' r' # cd) r = (
    let clo = flatten_code' lib cd' r'
    in clo @ flatten_code' (lib + length clo) cd r @ [BPushLam (lib + length clo)])"
| "flatten_code' lib (TCOApply # cd) r = flatten_code' lib cd r @ [BApply]"

primrec flatten_code :: "tco_code list \<times> tco_return \<Rightarrow> byte_code list" where
  "flatten_code (cd, r) = flatten_code' 0 cd r"

primrec unflatten_return :: "byte_code list \<Rightarrow> nat \<Rightarrow> tco_return" where
  "unflatten_return cd 0 = undefined"
| "unflatten_return cd (Suc pc) = (case lookup cd pc of
      Some BReturn \<Rightarrow> TCOReturn
    | Some BJump \<Rightarrow> TCOJump
    | Some op \<Rightarrow> unflatten_return cd pc
    | None \<Rightarrow> undefined)"

fun unflatten_code :: "byte_code list \<Rightarrow> nat \<Rightarrow> tco_code list" where
  "unflatten_code cd 0 = []"
| "unflatten_code cd (Suc pc) = (case lookup cd pc of
      Some (BLookup x) \<Rightarrow> TCOLookup x # unflatten_code cd pc
    | Some (BPushCon k) \<Rightarrow>  TCOPushCon k # unflatten_code cd pc
    | Some (BPushLam pc') \<Rightarrow> (
        if pc' \<le> pc
        then TCOPushLam (unflatten_code cd pc') (unflatten_return cd pc') # unflatten_code cd pc
        else undefined)
    | Some BApply \<Rightarrow> TCOApply # unflatten_code cd pc
    | Some BReturn \<Rightarrow> []
    | Some BJump \<Rightarrow> []
    | None \<Rightarrow> undefined)"

primrec unflatten_closure :: "byte_code list \<Rightarrow> bclosure \<Rightarrow> tco_closure" where
  "unflatten_closure cd (BConst k) = TCOConst k"
| "unflatten_closure cd (BLam vs pc) =
    TCOLam (map (unflatten_closure cd) vs) (unflatten_code cd pc) (unflatten_return cd pc)"

abbreviation ufcs :: "byte_code list \<Rightarrow> bclosure list \<Rightarrow> tco_closure list" where
  "ufcs cd vs \<equiv> map (unflatten_closure cd) vs"

primrec ufsf :: "byte_code list \<Rightarrow> (bclosure list \<times> nat) \<Rightarrow> tco_stack_frame" where
  "ufsf cd (vs, pc) = (ufcs cd vs, unflatten_code cd pc, unflatten_return cd pc)"

abbreviation ufsfs :: "byte_code list \<Rightarrow> (bclosure list \<times> nat) list \<Rightarrow> tco_stack_frame list" where
  "ufsfs cd pcs \<equiv> map (ufsf cd) pcs"

primrec unflatten_state :: "byte_code list \<Rightarrow> byte_code_state \<Rightarrow> tco_code_state" where
  "unflatten_state cd (BS vs sfs) = TCOS (ufcs cd vs) (ufsfs cd sfs)"

primrec code_size :: "tco_code \<Rightarrow> nat"
    and code_list_size :: "tco_code list \<Rightarrow> nat" where
  "code_size (TCOLookup x) = 1"
| "code_size (TCOPushCon k) = 1"
| "code_size (TCOPushLam cd r) = Suc (code_list_size cd)"
| "code_size TCOApply = 1"
| "code_list_size [] = 1"
| "code_list_size (c # cd) = code_size c + code_list_size cd"

fun ordered :: "byte_code \<Rightarrow> nat \<Rightarrow> bool" where
  "ordered (BPushLam pc) n = (0 < pc \<and> pc \<le> n)"
| "ordered _ n = True"

primrec ordered_closure :: "bclosure \<Rightarrow> nat \<Rightarrow> bool"
    and ordered_closures :: "bclosure list \<Rightarrow> nat \<Rightarrow> bool" where
  "ordered_closure (BConst k) n = True"
| "ordered_closure (BLam vs pc) n = (0 < pc \<and> pc \<le> n \<and> ordered_closures vs n)"
| "ordered_closures [] n = True"
| "ordered_closures (v # vs) n = (ordered_closure v n \<and> ordered_closures vs n)"

primrec orderly :: "byte_code list \<Rightarrow> nat \<Rightarrow> bool" where
  "orderly [] n = True"
| "orderly (op # cd) n = (ordered op n \<and> orderly cd (Suc n))"

primrec return_terminated :: "byte_code list \<Rightarrow> bool" where
  "return_terminated [] = False"
| "return_terminated (op # cd) = (op = BReturn \<or> op = BJump)"

fun orderly_stack :: "(bclosure list \<times> nat) list \<Rightarrow> nat \<Rightarrow> bool" where
  "orderly_stack [] cd = True"
| "orderly_stack ((env, 0) # sfs) cd = False"
| "orderly_stack ((env, Suc pc) # sfs) cd =
    (pc < cd \<and> ordered_closures env cd \<and> orderly_stack sfs cd)"

primrec orderly_state :: "byte_code list \<Rightarrow> byte_code_state \<Rightarrow> bool" where
  "orderly_state cd (BS vs sfs) = (orderly cd 0 \<and> return_terminated cd \<and>
    orderly_stack sfs (length cd) \<and> ordered_closures vs (length cd))"

lemma flatten_length [simp]: "length (flatten_code' lib cd r) = code_list_size cd"
  by (induction lib cd r rule: flatten_code'.induct) simp_all

lemma [simp]: "Suc 0 \<le> code_list_size cd"
  by (induction cd) simp_all

lemma [simp]: "0 < code_list_size cd"
  by (induction cd) simp_all

lemma [simp]: "code_list_size cd \<noteq> 0"
  by (induction cd) simp_all

lemma [simp]: "flatten_code' lib cd r \<noteq> []"
  by (induction lib cd r rule: flatten_code'.induct) simp_all

lemma [simp]: "flatten_code cdr \<noteq> []"
  by (cases cdr) (simp add: flatten_code_def)

lemma [simp]: "cd \<noteq> [] \<Longrightarrow> return_terminated (cd @ cd') = return_terminated cd"
  by (induction cd) simp_all

lemma [simp]: "flatten_return r = BReturn \<or> flatten_return r = BJump"
  by (induction r) simp_all

lemma [simp]: "return_terminated (flatten_code' lib cd r)"
  by (induction lib cd r rule: flatten_code'.induct) simp_all

lemma [simp]: "return_terminated (flatten_code cdr)"
  by (cases cdr) (simp add: flatten_code_def)

lemma [simp]: "ordered op x \<Longrightarrow> ordered op (Suc x)"
  by (induction op) simp_all

lemma [simp]: "ordered op (x + n) \<Longrightarrow> ordered op (x + (m + n))"
  by (induction op) simp_all

lemma [simp]: "orderly (cd @ cd') n = (orderly cd n \<and> orderly cd' (length cd + n))"
  by (induction cd arbitrary: n) simp_all

lemma [simp]: "ordered (flatten_return r) n"
  by (induction r) simp_all

lemma [simp]: "lib \<le> n \<Longrightarrow> orderly (flatten_code' lib cd r) n"
  by (induction lib cd r arbitrary: n rule: flatten_code'.induct) simp_all

lemma [simp]: "orderly (flatten_code cdr) 0"
  by (cases cdr) (simp add: flatten_code_def)

lemma [simp]: "x > 0 \<Longrightarrow> orderly_stack [([], x)] x"
  by (cases x) simp_all

lemma [simp]: "orderly_stack [([], length (flatten_code cdr))] (length (flatten_code cdr))"
  by (cases cdr) simp_all

lemma [simp]: "lookup vs x = Some v \<Longrightarrow> ordered_closures vs n \<Longrightarrow> ordered_closure v n"
  by (induction vs x rule: lookup.induct) simp_all

lemma pushlam_ordered [simp]: "lookup cd x = Some (BPushLam pc) \<Longrightarrow> orderly cd n \<Longrightarrow>
    x < length cd \<Longrightarrow> 0 < pc \<and> pc \<le> length cd + n"
  by (induction cd x arbitrary: n rule: lookup.induct) fastforce+

lemma [simp]: "lookup cd x = Some (BPushLam pc) \<Longrightarrow> orderly cd 0 \<Longrightarrow> x < length cd \<Longrightarrow>
    0 < pc \<and> pc \<le> length cd"
  using pushlam_ordered by fastforce

lemma index_into_append [simp]: "lookup (flatten_code' lib cd r @ cd') (code_list_size cd + n) =
    lookup cd' n"
  by (metis flatten_length lookup_append)

lemma [simp]: "lookup (flatten_code' lib cd r @ op # acc) (code_list_size cd) = Some op"
proof -
  have "lookup (flatten_code' lib cd r @ op # acc) (code_list_size cd + 0) = lookup (op # acc) 0"
    by (metis index_into_append)
  thus ?thesis by simp
qed

lemma unflatten_r_front [simp]: "pc \<le> length cd \<Longrightarrow>
    unflatten_return (cd @ cd') pc = unflatten_return cd pc"
  by (induction pc) (simp_all split: option.splits byte_code.splits)

lemma unflatten_front [simp]: "pc \<le> length cd \<Longrightarrow>
    unflatten_code (cd @ cd') pc = unflatten_code cd pc"
  by (induction cd pc rule: unflatten_code.induct) (simp_all split: option.splits byte_code.splits)

lemma unflatten_flatten_r [simp]: "unflatten_return (lib @ flatten_code' (length lib) cd r @ acc)
  (length lib + code_list_size cd) = r"
proof (induction "length lib" cd r arbitrary: lib acc rule: flatten_code'.induct)
  case (1 r)
  thus ?case by (cases r) simp_all
next
  case (4 cd' r' cd r)
  let ?pc = "length lib + code_list_size cd'"
  let ?code' = "lib @ flatten_code' (length lib) cd' r'"
  let ?code = "?code' @ flatten_code' ?pc cd r @ BPushLam ?pc # acc"
  have "length lib + length (flatten_code' (length lib) cd' r') = length ?code'" by simp
  with 4 have "unflatten_return (?code' @ flatten_code' (length ?code') cd r @
    BPushLam (length lib + length (flatten_code' (length lib) cd' r')) # acc)
     (length ?code' + code_list_size cd) = r" by blast
  hence "unflatten_return ?code (length lib + code_list_size cd' + code_list_size cd) = r" by simp
  hence "unflatten_return ?code (length lib + (code_list_size cd' + code_list_size cd)) = r"
    by (metis add.assoc)
  thus ?case by simp
qed simp_all

lemma unflatten_flatten [simp]: "unflatten_code (lib @ flatten_code' (length lib) cd r @ acc)
  (length lib + code_list_size cd) = cd"
proof (induction "length lib" cd r arbitrary: lib acc rule: flatten_code'.induct)
  case (1 r)
  thus ?case by (cases r) simp_all
next
  case (4 cd' r' cd r)
  let ?pc = "length lib + code_list_size cd'"
  let ?code' = "lib @ flatten_code' (length lib) cd' r' @ []"
  let ?code = "?code' @ flatten_code' ?pc cd r @ BPushLam ?pc # acc"
  have "length lib + length (flatten_code' (length lib) cd' r') = length ?code'" by simp
  with 4 have "unflatten_code (?code' @ flatten_code' (length ?code') cd r @
    BPushLam (length lib + length (flatten_code' (length lib) cd' r')) # acc)
      (length ?code' + code_list_size cd) = cd" by blast
  hence "unflatten_code ?code (length lib + code_list_size cd' + code_list_size cd) = cd" by simp
  hence X: "unflatten_code ?code (length lib + (code_list_size cd' + code_list_size cd)) = cd"
    by (metis add.assoc)
  have P: "?pc \<le> length ?code'" by simp
  moreover from 4 have "unflatten_code ?code' (length lib + code_list_size cd') = cd'" by blast
  ultimately have Z: "unflatten_code ?code ?pc =  cd'" by (metis unflatten_front)
  from P have "unflatten_return ?code ?pc = unflatten_return ?code' ?pc"
    by (metis unflatten_r_front)
  with X Z show ?case by simp
qed simp_all

lemma [simp]: "unflatten_return (flatten_code (cd, r)) (code_list_size cd) = r"
proof -
  have "unflatten_return ([] @ flatten_code' (length []) cd r @ []) (length [] + code_list_size cd) =
    r" by (metis unflatten_flatten_r list.size(3))
  thus ?thesis by simp
qed

lemma [simp]: "unflatten_code (flatten_code (cd, r)) (code_list_size cd) = cd"
proof -
  have "unflatten_code ([] @ flatten_code' (length []) cd r @ [])
    (length [] + code_list_size cd) = cd" by (metis unflatten_flatten list.size(3))
  thus ?thesis by simp
qed

lemma orderly_lam [simp]: "lookup cd pc = Some (BPushLam pc') \<Longrightarrow> orderly cd n \<Longrightarrow> pc' \<le> pc + n"
  by (induction cd pc arbitrary: n rule: lookup.induct) fastforce+

lemma [simp]: "lookup cd pc = Some (BPushLam pc') \<Longrightarrow> orderly cd 0 \<Longrightarrow> pc' \<le> pc"
  using orderly_lam by fastforce

theorem correctb [simp]: "cd \<tturnstile> \<Sigma>\<^sub>b \<leadsto>\<^sub>b \<Sigma>\<^sub>b' \<Longrightarrow> orderly_state cd \<Sigma>\<^sub>b \<Longrightarrow>
  iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (unflatten_state cd \<Sigma>\<^sub>b) (unflatten_state cd \<Sigma>\<^sub>b')"
proof (induction \<Sigma>\<^sub>b \<Sigma>\<^sub>b' rule: evalb.induct)
  case (evb_lookup cd pc x env v vs sfs)
  hence "TCOS (ufcs cd vs)
    ((ufcs cd env, unflatten_code cd (Suc pc), unflatten_return cd (Suc pc)) # ufsfs cd sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      TCOS (unflatten_closure cd v # ufcs cd vs)
        ((ufcs cd env, unflatten_code cd pc, unflatten_return cd pc) # ufsfs cd sfs)" by simp
  thus ?case by simp
next
  case (evb_pushcon cd pc k vs env sfs)
  hence "TCOS (ufcs cd vs)
    ((ufcs cd env, unflatten_code cd (Suc pc), unflatten_return cd (Suc pc)) # ufsfs cd sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      TCOS (TCOConst k # ufcs cd vs)
        ((ufcs cd env, unflatten_code cd pc, unflatten_return cd pc) # ufsfs cd sfs)" by simp
  thus ?case by simp
next
  case (evb_pushlam cd pc pc' vs env sfs)
  moreover hence X: "pc' \<le> pc" by auto
  moreover have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (ufcs cd vs) ((ufcs cd env,
    TCOPushLam (unflatten_code cd pc') (unflatten_return cd pc') #
      unflatten_code cd pc, unflatten_return cd pc) # ufsfs cd sfs))
        (TCOS (TCOLam (ufcs cd env) (unflatten_code cd pc') (unflatten_return cd pc') # ufcs cd vs)
          ((ufcs cd env, unflatten_code cd pc, unflatten_return cd pc) # ufsfs cd sfs))"
    by (metis evtco_pushlam iter_one)
  ultimately show ?case by simp
next
  case (evb_apply cd pc v env' pc' vs env sfs)
  hence "TCOS (unflatten_closure cd v # TCOLam (ufcs cd env') (unflatten_code cd pc')
    (unflatten_return cd pc') # ufcs cd vs)
      ((ufcs cd env, unflatten_code cd (Suc pc), unflatten_return cd (Suc pc)) # ufsfs cd sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (ufcs cd vs) ((unflatten_closure cd v # ufcs cd env', unflatten_code cd pc',
          unflatten_return cd pc') # (ufcs cd env, unflatten_code cd pc, unflatten_return cd pc) #
            ufsfs cd sfs)" by simp
  thus ?case by simp
next
  case (evb_return cd pc vs env sfs)
  moreover have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (ufcs cd vs) ((ufcs cd env, [], TCOReturn) # ufsfs cd sfs))
    (TCOS (ufcs cd vs) (ufsfs cd sfs))" by (metis evtco_return iter_one)
  ultimately show ?case by simp
next
  case (evb_jump cd pc v env' pc' vs env sfs)
  have "TCOS (unflatten_closure cd v # TCOLam (ufcs cd env') (unflatten_code cd pc')
    (unflatten_return cd pc') # ufcs cd vs) ((ufcs cd env, [],
      TCOJump) # ufsfs cd sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o TCOS (ufcs cd vs)
        ((unflatten_closure cd v # ufcs cd env', unflatten_code cd pc', unflatten_return cd pc') #
          ufsfs cd sfs)" by (metis evtco_jump)
  with evb_jump have "TCOS (unflatten_closure cd v #
    TCOLam (ufcs cd env') (unflatten_code cd pc') (unflatten_return cd pc') # ufcs cd vs)
      ((ufcs cd env, unflatten_code cd (Suc pc), unflatten_return cd (Suc pc)) # ufsfs cd sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (ufcs cd vs) ((unflatten_closure cd v # ufcs cd env', unflatten_code cd pc',
          unflatten_return cd pc') # ufsfs cd sfs)" by simp
  hence "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (unflatten_closure cd v #
    TCOLam (ufcs cd env') (unflatten_code cd pc') (unflatten_return cd pc') # ufcs cd vs)
      ((ufcs cd env, unflatten_code cd (Suc pc), unflatten_return cd (Suc pc)) # ufsfs cd sfs))
        (TCOS (ufcs cd vs) ((unflatten_closure cd v # ufcs cd env', unflatten_code cd pc',
          unflatten_return cd pc') # ufsfs cd sfs))" by (metis iter_one)
  thus ?case by simp
qed

lemma [simp]: "TCOLam envt cdt rt = unflatten_closure cdb vb \<Longrightarrow>
  \<exists>envb pc. vb = BLam envb pc \<and> envt = ufcs cdb envb \<and> cdt = unflatten_code cdb pc \<and>
    rt = unflatten_return cdb pc"
  by (induction vb) simp_all

lemma unfl_state [dest]: "TCOS vs sfs = unflatten_state cd \<Sigma>\<^sub>b \<Longrightarrow> \<exists>vsb sfsb.
    \<Sigma>\<^sub>b = BS vsb sfsb \<and> vs = ufcs cd vsb \<and> sfs = ufsfs cd sfsb"
  by (induction \<Sigma>\<^sub>b) simp_all

lemma [dest]: "TCOLookup x # cdt = unflatten_code cdb (Suc pc) \<Longrightarrow> orderly cdb 0 \<Longrightarrow>
    pc < length cdb \<Longrightarrow> lookup cdb pc = Some (BLookup x) \<and> cdt = unflatten_code cdb pc"
  by (simp split: option.splits byte_code.splits)

lemma [dest]: "TCOPushCon k # cdt = unflatten_code cdb (Suc pc) \<Longrightarrow> orderly cdb 0 \<Longrightarrow>
    pc < length cdb \<Longrightarrow> lookup cdb pc = Some (BPushCon k) \<and> cdt = unflatten_code cdb pc"
  by (simp split: option.splits byte_code.splits)

lemma [dest]: "TCOPushLam cdt'' r # cdt = unflatten_code cdb (Suc pc) \<Longrightarrow>
  orderly cdb 0 \<Longrightarrow> pc < length cdb \<Longrightarrow>
    \<exists>pc'. lookup cdb pc = Some (BPushLam pc') \<and> cdt = unflatten_code cdb pc \<and>
      cdt'' = unflatten_code cdb pc' \<and> r = unflatten_return cdb pc'"
  by (simp split: option.splits byte_code.splits)

lemma [dest]: "TCOApply # cdt = unflatten_code cdb (Suc pc) \<Longrightarrow> orderly cdb 0 \<Longrightarrow>
    pc < length cdb \<Longrightarrow> lookup cdb pc = Some BApply \<and> cdt = unflatten_code cdb pc"
  by (simp split: option.splits byte_code.splits)

lemma [dest]: "[] = unflatten_code cdb (Suc pc) \<Longrightarrow> TCOReturn = unflatten_return cdb (Suc pc) \<Longrightarrow>
    orderly cdb 0 \<Longrightarrow> pc < length cdb \<Longrightarrow> lookup cdb pc = Some BReturn"
  by (simp split: option.splits byte_code.splits)

lemma [dest]: "[] = unflatten_code cdb (Suc pc) \<Longrightarrow> TCOJump = unflatten_return cdb (Suc pc) \<Longrightarrow>
    orderly cdb 0 \<Longrightarrow> pc < length cdb \<Longrightarrow> lookup cdb pc = Some BJump"
  by (simp split: option.splits byte_code.splits)

lemma uf_to_lookup [dest]: "(envt, TCOLookup x # cdt, r) # sfst = ufsfs cdb sfsb \<Longrightarrow>
  orderly cdb 0 \<Longrightarrow> orderly_stack sfsb (length cdb) \<Longrightarrow> \<exists>envb pc sfsb'.
    sfsb = (envb, Suc pc) # sfsb' \<and> envt = ufcs cdb envb \<and> lookup cdb pc = Some (BLookup x) \<and>
      cdt = unflatten_code cdb pc \<and> r = unflatten_return cdb pc \<and> sfst = ufsfs cdb sfsb'"
proof (induction sfsb "length cdb" rule: orderly_stack.induct)
  case (3 envb pc sfsb')
  hence "TCOLookup x # cdt = unflatten_code cdb (Suc pc) \<and> orderly cdb 0 \<and> pc < length cdb" by simp
  hence "lookup cdb pc = Some (BLookup x) \<and> cdt = unflatten_code cdb pc" by blast
  with 3 show ?case by simp
qed simp_all

lemma uf_to_pushcon [dest]: "(envt, TCOPushCon k # cdt, r) # sfst = ufsfs cdb sfsb \<Longrightarrow>
  orderly cdb 0 \<Longrightarrow> orderly_stack sfsb (length cdb) \<Longrightarrow>
    \<exists>envb pc sfsb'. sfsb = (envb, Suc pc) # sfsb' \<and> envt = ufcs cdb envb \<and>
      lookup cdb pc = Some (BPushCon k) \<and> cdt = unflatten_code cdb pc \<and>
        r = unflatten_return cdb pc \<and> sfst = ufsfs cdb sfsb'"
proof (induction sfsb "length cdb" rule: orderly_stack.induct)
  case (3 envb pc sfsb')
  hence "TCOPushCon k # cdt = unflatten_code cdb (Suc pc) \<and> orderly cdb 0 \<and> pc < length cdb" by simp
  hence "lookup cdb pc = Some (BPushCon k) \<and> cdt = unflatten_code cdb pc" by blast
  with 3 show ?case by simp
qed simp_all

lemma uf_to_pushlam [dest]: "(envt, TCOPushLam cdt' r' # cdt, r) # sfst = ufsfs cdb sfsb \<Longrightarrow>
  orderly cdb 0 \<Longrightarrow> orderly_stack sfsb (length cdb) \<Longrightarrow> \<exists>envb pc sfsb' pc'.
    sfsb = (envb, Suc pc) # sfsb' \<and> envt = ufcs cdb envb \<and> lookup cdb pc = Some (BPushLam pc') \<and>
      cdt = unflatten_code cdb pc \<and> r = unflatten_return cdb pc \<and> cdt' = unflatten_code cdb pc' \<and>
        r' = unflatten_return cdb pc' \<and> sfst = ufsfs cdb sfsb'"
proof (induction sfsb "length cdb" rule: orderly_stack.induct)
  case (3 envb pc sfsb')
  hence "TCOPushLam cdt' r' # cdt = unflatten_code cdb (Suc pc) \<and> orderly cdb 0 \<and> pc < length cdb"
    by simp
  then obtain pc' where "lookup cdb pc = Some (BPushLam pc') \<and> cdt = unflatten_code cdb pc \<and>
    cdt' = unflatten_code cdb pc' \<and> r' = unflatten_return cdb pc'" by blast
  with 3 show ?case by simp
qed simp_all

lemma uf_to_apply [dest]: "(envt, TCOApply # cdt, r) # sfst = ufsfs cdb sfsb \<Longrightarrow> orderly cdb 0 \<Longrightarrow>
  orderly_stack sfsb (length cdb) \<Longrightarrow> \<exists>envb pc sfsb'. sfsb = (envb, Suc pc) # sfsb' \<and>
    envt = ufcs cdb envb \<and> lookup cdb pc = Some BApply \<and> cdt = unflatten_code cdb pc \<and>
      r = unflatten_return cdb pc \<and> sfst = ufsfs cdb sfsb'"
proof (induction sfsb "length cdb" rule: orderly_stack.induct)
  case (3 envb pc sfsb')
  hence "TCOApply # cdt = unflatten_code cdb (Suc pc) \<and> orderly cdb 0 \<and> pc < length cdb" by simp
  hence "lookup cdb pc = Some BApply \<and> cdt = unflatten_code cdb pc" by blast
  with 3 show ?case by simp
qed simp_all

lemma uf_to_return [dest]: "(envt, [], TCOReturn) # sfst = ufsfs cdb sfsb \<Longrightarrow> orderly cdb 0 \<Longrightarrow>
  orderly_stack sfsb (length cdb) \<Longrightarrow> \<exists>envb pc sfsb'. sfsb = (envb, Suc pc) # sfsb' \<and>
    envt = ufcs cdb envb \<and> lookup cdb pc = Some BReturn \<and> sfst = ufsfs cdb sfsb'"
proof (induction sfsb "length cdb" rule: orderly_stack.induct)
  case (3 envb pc sfsb')
  hence "[] = unflatten_code cdb (Suc pc) \<and> TCOReturn = unflatten_return cdb (Suc pc) \<and>
    orderly cdb 0 \<and> pc < length cdb" by simp
  hence "lookup cdb pc = Some BReturn" by blast
  with 3 show ?case by simp
qed simp_all

lemma uf_to_jump [dest]: "(envt, [], TCOJump) # sfst = ufsfs cdb sfsb \<Longrightarrow> orderly cdb 0 \<Longrightarrow>
  orderly_stack sfsb (length cdb) \<Longrightarrow> \<exists>envb pc sfsb'. sfsb = (envb, Suc pc) # sfsb' \<and>
    envt = ufcs cdb envb \<and> lookup cdb pc = Some BJump \<and> sfst = ufsfs cdb sfsb'"
proof (induction sfsb "length cdb" rule: orderly_stack.induct)
  case (3 envb pc sfsb')
  hence "[] = unflatten_code cdb (Suc pc) \<and> TCOJump = unflatten_return cdb (Suc pc) \<and>
    orderly cdb 0 \<and> pc < length cdb" by simp
  hence "lookup cdb pc = Some BJump" by blast
  with 3 show ?case by simp
qed simp_all

theorem completeb [simp]: "unflatten_state cd\<^sub>b \<Sigma>\<^sub>b \<leadsto>\<^sub>t\<^sub>c\<^sub>o \<Sigma>\<^sub>t' \<Longrightarrow> orderly_state cd\<^sub>b \<Sigma>\<^sub>b \<Longrightarrow>
  \<exists>\<Sigma>\<^sub>b'. iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) \<Sigma>\<^sub>b \<Sigma>\<^sub>b' \<and> unflatten_state cd\<^sub>b \<Sigma>\<^sub>b' = \<Sigma>\<^sub>t'"
proof (induction "unflatten_state cd\<^sub>b \<Sigma>\<^sub>b" \<Sigma>\<^sub>t' rule: evaltco.induct)
  case (evtco_lookup env x v vs cd r sfs)
  then obtain vsb sfsb where B: "\<Sigma>\<^sub>b = BS vsb sfsb \<and> vs = ufcs cd\<^sub>b vsb \<and>
    (env, TCOLookup x # cd, r) # sfs = ufsfs cd\<^sub>b sfsb" by fastforce
  with evtco_lookup have "orderly cd\<^sub>b 0 \<and> orderly_stack sfsb (length cd\<^sub>b)" by simp
  with B obtain envb pc sfsb' where S: "sfsb = (envb, Suc pc) # sfsb' \<and>
    env = ufcs cd\<^sub>b envb \<and> lookup cd\<^sub>b pc = Some (BLookup x) \<and> cd = unflatten_code cd\<^sub>b pc \<and>
      r = unflatten_return cd\<^sub>b pc \<and> sfs = ufsfs cd\<^sub>b sfsb'" by (metis uf_to_lookup)
  with evtco_lookup obtain v' where V: "lookup envb x = Some v' \<and> unflatten_closure cd\<^sub>b v' = v"
    by fastforce
  with S have "cd\<^sub>b \<tturnstile> BS vsb ((envb, Suc pc) # sfsb') \<leadsto>\<^sub>b BS (v' # vsb) ((envb, pc) # sfsb')"
    by simp
  hence "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) (BS vsb ((envb, Suc pc) # sfsb')) (BS (v' # vsb) ((envb, pc) # sfsb'))"
    by simp
  with B S V show ?case by fastforce
next
  case (evtco_pushcon vs env k cd r sfs)
  then obtain vsb sfsb where B: "\<Sigma>\<^sub>b = BS vsb sfsb \<and> vs = ufcs cd\<^sub>b vsb \<and>
    (env, TCOPushCon k # cd, r) # sfs = ufsfs cd\<^sub>b sfsb" by fastforce
  with evtco_pushcon have "orderly cd\<^sub>b 0 \<and> orderly_stack sfsb (length cd\<^sub>b)" by simp
  with B obtain envb pc sfsb' where S: "sfsb = (envb, Suc pc) # sfsb' \<and>
    env = ufcs cd\<^sub>b envb \<and> lookup cd\<^sub>b pc = Some (BPushCon k) \<and> cd = unflatten_code cd\<^sub>b pc \<and>
      r = unflatten_return cd\<^sub>b pc \<and> sfs = ufsfs cd\<^sub>b sfsb'" by (metis uf_to_pushcon)
  with S have "cd\<^sub>b \<tturnstile> BS vsb ((envb, Suc pc) # sfsb') \<leadsto>\<^sub>b BS (BConst k # vsb) ((envb, pc) # sfsb')"
    by simp
  hence "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) (BS vsb ((envb, Suc pc) # sfsb'))
    (BS (BConst k # vsb) ((envb, pc) # sfsb'))" by simp
  with B S show ?case by fastforce
next
  case (evtco_pushlam vs env cd' r' cd r sfs)
  then obtain vsb sfsb where B: "\<Sigma>\<^sub>b = BS vsb sfsb \<and> vs = ufcs cd\<^sub>b vsb \<and>
    (env, TCOPushLam cd' r' # cd, r) # sfs = ufsfs cd\<^sub>b sfsb" by fastforce
  with evtco_pushlam have "orderly cd\<^sub>b 0 \<and> orderly_stack sfsb (length cd\<^sub>b)" by simp
  with B obtain envb pc sfsb' pc' where S: "sfsb = (envb, Suc pc) # sfsb' \<and>
    env = ufcs cd\<^sub>b envb \<and> lookup cd\<^sub>b pc = Some (BPushLam pc') \<and> cd = unflatten_code cd\<^sub>b pc \<and>
      r = unflatten_return cd\<^sub>b pc \<and> sfs = ufsfs cd\<^sub>b sfsb' \<and> cd' = unflatten_code cd\<^sub>b pc' \<and>
        r' = unflatten_return cd\<^sub>b pc'" by (metis uf_to_pushlam)
  with S have "cd\<^sub>b \<tturnstile> BS vsb ((envb, Suc pc) # sfsb') \<leadsto>\<^sub>b
    BS (BLam envb pc' # vsb) ((envb, pc) # sfsb')" by simp
  hence "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) (BS vsb ((envb, Suc pc) # sfsb'))
    (BS (BLam envb pc' # vsb) ((envb, pc) # sfsb'))" by simp
  with B S show ?case by fastforce
next
  case (evtco_apply v env' cd' r' vs env cd r sfs)
  then obtain vsb sfsb where B: "\<Sigma>\<^sub>b = BS vsb sfsb \<and>
    v # TCOLam env' cd' r' # vs = ufcs cd\<^sub>b vsb \<and> (env, TCOApply # cd, r) # sfs = ufsfs cd\<^sub>b sfsb"
      by fastforce
  with evtco_apply have "orderly cd\<^sub>b 0 \<and> orderly_stack sfsb (length cd\<^sub>b)" by simp
  with B obtain envb pc sfsb' where S: "sfsb = (envb, Suc pc) # sfsb' \<and>
    env = ufcs cd\<^sub>b envb \<and> lookup cd\<^sub>b pc = Some BApply \<and> cd = unflatten_code cd\<^sub>b pc \<and>
      r = unflatten_return cd\<^sub>b pc \<and> sfs = ufsfs cd\<^sub>b sfsb'" by (metis uf_to_apply)
  from B obtain vb envb' pc' vsb' where V: "vsb = vb # BLam envb' pc' # vsb' \<and>
    v = unflatten_closure cd\<^sub>b vb \<and> env' = ufcs cd\<^sub>b envb' \<and> cd' = unflatten_code cd\<^sub>b pc' \<and>
      r' = unflatten_return cd\<^sub>b pc' \<and> vs = ufcs cd\<^sub>b vsb'" by fastforce
  from S have "cd\<^sub>b \<tturnstile> BS (vb # BLam envb' pc' # vsb') ((envb, Suc pc) # sfsb') \<leadsto>\<^sub>b
    BS vsb' ((vb # envb', pc') # (envb, pc) # sfsb')" by simp
  hence "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) (BS (vb # BLam envb' pc' # vsb') ((envb, Suc pc) # sfsb'))
    (BS vsb' ((vb # envb', pc') # (envb, pc) # sfsb'))" by simp
  with B S V show ?case by auto
next
  case (evtco_return vs env sfs)
  then obtain vsb sfsb where B: "\<Sigma>\<^sub>b = BS vsb sfsb \<and> vs = ufcs cd\<^sub>b vsb \<and>
    (env, [], TCOReturn) # sfs = ufsfs cd\<^sub>b sfsb" by fastforce
  with evtco_return have "orderly cd\<^sub>b 0 \<and> orderly_stack sfsb (length cd\<^sub>b)" by simp
  with B obtain envb pc sfsb' where S: "sfsb = (envb, Suc pc) # sfsb' \<and>
    env = ufcs cd\<^sub>b envb \<and> lookup cd\<^sub>b pc = Some BReturn \<and> sfs = ufsfs cd\<^sub>b sfsb'"
      by (metis uf_to_return)
  with S have "cd\<^sub>b \<tturnstile> BS vsb ((envb, Suc pc) # sfsb') \<leadsto>\<^sub>b BS vsb sfsb'" by simp
  hence "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) (BS vsb ((envb, Suc pc) # sfsb')) (BS vsb sfsb')" by simp
  with B S show ?case by fastforce
next
  case (evtco_jump v env' cd' r' vs env sfs)
  then obtain vsb sfsb where B: "\<Sigma>\<^sub>b = BS vsb sfsb \<and>
    v # TCOLam env' cd' r' # vs = ufcs cd\<^sub>b vsb \<and>
      (env, [], TCOJump) # sfs = ufsfs cd\<^sub>b sfsb" by fastforce
  with evtco_jump have "orderly cd\<^sub>b 0 \<and> orderly_stack sfsb (length cd\<^sub>b)" by simp
  with B obtain envb pc sfsb' where S: "sfsb = (envb, Suc pc) # sfsb' \<and>
    env = ufcs cd\<^sub>b envb \<and> lookup cd\<^sub>b pc = Some BJump \<and> sfs = ufsfs cd\<^sub>b sfsb'"
      by (metis uf_to_jump)
  from B obtain vb envb' pc' vsb' where V: "vsb = vb # BLam envb' pc' # vsb' \<and>
    v = unflatten_closure cd\<^sub>b vb \<and> env' = ufcs cd\<^sub>b envb' \<and> cd' = unflatten_code cd\<^sub>b pc' \<and>
      r' = unflatten_return cd\<^sub>b pc' \<and> vs = ufcs cd\<^sub>b vsb'" by fastforce
  from S have "cd\<^sub>b \<tturnstile> BS (vb # BLam envb' pc' # vsb') ((envb, Suc pc) # sfsb') \<leadsto>\<^sub>b
    BS vsb' ((vb # envb', pc') # sfsb')" by simp
  hence "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) (BS (vb # BLam envb' pc' # vsb') ((envb, Suc pc) # sfsb'))
    (BS vsb' ((vb # envb', pc') # sfsb'))" by simp
  with B S V show ?case by auto
qed

lemma [simp]: "cd\<^sub>b \<tturnstile> \<Sigma>\<^sub>b \<leadsto>\<^sub>b \<Sigma>\<^sub>b' \<Longrightarrow> orderly_state cd\<^sub>b \<Sigma>\<^sub>b \<Longrightarrow> orderly_state cd\<^sub>b \<Sigma>\<^sub>b'"
proof (induction cd\<^sub>b \<Sigma>\<^sub>b \<Sigma>\<^sub>b' rule: evalb.induct)
  case (evb_lookup cd pc x env v vs sfs)
  thus ?case by (cases pc, cases cd) simp_all
next
  case (evb_pushcon cd pc k vs env sfs)
  thus ?case by (cases pc, cases cd) simp_all
next
  case (evb_pushlam cd pc pc' vs env sfs)
  thus ?case
  proof (cases pc)
    case 0
    with evb_pushlam show ?thesis by (cases cd) simp_all
  qed simp_all
next
  case (evb_apply cd pc v env' pc' vs env sfs)
  thus ?case by (cases pc', simp, cases pc, cases cd) simp_all
next
  case (evb_jump cd pc v env' pc' vs env sfs)
  thus ?case by (cases pc') simp_all
qed simp_all

lemma [simp]: "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) \<Sigma>\<^sub>b \<Sigma>\<^sub>b' \<Longrightarrow> orderly_state cd\<^sub>b \<Sigma>\<^sub>b \<Longrightarrow> orderly_state cd\<^sub>b \<Sigma>\<^sub>b'"
  by (induction \<Sigma>\<^sub>b \<Sigma>\<^sub>b' rule: iter.induct) simp_all

lemma [simp]: "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (unflatten_state cd\<^sub>b \<Sigma>\<^sub>b) \<Sigma>\<^sub>t' \<Longrightarrow> orderly_state cd\<^sub>b \<Sigma>\<^sub>b \<Longrightarrow>
  \<exists>\<Sigma>\<^sub>b'. iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) \<Sigma>\<^sub>b \<Sigma>\<^sub>b' \<and> unflatten_state cd\<^sub>b \<Sigma>\<^sub>b' = \<Sigma>\<^sub>t'"
proof (induction "unflatten_state cd\<^sub>b \<Sigma>\<^sub>b" \<Sigma>\<^sub>t' arbitrary: \<Sigma>\<^sub>b rule: iter.induct)
  case (iter_step \<Sigma>\<^sub>t' \<Sigma>\<^sub>t'')
  moreover then obtain \<Sigma>\<^sub>b' where S: "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) \<Sigma>\<^sub>b \<Sigma>\<^sub>b' \<and> unflatten_state cd\<^sub>b \<Sigma>\<^sub>b' = \<Sigma>\<^sub>t'"
    by fastforce
  moreover with iter_step have "orderly_state cd\<^sub>b \<Sigma>\<^sub>b'" by fastforce
  ultimately obtain \<Sigma>\<^sub>b'' where "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) \<Sigma>\<^sub>b' \<Sigma>\<^sub>b'' \<and> unflatten_state cd\<^sub>b \<Sigma>\<^sub>b'' = \<Sigma>\<^sub>t''"
    by fastforce
  with S show ?case by (metis iter_append)
qed force+

lemma unfl_terminal [simp]: "unflatten_state cd \<Sigma> = TCOS [c] [] \<Longrightarrow>
  \<exists>v. \<Sigma> = BS [v] [] \<and> c = unflatten_closure cd v"
proof -
  assume "unflatten_state cd \<Sigma> = TCOS [c] []"
  then obtain vs sfs where S: "\<Sigma> = BS vs sfs \<and> [c] = ufcs cd vs \<and> [] = ufsfs cd sfs"
    by (metis unfl_state)
  moreover then obtain v where "vs = [v] \<and> c = unflatten_closure cd v" by blast
  ultimately show ?thesis by simp
qed

lemma evalb_end [simp]: "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (unflatten_state cd\<^sub>b \<Sigma>\<^sub>b) (TCOS [c] []) \<Longrightarrow>
  orderly_state cd\<^sub>b \<Sigma>\<^sub>b \<Longrightarrow>
    \<exists>v. iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) \<Sigma>\<^sub>b (BS [v] []) \<and> c = unflatten_closure cd\<^sub>b v"
proof -
  assume "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (unflatten_state cd\<^sub>b \<Sigma>\<^sub>b) (TCOS [c] [])"
  moreover assume O: "orderly_state cd\<^sub>b \<Sigma>\<^sub>b"
  ultimately obtain \<Sigma>\<^sub>b' where E: "iter (\<tturnstile> cd\<^sub>b \<leadsto>\<^sub>b) \<Sigma>\<^sub>b \<Sigma>\<^sub>b' \<and> unflatten_state cd\<^sub>b \<Sigma>\<^sub>b' = TCOS [c] []"
    by fastforce
  moreover with O have "orderly_state cd\<^sub>b \<Sigma>\<^sub>b'" by fastforce
  moreover with E obtain v where "\<Sigma>\<^sub>b' = BS [v] [] \<and> c = unflatten_closure cd\<^sub>b v"
    by (metis unfl_terminal)
  ultimately show ?thesis by blast
qed

end