(* trans_semantics.thy *)
(* William Mansky *)
(* Semantics for the revised specification language PTRANS. *)

theory trans_semantics
imports trans_flowgraph
begin

(* matches a total valuation of metavariables with a partial one *)
definition part_matches where "part_matches \<sigma> t \<equiv> \<forall>x y. t x = Some y \<longrightarrow> \<sigma> x = y"

(* extends a partial valuation with another valuation over a given domain *)
definition part_extend where "part_extend t d \<sigma> \<equiv> \<lambda>x. if x\<in>d then Some (\<sigma> x) else t x"

(* The pieces that must be provided by the target language to give semantics to transformations. *)
locale TRANS_basics = (* give SCEx a type annotation, parameterize by 'valuation? *)
  fixes subst::"(('thread, ('node, 'edge_type, 'instr) flowgraph) map) \<Rightarrow> ('metavar \<Rightarrow> 'object) \<Rightarrow> 'pattern \<rightharpoonup> 'instr"
    and node_subst::"(('thread, ('node, 'edge_type, 'instr) flowgraph) map) \<Rightarrow> ('metavar \<Rightarrow> 'object) \<Rightarrow>
                     'metavar node_lit \<rightharpoonup> 'node"
    and type_subst::"('metavar \<Rightarrow> 'object) \<Rightarrow> 'edge_type_expr \<rightharpoonup> 'edge_type"
    and pred_fv::"'pred \<Rightarrow> 'metavar set"
    and eval_pred::"(('thread, ('node, 'edge_type, 'instr) flowgraph) map) \<Rightarrow> ('thread, 'node) map \<Rightarrow>
                    ('metavar \<Rightarrow> 'object) \<Rightarrow> 'pred \<Rightarrow> bool"
    and instr_edges::"'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
    and Seq::'edge_type
  assumes infinite_nodes [simp]: "\<not>finite (UNIV::'node set)"
      and infinite_mvars [simp]: "\<not>finite (UNIV::'metavar set)"
      and pred_same_subst: "\<lbrakk>\<forall>x\<in>pred_fv p. \<sigma> x = \<sigma>' x; pre_tCFG CFGs\<rbrakk> \<Longrightarrow>
 eval_pred CFGs q \<sigma> p = eval_pred CFGs q \<sigma>' p"
begin

lemmas fresh_nodes = infinite_nodes [THEN fresh_new]
lemmas fresh_mvars = infinite_mvars [THEN fresh_new]

primrec subst_list where
"subst_list G \<sigma> [] = Some []" |
"subst_list G \<sigma> (p # rest) = (case (subst G \<sigma> p, subst_list G \<sigma> rest) of
   (Some i, Some irest) \<Rightarrow> Some (i # irest) | _ \<Rightarrow> None)"

primrec models where
"models _ _ _ SCTrue = True" |
"models CFGs \<sigma> q (SCPred p) = eval_pred CFGs q \<sigma> p" |
"models CFGs \<sigma> q (\<phi>1 \<and>sc \<phi>2) = (models CFGs \<sigma> q \<phi>1 \<and> models CFGs \<sigma> q \<phi>2)" |
"models CFGs \<sigma> q (\<not>sc \<phi>) = (\<not>models CFGs \<sigma> q \<phi>)" |
"models CFGs \<sigma> q (A \<phi>1 \<U> \<phi>2) = (\<forall>l \<in> pre_tCFG.Paths CFGs q. \<exists>i. models CFGs \<sigma> (l i) \<phi>2 \<and>
 (\<forall>j<i. models CFGs \<sigma> (l j) \<phi>1))" |
"models CFGs \<sigma> q (E \<phi>1 \<U> \<phi>2) = (\<exists>l \<in> pre_tCFG.Paths CFGs q. \<exists>i. models CFGs \<sigma> (l i) \<phi>2 \<and>
 (\<forall>j<i. models CFGs \<sigma> (l j) \<phi>1))" |
"models CFGs \<sigma> q (A \<phi>1 \<B> \<phi>2) = (\<forall>l \<in> pre_tCFG.RPaths CFGs q. \<exists>i. models CFGs \<sigma> (l i) \<phi>2 \<and>
 (\<forall>j<i. models CFGs \<sigma> (l j) \<phi>1))" |
"models CFGs \<sigma> q (E \<phi>1 \<B> \<phi>2) = (\<exists>l \<in> pre_tCFG.RPaths CFGs q. \<exists>i. models CFGs \<sigma> (l i) \<phi>2 \<and>
 (\<forall>j<i. models CFGs \<sigma> (l j) \<phi>1))" |
"models CFGs \<sigma> q (SCEx x \<phi>) = (\<exists>obj. models CFGs (\<sigma>(x := obj)) q \<phi>)"

abbreviation "side_cond_sf \<psi> \<sigma> CFGs \<equiv> models CFGs \<sigma> (start_points CFGs) \<psi>"

lemma cond_same_subst: "\<lbrakk>\<forall>x\<in>cond_fv pred_fv P. \<sigma> x = \<sigma>' x; pre_tCFG CFGs\<rbrakk> \<Longrightarrow>
 models CFGs \<sigma> q P = models CFGs \<sigma>' q P"
apply (induct P arbitrary: \<sigma> \<sigma>' q, simp+)
apply (erule pred_same_subst, simp)
apply (metis (lifting, mono_tags) UnI1 UnI2 cond_fv.simps(3) models.simps(3))
apply simp
apply (smt UnI1 UnI2 cond_fv.simps(5) models.simps(5))
apply (smt UnI1 UnI2 cond_fv.simps(6) models.simps(6))
apply (smt UnI1 UnI2 cond_fv.simps(7) models.simps(7))
apply (smt UnI1 UnI2 cond_fv.simps(8) models.simps(8))
apply auto
apply (rule_tac x=obj in exI, smt DiffI fun_upd_def singletonE)+
done

lemma cond_gen: "\<lbrakk>models CFGs \<sigma> q P; \<forall>x\<in>cond_fv pred_fv P. \<sigma> x = \<sigma>' x; pre_tCFG CFGs\<rbrakk> \<Longrightarrow>
 models CFGs \<sigma>' q P"
by (drule cond_same_subst, simp, force)

end

(* Utility functions for actions. *)
fun update_list where
"update_list f [] = f" |
"update_list f ((x,y) # rest) = update_list (f(x := y)) rest"

lemma update_list_past [simp]: "x \<notin> fst ` set l \<Longrightarrow> update_list f l x = f x"
by (induct l arbitrary: f, auto)

lemma update_list_i: "\<lbrakk>distinct (map fst l); (x, y) \<in> set l\<rbrakk> \<Longrightarrow> update_list f l x = y"
by (induct l arbitrary: f, auto)

definition "remap_succ x y e \<equiv> let (n,s,t) = e in if x = n then (y,s,t) else e"

context TRANS_basics begin

definition "rep_edges es ll \<equiv> if ll = [] then es else
  {remap_succ (hd ll) (last ll) e | e. e\<in>es} \<union>
  {(u,v,Seq) | u v. (\<exists>a. ll!a = u \<and> ll!(a+1) = v \<and> (a+1) < length ll)}"

lemma rep_one_edge [simp]: "rep_edges es [n] = es"
by (auto simp add: rep_edges_def remap_succ_def)

lemma rep_edges_out [simp]: "n \<notin> set ll \<Longrightarrow> ((n, b, c) \<in> rep_edges es ll) = ((n, b, c) \<in> es)"
by (auto simp add: rep_edges_def remap_succ_def, force+)

lemma rep_out_edges_out [simp]: "n \<notin> set ll \<Longrightarrow> out_edges (rep_edges es ll) n = out_edges es n"
by (simp add: out_edges_def)

lemma rep_out_edges_in: "\<lbrakk>n = ll ! i; i < length ll - 1; distinct ll; i = 0 \<or> (\<forall>n' e. (n, n', e) \<notin> es)\<rbrakk> \<Longrightarrow>
  out_edges (rep_edges es ll) n = {(ll ! (i + 1), Seq)}"
apply (clarsimp simp add: rep_edges_def remap_succ_def out_edges_def)
apply (case_tac "ll = []", simp+)
apply (simp add: last_conv_nth, rule set_eqI, rule iffI, clarsimp)
apply (erule_tac Q=
           "b = Seq \<and> (\<exists>aa. ll ! aa = ll ! i \<and> ll ! Suc aa = a \<and> Suc aa < length ll)"
           in disjE, clarsimp)
(* I think this works in 2015, while the above works in 2014, argh!
apply (erule_tac P="\<exists>aa. _ aa" in disjE, clarsimp)
*)
apply (case_tac "hd ll = aa", simp add: nth_eq_iff_index_eq, force simp add: hd_conv_nth)
apply (clarsimp simp add: nth_eq_iff_index_eq)
apply auto
done

corollary rep_out_edge_in: "\<lbrakk>(n, n', e) \<in> rep_edges es ll; n = ll ! i; i < length ll - 1; distinct ll;
  i = 0 \<or> (\<forall>n' e. (n, n', e) \<notin> es)\<rbrakk> \<Longrightarrow> n' = ll ! (i + 1) \<and> e = Seq"
apply (frule rep_out_edges_in, simp+)
by (metis out_edge prod.sel(1) prod.sel(2) singletonD)

lemma rep_out_edges_last: "\<lbrakk>n = last ll; ll \<noteq> []; distinct ll; \<forall>n' e. (n, n', e) \<notin> es\<rbrakk> \<Longrightarrow>
  out_edges (rep_edges es ll) n = out_edges es (hd ll)"
apply (clarsimp simp add: rep_edges_def remap_succ_def out_edges_def)
apply (rule set_eqI, rule iffI, clarsimp)
apply (erule disjE, clarsimp)
apply (case_tac "hd ll = aa", clarsimp+)
apply (simp add: last_conv_nth nth_eq_iff_index_eq)
apply (clarsimp simp add: nth_eq_iff_index_eq)
apply auto
done

lemma rep_out_by_t [simp]: "n \<notin> set ll \<Longrightarrow> out_by_t (rep_edges es ll) t n = out_by_t es t n"
by (simp add: out_edges_by_t)

(* Actions are defined by their effects on one of the CFGs in a tCFG. *)
fun action_sf where
"action_sf (AAddEdge n m e) \<sigma> CFGs = (case (node_subst CFGs \<sigma> n, node_subst CFGs \<sigma> m, type_subst \<sigma> e) of
   (Some u, Some v, Some ty) \<Rightarrow> if u \<notin> nodes CFGs \<or> u \<in> exits CFGs \<or> v \<in> starts CFGs
    then None else
   (case CFGs (thread_of u CFGs) of Some G \<Rightarrow>
    if v \<in> Nodes G then Some (CFGs(thread_of u CFGs \<mapsto> G\<lparr>Edges := Edges G \<union> {(u,v,ty)}\<rparr>)) else None
 | _ \<Rightarrow> None) | _ \<Rightarrow> None)" |
"action_sf (ARemoveEdge n m e) \<sigma> CFGs = (case (node_subst CFGs \<sigma> n, node_subst CFGs \<sigma> m, type_subst \<sigma> e) of
   (Some u, Some v, Some ty) \<Rightarrow> if u \<notin> nodes CFGs then None else
   (case CFGs (thread_of u CFGs) of Some G \<Rightarrow>
   Some (CFGs(thread_of u CFGs \<mapsto> G\<lparr>Edges := Edges G - {(u,v,ty)}\<rparr>)) | _ \<Rightarrow> None)
 | _ \<Rightarrow> None)" |
"action_sf (AReplace m pl) \<sigma> CFGs = (if pl = [] then (
 case node_subst CFGs \<sigma> m of Some l \<Rightarrow> if l \<notin> nodes CFGs \<or> l \<in> starts CFGs \<or> l \<in> exits CFGs then None
   else (case CFGs (thread_of l CFGs) of Some G \<Rightarrow>
   Some (CFGs(thread_of l CFGs \<mapsto> G\<lparr>Nodes := Nodes G - {l}, Edges := {(u,v,t). (u,v,t) \<in> Edges G \<and> u \<noteq> l \<and> v \<noteq> l}\<rparr>)) | _ \<Rightarrow> None)
     | _ \<Rightarrow> None)
 else case (node_subst CFGs \<sigma> m, subst_list CFGs \<sigma> pl) of
   (Some l, Some il) \<Rightarrow> if l \<notin> nodes CFGs \<or> l \<in> exits CFGs then None else
   (case CFGs (thread_of l CFGs) of Some G \<Rightarrow>
   let ll = new (nodes CFGs) (length il - 1)
    in Some (CFGs(thread_of l CFGs \<mapsto> G\<lparr>Nodes := Nodes G \<union> set ll, Edges := rep_edges (Edges G) (l#ll),
                        Label := update_list (Label G) (zip (l#ll) il)\<rparr>)) | _ \<Rightarrow> None)
   | _ \<Rightarrow> None)" |
"action_sf (ASplitEdge n m e i) \<sigma> CFGs = (case (node_subst CFGs \<sigma> n,node_subst CFGs \<sigma> m,type_subst \<sigma> e,subst CFGs \<sigma> i) of
   (Some u, Some v, Some ty, Some j) \<Rightarrow>
   (if (u,v,ty) \<in> edges CFGs then (case CFGs (thread_of u CFGs) of Some G \<Rightarrow>
    (let q = hd (new (nodes CFGs) 1)
    in Some (CFGs(thread_of u CFGs \<mapsto> G\<lparr>Nodes := Nodes G \<union> {q}, Edges := (Edges G - {(u,v,ty)}) \<union> {(u,q,ty),(q,v,Seq)},
                        Label := (Label G)(q := j)\<rparr>))) | _ \<Rightarrow> None)
    else None) | _ \<Rightarrow> None)"

(* semantics for lists of actions *)
primrec part_comp :: "('a \<rightharpoonup> 'a) list \<Rightarrow> 'a \<rightharpoonup> 'a" where
"part_comp ([]::('a \<rightharpoonup> 'a) list) x = Some x" |
"part_comp (f#rest) x = (case f x of None \<Rightarrow> None | Some y \<Rightarrow> part_comp rest y)"

definition action_list_sf
where "action_list_sf Al \<sigma> CFGs \<equiv> part_comp (map (\<lambda>a G. action_sf a \<sigma> G) Al) CFGs"

(* Recursive (fixpoint) application of a transformation *)
inductive apply_some::"(('metavar \<rightharpoonup> 'object) \<Rightarrow> 'a \<Rightarrow> 'a set) \<Rightarrow>
 ('metavar \<rightharpoonup> 'object) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
apply_none: "apply_some T \<tau> G G" |
apply_more: "\<lbrakk>G' \<in> T \<tau> G; apply_some T \<tau> G' G''\<rbrakk> \<Longrightarrow> apply_some T \<tau> G G''"

(* Transformations apply actions when their conditions are met. *)
primrec trans_sf where
"trans_sf (TIf al p) \<tau> CFGs = {CFGs' | CFGs' \<sigma>. Some CFGs' = action_list_sf al \<sigma> CFGs \<and>
    side_cond_sf p \<sigma> CFGs \<and> part_matches \<sigma> \<tau>}" |
"trans_sf (TMatch p T) \<tau> CFGs = {CFGs' | CFGs' \<sigma>. side_cond_sf p \<sigma> CFGs \<and> part_matches \<sigma> \<tau> \<and>
      CFGs' \<in> trans_sf T (part_extend \<tau> (cond_fv pred_fv p) \<sigma>) CFGs}" |
"trans_sf (TChoice T1 T2) \<tau> CFGs = (trans_sf T1 \<tau> CFGs) \<union> (trans_sf T2 \<tau> CFGs)" |
"trans_sf (TThen T1 T2) \<tau> CFGs = {CFGs'' | CFGs' CFGs''. CFGs' \<in> trans_sf T1 \<tau> CFGs \<and> CFGs'' \<in> trans_sf T2 \<tau> CFGs'}" |
"trans_sf (TApplyAll T) \<tau> CFGs = {CFGs'. apply_some (trans_sf T) \<tau> CFGs CFGs'} -
 {CFGs' | CFGs' CFGs''. CFGs' \<noteq> CFGs'' \<and> CFGs'' \<in> trans_sf T \<tau> CFGs'}"

lemma fst_set_zip [simp]: "length a = length b \<Longrightarrow> fst ` set (zip a b) = set a"
apply (induct a arbitrary: b, clarsimp+)
apply (case_tac b, simp+)
done

lemma subst_last [simp]: "\<lbrakk>subst_list CFGs \<sigma> l = Some l'; l \<noteq> []\<rbrakk> \<Longrightarrow>
  subst CFGs \<sigma> (last l) = Some (last l')"
apply (induct l arbitrary: l', simp, clarsimp split: option.splits)
apply (case_tac l, simp, clarsimp split: option.splits)
done

lemma subst_nth [simp]: "\<lbrakk>subst_list CFGs \<sigma> l = Some l'; i < length l'\<rbrakk> \<Longrightarrow>
  subst CFGs \<sigma> (l ! i) = Some (l' ! i)"
apply (induct l arbitrary: l' i, simp, clarsimp split: option.splits)
apply (case_tac i, simp+)
done

lemma subst_length [simp]: "subst_list CFGs \<sigma> l = Some l' \<Longrightarrow> length l = length l'"
by (induct l arbitrary: l', auto split: option.splits)

lemma replace_CFGs: "\<lbrakk>action_sf (AReplace m pl) \<sigma> CFGs = Some CFGs'; pl \<noteq> [];
  \<forall>p\<in>set (butlast pl). \<forall>i. subst CFGs \<sigma> p = Some i \<longrightarrow> instr_edges i = {no_edges(Seq := 1)};
  \<forall>i n. subst CFGs \<sigma> (last pl) = Some i \<and> node_subst CFGs \<sigma> m = Some n \<longrightarrow>
    instr_edges i = instr_edges (Label (the (CFGs (thread_of n CFGs))) n);
  tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow> tCFG CFGs' instr_edges Seq"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>action_sf (AReplace m pl) \<sigma> CFGs = Some CFGs'; pl \<noteq> [];
  \<forall>p\<in>set (butlast pl). \<forall>i. subst CFGs \<sigma> p = Some i \<longrightarrow> instr_edges i = {no_edges(Seq := 1)};
  \<forall>i n. subst CFGs \<sigma> (last pl) = Some i \<and> node_subst CFGs \<sigma> m = Some n \<longrightarrow>
    instr_edges i = instr_edges (Label (the (CFGs (thread_of n CFGs))) n);
  tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow> tCFG CFGs' instr_edges Seq"
apply (cut_tac nodes_finite)
apply (clarsimp simp add: Let_def split: option.splits if_splits)
apply (rename_tac l ll g)
apply (unfold_locales, auto)
apply (case_tac "t \<noteq> thread_of l CFGs", simp, erule CFGs)
apply (clarsimp, frule CFGs, clarsimp simp add: is_flowgraph_def flowgraph_def)
apply (rule context_conjI, clarsimp simp add: pointed_graph_def)
apply (rule conjI, clarsimp simp add: rep_edges_def remap_succ_def)
apply (case_tac "new (nodes CFGs) (length ll - Suc 0) = []", clarsimp)
apply (case_tac "length ll - Suc 0", force)
apply (simp add: Let_def)
apply clarsimp
apply (erule disjE, force)
apply clarsimp
apply (case_tac a, simp+)
apply (frule node_of_graph, simp+)
apply (rule conjI, clarsimp simp add: in_edges_def rep_edges_def remap_succ_def)
apply (rule conjI, clarsimp, case_tac "length ll - 1")
apply (metis One_nat_def gr_implies_not0)
apply (simp add: Let_def)
apply (clarsimp, rule conjI, force, clarsimp)
apply (cut_tac S="nodes CFGs" and m="Start g" in new_nodes_are_new, simp+)
apply (simp add: set_conv_nth)
apply (rule_tac x=aa in exI, rule conjI, erule sym, simp+)
apply (metis nodes_by_graph)
apply (clarsimp simp add: out_edges_def rep_edges_def remap_succ_def)
apply (rule conjI, clarsimp, case_tac "length ll - 1")
apply (metis One_nat_def gr_implies_not0)
apply (simp add: Let_def)
apply (clarsimp, rule conjI, clarsimp)
apply (rule conjI, clarsimp)
apply (cut_tac S="nodes CFGs" and m="Exit g" in new_nodes_are_new, simp+)
apply (drule_tac as="new (nodes CFGs) (length ll - Suc 0)" in last_in_set, simp+)
apply (metis nodes_by_graph)
apply metis
apply clarsimp
apply (case_tac aa, clarsimp)
apply (metis exits_by_graph)
apply clarsimp
apply (cut_tac S="nodes CFGs" and m="Exit g" in new_nodes_are_new, simp+)
apply (simp add: set_conv_nth, rule exI, rule conjI, erule sym, simp+)
apply (metis nodes_by_graph)
(* now flowgraph_axioms *)
apply (case_tac "ll = []", clarsimp)
apply (clarsimp simp add: flowgraph_axioms_def)
apply (subgoal_tac "distinct (l # new (nodes CFGs) (length ll - 1))")
apply ((rule conjI, clarsimp)+)
apply (case_tac "u = l", clarsimp)
apply (case_tac "length ll - 1 = 0", simp)
apply (case_tac ll, simp+)
apply (case_tac pl, simp, clarsimp split: option.splits)
apply (case_tac list, simp_all split: option.splits, clarsimp)
apply (rename_tac lrest)
apply (simp add: rep_edges_def remap_succ_def out_edges_def)
apply (rule conjI, clarsimp simp add: Let_def, clarsimp intro!: ext simp add: edge_types_def)
apply (subgoal_tac "l \<noteq> last (let n' = SOME n. n \<notin> nodes CFGs in n' #
  new (insert n' (nodes CFGs)) (length lrest))", clarsimp)
apply (rule_tac s="{SOME n. n \<notin> nodes CFGs}" in subst, simp_all, rule set_eqI, rule iffI,
  clarsimp simp add: Let_def)
apply (rule_tac x=0 in exI, simp)
apply clarsimp
apply (case_tac ab, simp+)
apply (cut_tac m=l and S="nodes CFGs" and n="Suc (length lrest)" in new_nodes_are_new2, simp+)
apply (force simp add: Let_def set_conv_nth)
apply (clarsimp simp add: Let_def)
apply (cut_tac S="nodes CFGs" and n="Suc (length lrest)" in new_nodes_are_new, simp+,
  simp add: set_conv_nth Let_def, rule_tac x=nat in exI, simp+)
apply clarsimp+
apply (subgoal_tac "u \<notin> set (l # new (nodes CFGs) (length ll - Suc 0))", simp, clarsimp)
apply (cut_tac S="nodes CFGs" in new_nodes_are_new, simp+)
apply (metis nodes_by_graph)
apply (clarsimp simp add: set_conv_nth)
apply (cut_tac l="zip (l # new (nodes CFGs) (length ll - Suc 0)) ll" and f="Label g" and
  x="new (nodes CFGs) (length ll - Suc 0) ! i" in update_list_i, simp+)
apply (clarsimp, cut_tac S="nodes CFGs" in new_nodes_are_new, simp+)
apply (simp add: set_zip, rule_tac x="Suc i" in exI, force)
apply simp
apply (case_tac "Suc i = length ll - 1", clarsimp simp add: last_conv_nth)
apply (clarsimp simp add: rep_edges_def remap_succ_def out_edges_def, rule conjI, clarsimp)
apply (case_tac ll, simp+)
apply (case_tac list, simp, simp add: Let_def)
apply clarsimp
apply (erule_tac x=l in allE, simp add: node_of_graph, erule impE)
apply (metis exits_by_graph)
apply (rule_tac s="{(u, t). (l, u, t) \<in> Edges g}" in subst, simp_all)
apply (subgoal_tac "new (nodes CFGs) (length ll - Suc 0) ! i =
  last (new (nodes CFGs) (length ll - Suc 0))", simp)
apply (rule set_eqI, rule iffI, clarsimp simp add: last_conv_nth, metis)
apply clarsimp
apply (erule disjE, clarsimp)
apply (case_tac "l = aa", simp, clarsimp)
apply (drule pointed_graph.edges_ok, simp, clarsimp)
apply (cut_tac S="nodes CFGs" and m="new (nodes CFGs) (length ll - 1) ! i" in new_nodes_are_new,
  simp+)
apply (force simp add: set_conv_nth)
apply (metis (hide_lams, no_types) One_nat_def nodes_by_graph)
apply clarsimp
apply (case_tac aa, clarsimp)
apply (cut_tac S="nodes CFGs" and n="length ll - Suc 0" in new_nodes_are_new, simp+,
  rule last_in_set, clarsimp+)
apply (cut_tac S1="nodes CFGs" and i=i and j=nat and n1="length ll - 1" in
  nth_eq_iff_index_eq [OF new_nodes_diff], simp+)
apply (simp add: last_conv_nth, case_tac ll, simp+)
apply (case_tac list, simp+)
apply (erule_tac x="pl ! Suc i" in allE, erule impE)
apply (rule_tac x="Suc i" in exI, simp add: nth_butlast)
apply (clarsimp simp add: out_edges_def rep_edges_def remap_succ_def)
apply (rule conjI, clarsimp, case_tac "length ll - 1", simp, simp add: Let_def)
apply (subgoal_tac "new (nodes CFGs) (length ll - Suc 0) ! i \<noteq>
  last (new (nodes CFGs) (length ll - Suc 0))", simp)
apply (clarsimp intro!: ext simp add: edge_types_def, rule conjI, clarsimp)
apply (rule_tac s="{new (nodes CFGs) (length ll - Suc 0) ! Suc i}" in subst, simp_all, rule set_eqI,
  rule iffI, clarsimp)
apply (erule_tac x="Suc i" and P="\<lambda>ab. new (nodes CFGs) (length ll - Suc 0) ! ab =
  new (nodes CFGs) (length ll - Suc 0) ! Suc i \<longrightarrow> (l # new (nodes CFGs)
       (length ll - Suc 0)) ! ab = new (nodes CFGs) (length ll - Suc 0) ! i
        \<longrightarrow> \<not> Suc ab < length ll" in allE, clarsimp+)
apply (erule disjE, clarsimp)
apply (drule pointed_graph.edges_ok, simp, clarsimp)
apply (cut_tac S="nodes CFGs" and m="new (nodes CFGs) (length ll - 1) ! i" in new_nodes_are_new,
  simp+)
apply (force simp add: set_conv_nth)
apply (metis (hide_lams, no_types) One_nat_def nodes_by_graph)
apply clarsimp
apply (case_tac a, simp+)
apply (cut_tac S1="nodes CFGs" and i=nat and j=i and n1="length ll - 1" in
  nth_eq_iff_index_eq [OF new_nodes_diff], simp+)
apply clarsimp
apply (rule_tac s="{}" in subst, simp_all, clarsimp)
apply (drule pointed_graph.edges_ok, simp, clarsimp)
apply (cut_tac S="nodes CFGs" and m="new (nodes CFGs) (length ll - 1) ! i" in new_nodes_are_new,
  simp+)
apply (force simp add: set_conv_nth)
apply (metis (hide_lams, no_types) One_nat_def nodes_by_graph)
apply (case_tac "new (nodes CFGs) (length ll - Suc 0) = []", case_tac "length ll - 1", simp,
  simp add: Let_def)
apply (clarsimp simp add: last_conv_nth)
apply (cut_tac S1="nodes CFGs" and i=i and j="length ll - (Suc (Suc 0))" and n1="length ll - 1" in
  nth_eq_iff_index_eq [OF new_nodes_diff], simp+)
apply (clarsimp simp add: rep_edges_def remap_succ_def, rule conjI, clarsimp)
apply (case_tac "length ll - 1", simp, simp add: Let_def)
apply (clarsimp, (rule conjI, clarsimp)+)
apply (drule pointed_graph.edges_ok, simp, clarsimp)
apply (cut_tac S="nodes CFGs" and m="last (new (nodes CFGs) (length ll - 1))" in new_nodes_are_new,
  simp+, rule last_in_set, simp+, force)
apply clarsimp+
apply (case_tac a, clarsimp+)
apply (cut_tac S1="nodes CFGs" and i=nat and j="Suc nat" and n1="length ll - 1" in
  nth_eq_iff_index_eq [OF new_nodes_diff], simp+)
apply (rule conjI, clarsimp)
apply (cut_tac S="nodes CFGs" in new_nodes_are_new, simp+)
apply (rule new_nodes_diff, simp+)
(* tCFG axioms *)
apply (clarsimp split: if_splits)
apply (erule disjE, cut_tac disjoint, simp_all, simp add: Int_def)
apply (cut_tac S="nodes CFGs" in new_nodes_are_new, simp+, simp add: nodes_by_graph)
apply (erule disjE, cut_tac disjoint, simp_all, simp add: Int_def)
apply (cut_tac S="nodes CFGs" in new_nodes_are_new, simp+, simp add: nodes_by_graph)
apply (cut_tac disjoint, simp_all, simp add: Int_def)
done
qed

lemma apply_some_transfer [rule_format]: "\<lbrakk>P G; \<forall>\<tau> G G'. G' \<in> T \<tau> G \<longrightarrow> P G \<longrightarrow> P G'; apply_some T \<tau> G G'\<rbrakk> \<Longrightarrow>
  P G'"
by (drule_tac P="\<lambda>T' \<tau> G G'. T' = T \<and> P G \<longrightarrow> P G'" in apply_some.induct, auto)

lemma action_disjoint: "\<lbrakk>action_sf a \<sigma> G = Some G'; pre_tCFG G\<rbrakk> \<Longrightarrow> pre_tCFG G'"
apply (frule pre_tCFG.nodes_finite)
apply (case_tac a, auto split: if_splits option.splits simp add: Let_def intro!: pre_tCFG.disjoint_change)
apply (frule pre_tCFG.graphs, simp, clarsimp simp add: pointed_graph_def)
apply (rule conjI, metis)
apply (rule conjI, metis starts_by_graph)
apply (rule conjI, metis exits_by_graph)
apply (simp add: in_edges_def out_edges_def)
apply (cut_tac S="nodes G" in new_nodes_are_new, simp+)
apply (frule pre_tCFG.graphs, simp, clarsimp simp add: pointed_graph_def)
apply (rename_tac m pl l ll g)
apply (rule conjI, clarsimp simp add: rep_edges_def remap_succ_def)
apply (rule conjI, clarsimp)
apply (case_tac "length ll - 1", force, simp add: Let_def)
apply clarsimp
apply (erule disjE, force)
apply clarsimp
apply (case_tac aa, simp add: pre_tCFG.node_of_graph, simp)
apply (simp add: in_edges_def out_edges_def rep_edges_def remap_succ_def)
apply (rule conjI, clarsimp)
apply (case_tac "length ll - 1", force, simp add: Let_def)
apply (clarsimp, (rule conjI, clarsimp+)+)
apply (drule pre_tCFG.graphs, simp)
apply (simp, drule pointed_graph.has_start, cut_tac S="nodes G" and n="length ll - Suc 0"
  in new_nodes_are_new, simp+)
apply (simp add: set_conv_nth, rule_tac x=aa in exI, simp)
apply (simp add: nodes_by_graph)
apply (clarsimp, (rule conjI, clarsimp+)+)
apply (drule pre_tCFG.graphs, simp+)
apply (drule pointed_graph.has_exit, cut_tac S="nodes G" and n="length ll - Suc 0"
  in new_nodes_are_new, simp+)
apply (rule last_in_set, simp+)
apply (simp add: nodes_by_graph)
apply force
apply clarsimp
apply (case_tac aa, simp add: exits_by_graph)
apply (drule pre_tCFG.graphs, simp+)
apply (drule pointed_graph.has_exit, cut_tac S="nodes G" and n="length ll - Suc 0"
  in new_nodes_are_new, simp+)
apply (simp add: set_conv_nth, rule_tac x=nat in exI, simp)
apply (simp add: nodes_by_graph)
apply (frule pre_tCFG.graphs, simp, clarsimp simp add: pointed_graph_def)
apply (rule conjI, metis)
apply (simp add: in_edges_def out_edges_def)
apply (frule pre_tCFG.graphs, simp, clarsimp simp add: pointed_graph_def)
apply (rule conjI, clarsimp simp add: exits_by_graph)
apply (clarsimp simp add: in_edges_def out_edges_def)
apply (metis pre_tCFG.node_of_graph starts_by_graph)
apply (cut_tac A="nodes G" in fresh_new, simp+)
apply (frule pre_tCFG.graphs, simp, clarsimp simp add: pointed_graph_def)
apply (cut_tac A="nodes G" in fresh_new, simp+)
apply (rule conjI, clarsimp simp add: nodes_by_graph, clarsimp simp add: out_edges_def)
apply (rename_tac n m e i u v ty j g)
apply (rule conjI, clarsimp simp add: edges_def ran_def)
apply (frule_tac t=aa in pre_tCFG.graphs, simp+, drule pointed_graph.edges_ok, simp+)
apply (case_tac "aa = thread_of (Exit g) G", simp+)
apply (drule pre_tCFG.disjoint, simp_all, simp add: Int_def)
apply (clarsimp simp add: edges_def ran_def)
apply (frule_tac t=aa in pre_tCFG.graphs, simp+, drule pointed_graph.edges_ok, simp+)
apply (simp add: pre_tCFG.thread_of_correct)
apply (clarsimp, rule conjI, metis)
apply (clarsimp simp add: in_edges_def)
apply (rule conjI, clarsimp simp add: nodes_by_graph, clarsimp)
done

lemma actions_disjoint: "\<lbrakk>action_list_sf list \<sigma> G = Some G'; pre_tCFG G\<rbrakk> \<Longrightarrow> pre_tCFG G'"
apply (induct list arbitrary: G G', simp_all add: action_list_sf_def split: option.splits)
apply (drule action_disjoint, simp+)
done

lemma trans_disjoint: "\<lbrakk>G' \<in> trans_sf T \<tau> G; pre_tCFG G\<rbrakk> \<Longrightarrow> pre_tCFG G'"
apply (induct T arbitrary: \<tau> G G', simp_all, clarsimp)
apply (drule sym, drule actions_disjoint, simp+)
apply auto
apply (cut_tac P=pre_tCFG and T="trans_sf T" in apply_some_transfer, force, simp+)+
done

end

lemma option_if1 [simp]: "((if P then None else x) = Some y) = (\<not>P \<and> x = Some y)"
by simp

lemma option_if2: "((if P then x else None) = Some y) = (P \<and> x = Some y)"
by simp

lemma part_extend_matches: "\<lbrakk>part_matches \<sigma>' (part_extend \<tau> S \<sigma>); x \<in> S\<rbrakk> \<Longrightarrow> \<sigma>' x = \<sigma> x"
by (simp add: part_matches_def part_extend_def)

lemma option_Some1: "((case a of None \<Rightarrow> None | Some b \<Rightarrow> f b) = Some c) =
  (\<exists>b. a = Some b \<and> f b = Some c)"
by (auto split: option.splits)

lemma option_Some2: "(Some c = (case a of None \<Rightarrow> None | Some b \<Rightarrow> f b)) =
  (\<exists>b. a = Some b \<and> f b = Some c)"
by (auto split: option.splits)

end


theory Primitive_Abstract
imports
  Common_Primitive_toString
  Transform
  Conntrack_State_Transform
begin

section\<open>Abstracting over Primitives\<close>

text\<open>Abstract over certain primitives. The first parameter is a function
  @{typ "'i::len common_primitive negation_type \<Rightarrow> bool"} to select the primitives to be abstracted over.
  The @{typ "'i::len common_primitive"} is wrapped in a @{typ "'i::len common_primitive negation_type"} to let the function
  selectively abstract only over negated, non-negated, or both kinds of primitives.
  This functions requires a @{const normalized_nnf_match}.
\<close>
(*requires toString function!*)
fun abstract_primitive
  :: "('i::len common_primitive negation_type \<Rightarrow> bool) \<Rightarrow> 'i common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr"
where
  "abstract_primitive _     MatchAny = MatchAny" |
  "abstract_primitive disc (Match a) =
      (if
         disc (Pos a)
       then
         Match (Extra (common_primitive_toString ipaddr_generic_toString a))
       else
         (Match a))" |
  "abstract_primitive disc (MatchNot (Match a)) =
      (if
         disc (Neg a)
       then
         Match (Extra (''! ''@common_primitive_toString ipaddr_generic_toString a))
       else
         (MatchNot (Match a)))" |
  "abstract_primitive disc (MatchNot m) = MatchNot (abstract_primitive disc m)" |
  "abstract_primitive disc (MatchAnd m1 m2) = MatchAnd (abstract_primitive disc m1) (abstract_primitive disc m2)"

text\<open>For example, a simple firewall requires that no negated interfaces and protocols occur in the
      expression.\<close>
definition abstract_for_simple_firewall :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr"
  where "abstract_for_simple_firewall \<equiv> abstract_primitive (\<lambda>r. case r
                of Pos a \<Rightarrow> is_CT_State a \<or> is_L4_Flags a
                |  Neg a \<Rightarrow> is_Iiface a \<or> is_Oiface a \<or> is_Prot a \<or> is_CT_State a \<or> is_L4_Flags a)"

lemma abstract_primitive_preserves_normalized:
  "normalized_src_ports m \<Longrightarrow> normalized_src_ports (abstract_primitive disc m)"
  "normalized_dst_ports m \<Longrightarrow> normalized_dst_ports (abstract_primitive disc m)"
  "normalized_src_ips m \<Longrightarrow> normalized_src_ips (abstract_primitive disc m)"
  "normalized_dst_ips m \<Longrightarrow> normalized_dst_ips (abstract_primitive disc m)"
  "normalized_nnf_match m \<Longrightarrow> normalized_nnf_match (abstract_primitive disc m)"
  by(induction disc m rule: abstract_primitive.induct) (simp_all)
lemma abstract_primitive_preserves_nodisc:
  "\<not> has_disc disc' m \<Longrightarrow> (\<forall>str. \<not> disc' (Extra str)) \<Longrightarrow> \<not> has_disc disc' (abstract_primitive disc m)"
  by(induction disc m rule: abstract_primitive.induct)(simp_all)
lemma abstract_primitive_preserves_nodisc_nedgated:
  "\<not> has_disc_negated disc' neg m \<Longrightarrow> (\<forall>str. \<not> disc' (Extra str)) \<Longrightarrow> \<not> has_disc_negated disc' neg (abstract_primitive disc m)"
  by(induction disc m arbitrary: neg rule: abstract_primitive.induct) simp+

lemma abstract_primitive_nodisc:
  "\<forall>x. disc' x \<longrightarrow> disc (Pos x) \<and> disc (Neg x)  \<Longrightarrow> (\<forall>str. \<not> disc' (Extra str)) \<Longrightarrow> \<not> has_disc disc' (abstract_primitive disc m)"
  by(induction disc m rule: abstract_primitive.induct) auto

lemma abstract_primitive_preserves_not_has_disc_negated:
  "\<forall>a. \<not> disc (Extra a)\<Longrightarrow> \<not> has_disc_negated disc neg m \<Longrightarrow> \<not> has_disc_negated disc neg (abstract_primitive sel_f m)"
by(induction sel_f m arbitrary: neg rule: abstract_primitive.induct) simp+

lemma abstract_for_simple_firewall_preserves_nodisc_negated:
  "\<forall>a. \<not> disc (Extra a)\<Longrightarrow> \<not> has_disc_negated disc False m \<Longrightarrow> \<not> has_disc_negated disc False (abstract_for_simple_firewall m)"
unfolding abstract_for_simple_firewall_def
using abstract_primitive_preserves_nodisc_nedgated by blast

text\<open>The function @{const ctstate_assume_state} can be used to fix a state and hence remove all state matches from the ruleset.
      It is therefore advisable to create a simple firewall for a fixed state, e.g. with @{const ctstate_assume_new} before
      calling to @{const abstract_for_simple_firewall}.\<close>
lemma not_hasdisc_ctstate_assume_state: "\<not> has_disc is_CT_State (ctstate_assume_state s m)"
  by(induction m rule: ctstate_assume_state.induct) (simp_all)

lemma abstract_for_simple_firewall_hasdisc: fixes m :: "'i::len common_primitive match_expr"
  shows "\<not> has_disc is_CT_State (abstract_for_simple_firewall m)"
  and   "\<not> has_disc is_L4_Flags (abstract_for_simple_firewall m)"
  unfolding abstract_for_simple_firewall_def
  apply(induction "(\<lambda>r:: 'i common_primitive negation_type. case r of Pos a \<Rightarrow> is_CT_State a | Neg a \<Rightarrow> is_Iiface a \<or> is_Oiface a \<or> is_Prot a \<or> is_CT_State a)" m rule: abstract_primitive.induct)
  apply(simp_all)
  done

lemma abstract_for_simple_firewall_negated_ifaces_prots: fixes m :: "'i::len common_primitive match_expr"
  shows  "normalized_nnf_match m \<Longrightarrow> \<not> has_disc_negated (\<lambda>a. is_Iiface a \<or> is_Oiface a) False (abstract_for_simple_firewall m)"
  and "normalized_nnf_match m \<Longrightarrow> \<not> has_disc_negated is_Prot False (abstract_for_simple_firewall m)"
  unfolding abstract_for_simple_firewall_def
  apply(induction "(\<lambda>r:: 'i common_primitive negation_type. case r of Pos a \<Rightarrow> is_CT_State a | Neg a \<Rightarrow> is_Iiface a \<or> is_Oiface a \<or> is_Prot a \<or> is_CT_State a)" m rule: abstract_primitive.induct)
  apply(simp_all)
  done

context
begin
  private lemma abstract_primitive_in_doubt_allow_Allow:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      matches (\<beta>, in_doubt_allow) m action.Accept p \<Longrightarrow>
      matches (\<beta>, in_doubt_allow) (abstract_primitive disc m) action.Accept p"
     by(induction disc m rule: abstract_primitive.induct)
       (simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)

  private lemma abstract_primitive_in_doubt_allow_Allow2:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_allow) m action.Drop p \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_allow) (abstract_primitive disc m) action.Drop p"
     proof(induction disc m rule: abstract_primitive.induct)
     case(5 m1 m2) thus ?case by (auto simp add: bunch_of_lemmata_about_matches(1))
     qed(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)

  private lemma abstract_primitive_in_doubt_allow_Deny:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      matches (\<beta>, in_doubt_allow) (abstract_primitive disc m) action.Drop p \<Longrightarrow>
      matches (\<beta>, in_doubt_allow) m action.Drop p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done

  private lemma abstract_primitive_in_doubt_allow_Deny2:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_allow) (abstract_primitive disc m) action.Accept p \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_allow) m action.Accept p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done

  theorem abstract_primitive_in_doubt_allow_generic:
    fixes \<beta>::"('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac"
    assumes generic: "primitive_matcher_generic \<beta>"
       and n: "\<forall> r \<in> set rs. normalized_nnf_match (get_match r)"
       and simple: "simple_ruleset rs"
    defines "\<gamma> \<equiv> (\<beta>, in_doubt_allow)" and "abstract disc \<equiv> optimize_matches (abstract_primitive disc)"
    shows   "{p. \<gamma>,p\<turnstile> \<langle>abstract disc rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny} \<subseteq> {p. \<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny}"
                (is ?deny)
      and   "{p. \<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow} \<subseteq> {p. \<gamma>,p\<turnstile> \<langle>abstract disc rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow}"
                (is ?allow)
    proof -
      from simple have "good_ruleset rs" using simple_imp_good_ruleset by fast
      from optimize_matches_simple_ruleset simple simple_imp_good_ruleset have
       good: "good_ruleset (optimize_matches (abstract_primitive disc) rs)" by fast

      let ?\<gamma>="(\<beta>, in_doubt_allow) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
        --\<open>type signature is needed, otherwise @{const in_doubt_allow} would be for arbitrary packet\<close>

      have abstract_primitive_in_doubt_allow_help1:
        "approximating_bigstep_fun \<gamma> p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
        if prem: "approximating_bigstep_fun \<gamma> p rs Undecided = Decision FinalAllow" for p
        proof -
          from simple have "wf_ruleset \<gamma> p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding \<gamma>_def
            proof(induction ?\<gamma> p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case (MatchAccept p m a rs)
              from MatchAccept.prems
                abstract_primitive_in_doubt_allow_Allow[OF generic] MatchAccept.hyps have
                "matches ?\<gamma> (abstract_primitive disc m) action.Accept p" by simp
              thus ?case
              apply(simp add: MatchAccept.hyps(2))
              using optimize_matches_matches_fst by fastforce
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches ?\<gamma> (abstract_primitive disc m) a p")
                case False with Nomatch show ?thesis
                  apply(simp add: optimize_matches_def)
                  using simple_ruleset_tail by blast
                next
                case True
                  from Nomatch.prems(1) have "a = action.Accept \<or> a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_allow_Allow2[OF generic] have
                    "a = action.Drop \<Longrightarrow> \<not> matches ?\<gamma> (abstract_primitive disc m) action.Drop p" by simp
                  with True \<open>a = action.Accept \<or> a = action.Drop\<close> have "a = action.Accept" by blast
                  with True show ?thesis
                    using optimize_matches_matches_fst by fastforce
                qed
            qed(simp_all add: simple_ruleset_def)
      qed

      have abstract_primitive_in_doubt_allow_help2:
        "approximating_bigstep_fun \<gamma> p rs Undecided = Decision FinalDeny"
        if prem: "approximating_bigstep_fun \<gamma> p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
        for p
        proof -
          from simple have "wf_ruleset \<gamma> p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding \<gamma>_def
            proof(induction ?\<gamma> p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case Empty thus ?case by(simp add: optimize_matches_def)
            next
            case (MatchAccept p m a rs)
              from MatchAccept.prems abstract_primitive_in_doubt_allow_Allow[OF generic] MatchAccept.hyps have
                1: "matches ?\<gamma> (abstract_primitive disc m) action.Accept p" by simp
              with MatchAccept have "approximating_bigstep_fun ?\<gamma> p
                (Rule (abstract_primitive disc m) action.Accept # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalDeny"
                using optimize_matches_matches_fst by metis
              with 1 have False by(simp)
              thus ?case ..
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches ?\<gamma> (abstract_primitive disc m) a p")
                case False
                with Nomatch.prems(2) have "approximating_bigstep_fun ?\<gamma> p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
                  by(simp add: optimize_matches_def split: if_split_asm)
                with Nomatch have IH: "approximating_bigstep_fun ?\<gamma> p rs Undecided = Decision FinalDeny"
                  using simple_ruleset_tail by auto
                with Nomatch(1) show ?thesis by simp
                next
                case True
                  from Nomatch.prems(2) True have 1: "approximating_bigstep_fun ?\<gamma> p
                    (Rule (abstract_primitive disc m) a # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalDeny"
                    using optimize_matches_matches_fst by metis

                  from Nomatch.prems(1) have "a = action.Accept \<or> a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_allow_Allow2[OF generic] have
                    "a = action.Drop \<Longrightarrow> \<not> matches ?\<gamma> (abstract_primitive disc m) action.Drop p" by simp
                  with True \<open>a = action.Accept \<or> a = action.Drop\<close> have "a = action.Accept" by blast
                  with 1 True have False by simp
                  thus ?thesis ..
                qed
            qed(simp_all add: simple_ruleset_def)
      qed

      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_allow_help1 \<open>good_ruleset rs\<close> show ?allow
        unfolding abstract_def by fast
      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_allow_help2 \<open>good_ruleset rs\<close> \<gamma>_def show ?deny
        unfolding abstract_def by fast
    qed
  corollary abstract_primitive_in_doubt_allow:
    assumes "\<forall> r \<in> set rs. normalized_nnf_match (get_match r)" and "simple_ruleset rs"
    defines "\<gamma> \<equiv> (common_matcher, in_doubt_allow)" and "abstract disc \<equiv> optimize_matches (abstract_primitive disc)"
    shows   "{p. \<gamma>,p\<turnstile> \<langle>abstract disc rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny} \<subseteq> {p. \<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny}"
      and   "{p. \<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow} \<subseteq> {p. \<gamma>,p\<turnstile> \<langle>abstract disc rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow}"
    unfolding \<gamma>_def abstract_def
    using assms abstract_primitive_in_doubt_allow_generic[OF primitive_matcher_generic_common_matcher] by blast+
end

context
begin
  private lemma abstract_primitive_in_doubt_deny_Deny:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      matches (\<beta>, in_doubt_deny) m action.Drop p \<Longrightarrow>
      matches (\<beta>, in_doubt_deny) (abstract_primitive disc m) action.Drop p"
     by(induction disc m rule: abstract_primitive.induct)
       (simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)

  private lemma abstract_primitive_in_doubt_deny_Deny2:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_deny) m action.Accept p \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_deny) (abstract_primitive disc m) action.Accept p"
     proof(induction disc m rule: abstract_primitive.induct)
     case(5 m1 m2) thus ?case by (auto simp add: bunch_of_lemmata_about_matches(1))
     qed(simp_all add: bunch_of_lemmata_about_matches(1) primitive_matcher_generic.Extra_single)

  private lemma abstract_primitive_in_doubt_deny_Allow:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      matches (\<beta>, in_doubt_deny) (abstract_primitive disc m) action.Accept p \<Longrightarrow>
      matches (\<beta>, in_doubt_deny) m action.Accept p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done

  private lemma abstract_primitive_in_doubt_deny_Allow2:
    "primitive_matcher_generic \<beta> \<Longrightarrow> normalized_nnf_match m \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_deny) (abstract_primitive disc m) action.Drop p \<Longrightarrow>
      \<not> matches (\<beta>, in_doubt_deny) m action.Drop p"
     apply(induction disc m rule: abstract_primitive.induct)
           apply (simp_all add: bunch_of_lemmata_about_matches(1))
       apply(auto simp add: primitive_matcher_generic.Extra_single primitive_matcher_generic.Extra_single_not split: if_split_asm)
     done

  theorem abstract_primitive_in_doubt_deny_generic:
    fixes \<beta>::"('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac"
    assumes generic: "primitive_matcher_generic \<beta>"
        and n: "\<forall> r \<in> set rs. normalized_nnf_match (get_match r)"
        and simple: "simple_ruleset rs"
    defines "\<gamma> \<equiv> (\<beta>, in_doubt_deny)" and "abstract disc \<equiv> optimize_matches (abstract_primitive disc)"
    shows   "{p. \<gamma>,p\<turnstile> \<langle>abstract disc rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow} \<subseteq> {p. \<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow}"
             (is ?allow)
    and     "{p. \<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny} \<subseteq> {p. \<gamma>,p\<turnstile> \<langle>abstract disc rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalDeny}"
             (is ?deny)
    proof -
      from simple have "good_ruleset rs" using simple_imp_good_ruleset by fast
      from optimize_matches_simple_ruleset simple simple_imp_good_ruleset have
        good: "good_ruleset (optimize_matches (abstract_primitive disc) rs)" by fast

      let ?\<gamma>="(\<beta>, in_doubt_deny) :: ('i::len common_primitive, ('i, 'a) tagged_packet_scheme) match_tac"
        --\<open>type signature is needed, otherwise @{const in_doubt_allow} would be for arbitrary packet\<close>

      have abstract_primitive_in_doubt_deny_help1:
        "approximating_bigstep_fun \<gamma> p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalDeny"
        if prem: "approximating_bigstep_fun \<gamma> p rs Undecided = Decision FinalDeny" for p
        proof -
          from simple have "wf_ruleset \<gamma> p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding \<gamma>_def
            proof(induction ?\<gamma> p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case (MatchDrop p m a rs)
              from MatchDrop.prems abstract_primitive_in_doubt_deny_Deny[OF generic] MatchDrop.hyps have
                "matches ?\<gamma> (abstract_primitive disc m) action.Drop p" by simp
              thus ?case
              apply(simp add: MatchDrop.hyps(2))
              using optimize_matches_matches_fst by fastforce
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches ?\<gamma> (abstract_primitive disc m) a p")
                case False with Nomatch show ?thesis
                  apply(simp add: optimize_matches_def)
                  using simple_ruleset_tail by blast
                next
                case True
                  from Nomatch.prems(1) have "a = action.Accept \<or> a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_deny_Deny2[OF generic] have
                    "a = action.Accept \<Longrightarrow> \<not> matches ?\<gamma> (abstract_primitive disc m) action.Accept p" by(simp)
                  with True \<open>a = action.Accept \<or> a = action.Drop\<close> have "a = action.Drop" by blast
                  with True show ?thesis using optimize_matches_matches_fst by fastforce
                qed
            qed(simp_all add: simple_ruleset_def)
      qed

      have abstract_primitive_in_doubt_deny_help2:
        "approximating_bigstep_fun \<gamma> p rs Undecided = Decision FinalAllow"
        if prem: "approximating_bigstep_fun \<gamma> p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
        for p
        proof -
          from simple have "wf_ruleset ?\<gamma> p rs" using good_imp_wf_ruleset simple_imp_good_ruleset by fast
          from this simple prem n show ?thesis
            unfolding \<gamma>_def
            proof(induction ?\<gamma> p rs Undecided rule: approximating_bigstep_fun_induct_wf)
            case Empty thus ?case by(simp add: optimize_matches_def)
            next
            case (MatchAccept p m a rs) thus ?case by auto
            next
            case (MatchDrop p m a rs)
              from MatchDrop.prems abstract_primitive_in_doubt_deny_Deny[OF generic] MatchDrop.hyps have
                1: "matches ?\<gamma> (abstract_primitive disc m) action.Drop p" by simp
              from MatchDrop have "approximating_bigstep_fun ?\<gamma> p
                (Rule (abstract_primitive disc m) action.Drop # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalAllow"
              using optimize_matches_matches_fst 1 by fastforce
              with 1 have False by(simp)
              thus ?case ..
            next
            case (Nomatch p m a rs) thus ?case
              proof(cases "matches ?\<gamma> (abstract_primitive disc m) a p")
                case False
                with Nomatch.prems(2) have "approximating_bigstep_fun ?\<gamma> p (optimize_matches (abstract_primitive disc) rs) Undecided = Decision FinalAllow"
                  by(simp add: optimize_matches_def split: if_split_asm)
                with Nomatch have IH: "approximating_bigstep_fun ?\<gamma> p rs Undecided = Decision FinalAllow"
                  using simple_ruleset_tail by auto
                with Nomatch(1) show ?thesis by simp
                next
                case True
                  from Nomatch.prems(2) True have 1: "approximating_bigstep_fun ?\<gamma> p
                    (Rule (abstract_primitive disc m) a # (optimize_matches (abstract_primitive disc) rs)) Undecided = Decision FinalAllow"
                    using optimize_matches_matches_fst by metis
                  from Nomatch.prems(1) have "a = action.Accept \<or> a = action.Drop" by(simp add: simple_ruleset_def)
                  from Nomatch.hyps(1) Nomatch.prems(3) abstract_primitive_in_doubt_deny_Deny2[OF generic] have
                    "a = action.Accept \<Longrightarrow> \<not> matches ?\<gamma> (abstract_primitive disc m) action.Accept p" by simp
                  with True \<open>a = action.Accept \<or> a = action.Drop\<close> have "a = action.Drop" by blast
                  with 1 True have False by force
                  thus ?thesis ..
                qed
            qed(simp_all add: simple_ruleset_def)
      qed

      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_deny_help1 \<open>good_ruleset rs\<close> show ?deny
        unfolding abstract_def by fast
      from good approximating_semantics_iff_fun_good_ruleset abstract_primitive_in_doubt_deny_help2 \<open>good_ruleset rs\<close> show ?allow
        unfolding abstract_def by fast
    qed
end

end


theory Mockup_Test_Abs_Sys
  imports Abstract_System More_Eisbach_Tools
begin
  typedecl state
  typedecl program
  typedecl location

  consts step :: "program \<Rightarrow> state \<Rightarrow> state"
  consts halted :: "program \<Rightarrow> state \<Rightarrow> bool"
  consts location :: "state \<Rightarrow> location"

  definition "stepse \<pi> \<equiv> doE { s\<leftarrow>sget; sput (step \<pi> s) }"

  global_interpretation det_system "stepse \<pi>" "halted \<pi>" for \<pi>
    defines yields = yields'
    .

  declare yields_unfold[code]

  interpretation cfg_system "stepse \<pi>" "halted \<pi>" "\<lambda>_. True" location
    apply unfold_locales by (rule is_weak_invarI) simp

method vcg_clarify = (intro impI conjI)?, (((rule exI, rule conjI, assumption)+ | (simp add: prep_precond_conv))+)?
method vcg_step_aux = (rule wps_rls linvar_unfoldI, (assumption+)?); kbxfer?
method vcg_step = vcg_clarify, vcg_step_aux
method vcg = (vcg_step+, vcg_clarify)

  term htriple

  lemma "htriple \<pi> (\<lambda>s. location s = foo) Q"
    apply (rule floyd_htripleI[where \<Theta>="[
      foo \<mapsto> \<lambda>s. \<not> halted \<pi> s \<and> \<Phi>\<^sub>1 s,
      bar \<mapsto> \<lambda>s. halted \<pi> s \<and> \<Phi>\<^sub>2 s,
      bar2 \<mapsto> \<lambda>s. halted \<pi> s \<and> \<Phi>\<^sub>3 s
      ]"])

    subgoal
      apply (rule linvar_unfoldI)
      apply simp
      sorry

    subgoal
      apply (rule floyd_invarI)
      apply (intro floyd_vcsI; (clarsimp simp: )?)

      apply (subst stepse_def[abs_def])
      apply (simp add: wps_eqs)

      apply (rule linvar_unfoldI)
      apply clarsimp apply (intro impI conjI; simp?)

      prefer 16
      apply (subst stepse_def[abs_def])
      apply (simp add: wps_eqs)
      sorry

    subgoal for s
      apply (clarsimp split: if_splits)
      sorry

    oops

  term "yields \<pi>"

end


(*  Title:      HOL/UNITY/Comp/AllocImpl.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section{*Implementation of a multiple-client allocator from a single-client allocator*}

theory AllocImpl imports AllocBase "../Follows" "../PPROD" begin

(** State definitions.  OUTPUT variables are locals **)

(*Type variable 'b is the type of items being merged*)
record 'b merge =
  In   :: "nat => 'b list"  (*merge's INPUT histories: streams to merge*)
  Out  :: "'b list"         (*merge's OUTPUT history: merged items*)
  iOut :: "nat list"        (*merge's OUTPUT history: origins of merged items*)

record ('a,'b) merge_d =
  "'b merge" +
  dummy :: 'a       (*dummy field for new variables*)

definition non_dummy :: "('a,'b) merge_d => 'b merge" where
    "non_dummy s = (|In = In s, Out = Out s, iOut = iOut s|)"

record 'b distr =
  In  :: "'b list"          (*items to distribute*)
  iIn :: "nat list"         (*destinations of items to distribute*)
  Out :: "nat => 'b list"   (*distributed items*)

record ('a,'b) distr_d =
  "'b distr" +
  dummy :: 'a       (*dummy field for new variables*)

record allocState =
  giv :: "nat list"   (*OUTPUT history: source of tokens*)
  ask :: "nat list"   (*INPUT: tokens requested from allocator*)
  rel :: "nat list"   (*INPUT: tokens released to allocator*)

record 'a allocState_d =
  allocState +
  dummy    :: 'a                (*dummy field for new variables*)

record 'a systemState =
  allocState +
  mergeRel :: "nat merge"
  mergeAsk :: "nat merge"
  distr    :: "nat distr"
  dummy    :: 'a                  (*dummy field for new variables*)

(** Merge specification (the number of inputs is Nclients) ***)

definition
  (*spec (10)*)
  merge_increasing :: "('a,'b) merge_d program set"
  where "merge_increasing =
         UNIV guarantees (Increasing merge.Out) Int (Increasing merge.iOut)"

definition
  (*spec (11)*)
  merge_eqOut :: "('a,'b) merge_d program set"
  where "merge_eqOut =
         UNIV guarantees
         Always {s. length (merge.Out s) = length (merge.iOut s)}"

definition
  (*spec (12)*)
  merge_bounded :: "('a,'b) merge_d program set"
  where "merge_bounded =
         UNIV guarantees
         Always {s. \<forall>elt \<in> set (merge.iOut s). elt < Nclients}"

definition
  (*spec (13)*)
  merge_follows :: "('a,'b) merge_d program set"
  where "merge_follows =
         (\<Inter>i \<in> lessThan Nclients. Increasing (sub i o merge.In))
         guarantees
         (\<Inter>i \<in> lessThan Nclients.
          (%s. sublist (merge.Out s)
                       {k. k < size(merge.iOut s) & merge.iOut s! k = i})
          Fols (sub i o merge.In))"

definition
  (*spec: preserves part*)
  merge_preserves :: "('a,'b) merge_d program set"
  where "merge_preserves = preserves merge.In Int preserves merge_d.dummy"

definition
  (*environmental constraints*)
  merge_allowed_acts :: "('a,'b) merge_d program set"
  where "merge_allowed_acts =
       {F. AllowedActs F =
            insert Id (UNION (preserves (funPair merge.Out merge.iOut)) Acts)}"

definition
  merge_spec :: "('a,'b) merge_d program set"
  where "merge_spec = merge_increasing Int merge_eqOut Int merge_bounded Int
                   merge_follows Int merge_allowed_acts Int merge_preserves"

(** Distributor specification (the number of outputs is Nclients) ***)

definition
  (*spec (14)*)
  distr_follows :: "('a,'b) distr_d program set"
  where "distr_follows =
         Increasing distr.In Int Increasing distr.iIn Int
         Always {s. \<forall>elt \<in> set (distr.iIn s). elt < Nclients}
         guarantees
         (\<Inter>i \<in> lessThan Nclients.
          (sub i o distr.Out) Fols
          (%s. sublist (distr.In s)
                       {k. k < size(distr.iIn s) & distr.iIn s ! k = i}))"

definition
  distr_allowed_acts :: "('a,'b) distr_d program set"
  where "distr_allowed_acts =
       {D. AllowedActs D = insert Id (UNION (preserves distr.Out) Acts)}"

definition
  distr_spec :: "('a,'b) distr_d program set"
  where "distr_spec = distr_follows Int distr_allowed_acts"

(** Single-client allocator specification (required) ***)

definition
  (*spec (18)*)
  alloc_increasing :: "'a allocState_d program set"
  where "alloc_increasing = UNIV  guarantees  Increasing giv"

definition
  (*spec (19)*)
  alloc_safety :: "'a allocState_d program set"
  where "alloc_safety =
         Increasing rel
         guarantees  Always {s. tokens (giv s) \<le> NbT + tokens (rel s)}"

definition
  (*spec (20)*)
  alloc_progress :: "'a allocState_d program set"
  where "alloc_progress =
         Increasing ask Int Increasing rel Int
         Always {s. \<forall>elt \<in> set (ask s). elt \<le> NbT}
         Int
         (\<Inter>h. {s. h \<le> giv s & h pfixGe (ask s)}
                 LeadsTo
                 {s. tokens h \<le> tokens (rel s)})
         guarantees  (\<Inter>h. {s. h \<le> ask s} LeadsTo {s. h pfixLe giv s})"

definition
  (*spec: preserves part*)
  alloc_preserves :: "'a allocState_d program set"
  where "alloc_preserves = preserves rel Int
                        preserves ask Int
                        preserves allocState_d.dummy"

definition
  (*environmental constraints*)
  alloc_allowed_acts :: "'a allocState_d program set"
  where "alloc_allowed_acts =
       {F. AllowedActs F = insert Id (UNION (preserves giv) Acts)}"

definition
  alloc_spec :: "'a allocState_d program set"
  where "alloc_spec = alloc_increasing Int alloc_safety Int alloc_progress Int
                   alloc_allowed_acts Int alloc_preserves"

locale Merge =
  fixes M :: "('a,'b::order) merge_d program"
  assumes
    Merge_spec:  "M  \<in> merge_spec"

locale Distrib =
  fixes D :: "('a,'b::order) distr_d program"
  assumes
    Distrib_spec:  "D \<in> distr_spec"

(****
#  {** Network specification ***}

#    {*spec (9.1)*}
#    network_ask :: "'a systemState program set
#       "network_ask == \<Inter>i \<in> lessThan Nclients.
#                           Increasing (ask o sub i o client)
#                           guarantees[ask]
#                           (ask  Fols (ask o sub i o client))"

#    {*spec (9.2)*}
#    network_giv :: "'a systemState program set
#       "network_giv == \<Inter>i \<in> lessThan Nclients.
#                           Increasing giv
#                           guarantees[giv o sub i o client]
#                           ((giv o sub i o client) Fols giv)"

#    {*spec (9.3)*}
#    network_rel :: "'a systemState program set
#       "network_rel == \<Inter>i \<in> lessThan Nclients.
#                           Increasing (rel o sub i o client)
#                           guarantees[rel]
#                           (rel  Fols (rel o sub i o client))"

#    {*spec: preserves part*}
#       network_preserves :: "'a systemState program set
#       "network_preserves == preserves giv  Int
#                             (\<Inter>i \<in> lessThan Nclients.
#                              preserves (funPair rel ask o sub i o client))"

#    network_spec :: "'a systemState program set
#       "network_spec == network_ask Int network_giv Int
#                        network_rel Int network_preserves"

#  {** State mappings **}
#    sysOfAlloc :: "((nat => merge) * 'a) allocState_d => 'a systemState"
#       "sysOfAlloc == %s. let (cl,xtr) = allocState_d.dummy s
#                          in (| giv = giv s,
#                                ask = ask s,
#                                rel = rel s,
#                                client   = cl,
#                                dummy    = xtr|)"

#    sysOfClient :: "(nat => merge) * 'a allocState_d => 'a systemState"
#       "sysOfClient == %(cl,al). (| giv = giv al,
#                                    ask = ask al,
#                                    rel = rel al,
#                                    client   = cl,
#                                    systemState.dummy = allocState_d.dummy al|)"
****)

declare subset_preserves_o [THEN subsetD, intro]
declare funPair_o_distrib [simp]
declare Always_INT_distrib [simp]
declare o_apply [simp del]

subsection{*Theorems for Merge*}

context Merge
begin

lemma Merge_Allowed:
     "Allowed M = (preserves merge.Out) Int (preserves merge.iOut)"
apply (cut_tac Merge_spec)
apply (auto simp add: merge_spec_def merge_allowed_acts_def Allowed_def
                      safety_prop_Acts_iff)
done

lemma M_ok_iff [iff]:
     "M ok G = (G \<in> preserves merge.Out & G \<in> preserves merge.iOut &
                     M \<in> Allowed G)"
by (auto simp add: Merge_Allowed ok_iff_Allowed)

lemma Merge_Always_Out_eq_iOut:
     "[| G \<in> preserves merge.Out; G \<in> preserves merge.iOut; M \<in> Allowed G |]
      ==> M Join G \<in> Always {s. length (merge.Out s) = length (merge.iOut s)}"
apply (cut_tac Merge_spec)
apply (force dest: guaranteesD simp add: merge_spec_def merge_eqOut_def)
done

lemma Merge_Bounded:
     "[| G \<in> preserves merge.iOut; G \<in> preserves merge.Out; M \<in> Allowed G |]
      ==> M Join G \<in> Always {s. \<forall>elt \<in> set (merge.iOut s). elt < Nclients}"
apply (cut_tac Merge_spec)
apply (force dest: guaranteesD simp add: merge_spec_def merge_bounded_def)
done

lemma Merge_Bag_Follows_lemma:
     "[| G \<in> preserves merge.iOut; G \<in> preserves merge.Out; M \<in> Allowed G |]
  ==> M Join G \<in> Always
          {s. (\<Sum>i \<in> lessThan Nclients. bag_of (sublist (merge.Out s)
                                  {k. k < length (iOut s) & iOut s ! k = i})) =
              (bag_of o merge.Out) s}"
apply (rule Always_Compl_Un_eq [THEN iffD1])
apply (blast intro: Always_Int_I [OF Merge_Always_Out_eq_iOut Merge_Bounded])
apply (rule UNIV_AlwaysI, clarify)
apply (subst bag_of_sublist_UN_disjoint [symmetric])
  apply (simp)
 apply blast
apply (simp add: set_conv_nth)
apply (subgoal_tac
       "(\<Union>i \<in> lessThan Nclients. {k. k < length (iOut x) & iOut x ! k = i}) =
       lessThan (length (iOut x))")
 apply (simp (no_asm_simp) add: o_def)
apply blast
done

lemma Merge_Bag_Follows:
     "M \<in> (\<Inter>i \<in> lessThan Nclients. Increasing (sub i o merge.In))
          guarantees
             (bag_of o merge.Out) Fols
             (%s. \<Sum>i \<in> lessThan Nclients. (bag_of o sub i o merge.In) s)"
apply (rule Merge_Bag_Follows_lemma [THEN Always_Follows1, THEN guaranteesI], auto)
apply (rule Follows_setsum)
apply (cut_tac Merge_spec)
apply (auto simp add: merge_spec_def merge_follows_def o_def)
apply (drule guaranteesD)
  prefer 3
  apply (best intro: mono_bag_of [THEN mono_Follows_apply, THEN subsetD], auto)
done

end

subsection{*Theorems for Distributor*}

context Distrib
begin

lemma Distr_Increasing_Out:
     "D \<in> Increasing distr.In Int Increasing distr.iIn Int
          Always {s. \<forall>elt \<in> set (distr.iIn s). elt < Nclients}
          guarantees
          (\<Inter>i \<in> lessThan Nclients. Increasing (sub i o distr.Out))"
apply (cut_tac Distrib_spec)
apply (simp add: distr_spec_def distr_follows_def)
apply clarify
apply (blast intro: guaranteesI Follows_Increasing1 dest: guaranteesD)
done

lemma Distr_Bag_Follows_lemma:
     "[| G \<in> preserves distr.Out;
         D Join G \<in> Always {s. \<forall>elt \<in> set (distr.iIn s). elt < Nclients} |]
  ==> D Join G \<in> Always
          {s. (\<Sum>i \<in> lessThan Nclients. bag_of (sublist (distr.In s)
                                  {k. k < length (iIn s) & iIn s ! k = i})) =
              bag_of (sublist (distr.In s) (lessThan (length (iIn s))))}"
apply (erule Always_Compl_Un_eq [THEN iffD1])
apply (rule UNIV_AlwaysI, clarify)
apply (subst bag_of_sublist_UN_disjoint [symmetric])
  apply (simp (no_asm))
 apply blast
apply (simp add: set_conv_nth)
apply (subgoal_tac
       "(\<Union>i \<in> lessThan Nclients. {k. k < length (iIn x) & iIn x ! k = i}) =
        lessThan (length (iIn x))")
 apply (simp (no_asm_simp))
apply blast
done

lemma D_ok_iff [iff]:
     "D ok G = (G \<in> preserves distr.Out & D \<in> Allowed G)"
apply (cut_tac Distrib_spec)
apply (auto simp add: distr_spec_def distr_allowed_acts_def Allowed_def
                      safety_prop_Acts_iff ok_iff_Allowed)
done

lemma Distr_Bag_Follows:
 "D \<in> Increasing distr.In Int Increasing distr.iIn Int
      Always {s. \<forall>elt \<in> set (distr.iIn s). elt < Nclients}
      guarantees
       (\<Inter>i \<in> lessThan Nclients.
        (%s. \<Sum>i \<in> lessThan Nclients. (bag_of o sub i o distr.Out) s)
        Fols
        (%s. bag_of (sublist (distr.In s) (lessThan (length(distr.iIn s))))))"
apply (rule guaranteesI, clarify)
apply (rule Distr_Bag_Follows_lemma [THEN Always_Follows2], auto)
apply (rule Follows_setsum)
apply (cut_tac Distrib_spec)
apply (auto simp add: distr_spec_def distr_follows_def o_def)
apply (drule guaranteesD)
  prefer 3
  apply (best intro: mono_bag_of [THEN mono_Follows_apply, THEN subsetD], auto)
done

end

subsection{*Theorems for Allocator*}

lemma alloc_refinement_lemma:
     "!!f::nat=>nat. (\<Inter>i \<in> lessThan n. {s. f i \<le> g i s})
      \<subseteq> {s. (SUM x: lessThan n. f x) \<le> (SUM x: lessThan n. g x s)}"
apply (induct_tac "n")
apply (auto simp add: lessThan_Suc)
done

lemma alloc_refinement:
"(\<Inter>i \<in> lessThan Nclients. Increasing (sub i o allocAsk) Int
                           Increasing (sub i o allocRel))
  Int
  Always {s. \<forall>i. i<Nclients -->
              (\<forall>elt \<in> set ((sub i o allocAsk) s). elt \<le> NbT)}
  Int
  (\<Inter>i \<in> lessThan Nclients.
   \<Inter>h. {s. h \<le> (sub i o allocGiv)s & h pfixGe (sub i o allocAsk)s}
        LeadsTo {s. tokens h \<le> (tokens o sub i o allocRel)s})
  \<subseteq>
 (\<Inter>i \<in> lessThan Nclients. Increasing (sub i o allocAsk) Int
                           Increasing (sub i o allocRel))
  Int
  Always {s. \<forall>i. i<Nclients -->
              (\<forall>elt \<in> set ((sub i o allocAsk) s). elt \<le> NbT)}
  Int
  (\<Inter>hf. (\<Inter>i \<in> lessThan Nclients.
         {s. hf i \<le> (sub i o allocGiv)s & hf i pfixGe (sub i o allocAsk)s})
  LeadsTo {s. (\<Sum>i \<in> lessThan Nclients. tokens (hf i)) \<le>
              (\<Sum>i \<in> lessThan Nclients. (tokens o sub i o allocRel)s)})"
apply (auto simp add: ball_conj_distrib)
apply (rename_tac F hf)
apply (rule LeadsTo_weaken_R [OF Finite_stable_completion alloc_refinement_lemma], blast, blast)
apply (subgoal_tac "F \<in> Increasing (tokens o (sub i o allocRel))")
 apply (simp add: Increasing_def o_assoc)
apply (blast intro: mono_tokens [THEN mono_Increasing_o, THEN subsetD])
done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
 * This file contains theorems for dealing with a "simply" lifted
 * heap, where each byte of memory can be accessed as one (and only)
 * type.
 *
 * This is a simpler model of Tuch's "lift_t" model, where nested
 * struct fields cannot be directly accessed as pointers.
 *)

theory TypHeapSimple
imports
  "CLib.TypHeapLib"
begin

(*
 * Each address in the heap can contain one of three things:
 *
 *   - A type tag, which inidicates that this address is the first
 *     byte of an object;
 *
 *   - A footprint, which indicates that this address is a latter byte
 *     of an object;
 *
 *   - Nothing, which indicates that this address does not fall inside
 *     an object.
 *)
datatype heap_typ_contents =
    HeapType typ_uinfo
  | HeapFootprint
  | HeapEmpty

(*
 * Given a Tuch-style heap representation (where each memory location
 * contains a set of different types, representing nested field types)
 * calculate a single top-level type of the heap.
 *
 * We just want to commit to a single type for this heap location,
 * and nothing more.
 *)
definition
  heap_type_tag :: "heap_typ_desc \<Rightarrow> addr \<Rightarrow> heap_typ_contents"
where
  "heap_type_tag d a \<equiv>
     (if fst (d a) = False \<or> (\<forall>x. (snd (d a)) x = None) \<or> (\<forall>x. (snd (d a)) x \<noteq> None) then
       HeapEmpty
     else
       case (snd (d a)) (GREATEST x. snd (d a) x \<noteq> None) of
         Some (_, False) \<Rightarrow> HeapFootprint
       | Some (x, True) \<Rightarrow> HeapType x
       | None \<Rightarrow> HeapEmpty)"

(*
 * Determine if the heap has a valid footprint for the given type at
 * the given address.
 *
 * A valid footprint means that the user has committed that the given
 * memory location will only be used for the given type.
 *
 * A "simple" footprint differs from the Tuch-style because we only
 * commit to a single type, and have no support for accessing nested
 * structures.
 *)
definition
  valid_simple_footprint :: "heap_typ_desc \<Rightarrow> addr \<Rightarrow> typ_uinfo \<Rightarrow> bool"
where
  "valid_simple_footprint d x t \<equiv>
    heap_type_tag d x = HeapType t \<and>
      (\<forall>y. y \<in> {x + 1..+  (size_td t)- Suc 0} \<longrightarrow> heap_type_tag d y = HeapFootprint)"

lemma valid_simple_footprintI:
  "\<lbrakk> heap_type_tag d x = HeapType t; \<And>y. y \<in> {x + 1..+(size_td t) - Suc 0} \<Longrightarrow> heap_type_tag d y = HeapFootprint \<rbrakk>
      \<Longrightarrow> valid_simple_footprint d x t"
  by (clarsimp simp: valid_simple_footprint_def)

lemma valid_simple_footprintD:
  "valid_simple_footprint d x t \<Longrightarrow> heap_type_tag d x = HeapType t"
  by (simp add: valid_simple_footprint_def)

lemma valid_simple_footprintD2:
  "\<lbrakk> valid_simple_footprint d x t; y \<in> {x + 1..+(size_td t) - Suc 0} \<rbrakk> \<Longrightarrow> heap_type_tag d y = HeapFootprint"
  by (simp add: valid_simple_footprint_def)

lemma typ_slices_not_empty:
    "typ_slices (x::('a::{mem_type} itself)) \<noteq> []"
  apply (clarsimp simp: typ_slices_def)
  done

lemma last_typ_slice_t:
    "(last (typ_slice_t t 0)) = (t, True)"
  apply (case_tac t)
  apply clarsimp
  done

lemma if_eqI:
 "\<lbrakk> a \<Longrightarrow> x = z; \<not> a \<Longrightarrow> y = z \<rbrakk> \<Longrightarrow> (if a then x else y) = z"
  by simp

lemma heap_type_tag_ptr_retyp:
    "snd (s (ptr_val t)) = Map.empty \<Longrightarrow>
        heap_type_tag (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t) = HeapType (typ_uinfo_t TYPE('a))"
  apply (unfold ptr_retyp_def heap_type_tag_def)
  apply (subst htd_update_list_index, fastforce, fastforce)+
  apply (rule if_eqI)
   apply clarsimp
   apply (erule disjE)
    apply (erule_tac x=0 in allE)
    apply clarsimp
   apply (erule_tac x="length (typ_slice_t (typ_uinfo_t TYPE('a)) 0)" in allE)
   apply (clarsimp simp: list_map_eq)
  apply (clarsimp simp: list_map_eq last_conv_nth [simplified, symmetric] last_typ_slice_t
            split: option.splits if_split_asm prod.splits)
  done

lemma not_snd_last_typ_slice_t:
    "k \<noteq> 0 \<Longrightarrow> \<not> snd (last (typ_slice_t z k))"
  by (case_tac z, clarsimp)

lemma heap_type_tag_ptr_retyp_rest:
    "\<lbrakk> snd (s (ptr_val t + k)) = Map.empty; 0 < k; unat k < size_td (typ_uinfo_t TYPE('a)) \<rbrakk> \<Longrightarrow>
        heap_type_tag (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t + k) = HeapFootprint"
  apply (unfold ptr_retyp_def heap_type_tag_def)
  apply (subst htd_update_list_index, simp, clarsimp,
      metis intvlI size_of_def word_unat.Rep_inverse)+
  apply (rule if_eqI)
   apply clarsimp
   apply (erule disjE)
    apply (erule_tac x=0 in allE)
    apply (clarsimp simp: size_of_def)
   apply (erule_tac x="length (typ_slice_t (typ_uinfo_t TYPE('a)) (unat k))" in allE)
   apply (clarsimp simp: size_of_def list_map_eq)
  apply (clarsimp simp: list_map_eq last_conv_nth [simplified, symmetric] size_of_def
      split: option.splits if_split_asm prod.splits bool.splits)
   apply (metis surj_pair)
  apply (subst (asm) (2) surjective_pairing)
  apply (subst (asm) not_snd_last_typ_slice_t)
   apply clarsimp
   apply unat_arith
  apply simp
  done

lemma typ_slices_addr_card [simp]:
    "length (typ_slices (x::('a::{mem_type} itself))) < addr_card"
  apply (clarsimp simp: typ_slices_def)
  done

lemma htd_update_list_same':
  "\<lbrakk>0 < unat k; unat k \<le> addr_card - length v\<rbrakk> \<Longrightarrow> htd_update_list (p + k) v h p = h p"
  apply (insert htd_update_list_same [where v=v and p=p and h=h and k="unat k"])
  apply clarsimp
  done

lemma unat_less_impl_less:
    "unat a < unat b \<Longrightarrow> a < b"
  by unat_arith

lemma valid_simple_footprint_ptr_retyp:
    "\<lbrakk> \<forall>k < size_td (typ_uinfo_t TYPE('a)). snd (s (ptr_val t + of_nat k)) = Map.empty;
        1 \<le> size_td (typ_uinfo_t TYPE('a));
        size_td (typ_uinfo_t TYPE('a)) < addr_card \<rbrakk>
        \<Longrightarrow> valid_simple_footprint (ptr_retyp (t :: 'a::mem_type ptr) s) (ptr_val t) (typ_uinfo_t TYPE('a))"
  apply (clarsimp simp: valid_simple_footprint_def)
  apply (rule conjI)
   apply (subst heap_type_tag_ptr_retyp)
    apply (erule allE [where x="0"])
    apply clarsimp
   apply clarsimp
  apply (clarsimp simp: intvl_def)
  apply (erule_tac x="k + 1" in allE)
  apply (erule impE)
   apply (metis One_nat_def less_diff_conv)
  apply (subst add.assoc, subst heap_type_tag_ptr_retyp_rest)
     apply clarsimp
    apply (case_tac "1 + of_nat k = (0 :: addr)")
     apply (metis add.left_neutral intvlI intvl_Suc_nmem size_of_def)
    apply unat_arith
   apply clarsimp
   apply (metis lt_size_of_unat_simps size_of_def Suc_eq_plus1 One_nat_def less_diff_conv of_nat_Suc)
  apply simp
  done

(* Determine if the given pointer is valid in the given heap. *)
definition
  heap_ptr_valid :: "heap_typ_desc \<Rightarrow> 'a::c_type ptr \<Rightarrow> bool"
where
  "heap_ptr_valid d p \<equiv>
      valid_simple_footprint d (ptr_val (p::'a ptr)) (typ_uinfo_t TYPE('a))
        \<and> c_guard p"

(*
 * Lift a heap from raw bytes and a heap description into
 * higher-level objects.
 *
 * This differs from Tuch's "lift_t" because we only support
 * simple lifting; that is, each byte in the heap may only
 * be accessed as a single type. Accessing struct fields by
 * their pointers is not supported.
 *)
definition
  simple_lift :: "heap_raw_state \<Rightarrow> ('a::c_type) ptr \<Rightarrow> 'a option"
where
  "simple_lift s p = (
     if (heap_ptr_valid (hrs_htd s) p) then
       (Some (h_val (hrs_mem s) p))
     else
       None)"

lemma simple_lift_heap_ptr_valid:
  "simple_lift s p = Some x \<Longrightarrow> heap_ptr_valid (hrs_htd s) p"
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  done

lemma simple_lift_c_guard:
  "simple_lift s p = Some x \<Longrightarrow> c_guard p"
  apply (clarsimp simp: simple_lift_def heap_ptr_valid_def split: if_split_asm)
  done

(* Two valid footprints will either overlap completely or not at all. *)
lemma valid_simple_footprint_neq:
  assumes valid_p: "valid_simple_footprint d p s"
      and valid_q: "valid_simple_footprint d q t"
      and neq: "p \<noteq> q"
  shows "p \<notin> {q..+ (size_td t)}"
proof -
  have heap_type_p: "heap_type_tag d p = HeapType s"
    apply (metis valid_p valid_simple_footprint_def)
    done

  have heap_type_q: "heap_type_tag d q = HeapType t"
    apply (metis valid_q valid_simple_footprint_def)
    done

  have heap_type_q_footprint:
    "\<And>x. x \<in> {(q + 1)..+(size_td t - Suc 0)} \<Longrightarrow> heap_type_tag d x = HeapFootprint"
    apply (insert valid_q)
    apply (simp add: valid_simple_footprint_def)
    done

  show ?thesis
    using heap_type_q_footprint heap_type_p neq
         intvl_neq_start heap_type_q
    by (metis heap_typ_contents.simps(2))
qed

(* Two valid footprints with different types will never overlap. *)
lemma valid_simple_footprint_type_neq:
  "\<lbrakk> valid_simple_footprint d p s;
     valid_simple_footprint d q t;
     s \<noteq> t \<rbrakk> \<Longrightarrow>
   p \<notin> {q..+ (size_td t)}"
  apply (subgoal_tac "p \<noteq> q")
   apply (rule valid_simple_footprint_neq, simp_all)[1]
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma valid_simple_footprint_neq_disjoint:
  "\<lbrakk> valid_simple_footprint d p s; valid_simple_footprint d q t; p \<noteq> q \<rbrakk> \<Longrightarrow>
      {p..+(size_td s)} \<inter> {q..+ (size_td t)} = {}"
  apply (rule ccontr)
  apply (fastforce simp: valid_simple_footprint_neq dest!: intvl_inter)
  done

lemma valid_simple_footprint_type_neq_disjoint:
  "\<lbrakk> valid_simple_footprint d p s;
     valid_simple_footprint d q t;
     s \<noteq> t \<rbrakk> \<Longrightarrow>
   {p..+(size_td s)} \<inter> {q..+ (size_td t)} = {}"
  apply (subgoal_tac "p \<noteq> q")
   apply (rule valid_simple_footprint_neq_disjoint, simp_all)[1]
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma heap_ptr_valid_neq_disjoint:
  "\<lbrakk> heap_ptr_valid d (p::'a::c_type ptr);
     heap_ptr_valid d (q::'b::c_type ptr);
     ptr_val p \<noteq> ptr_val q \<rbrakk> \<Longrightarrow>
   {ptr_val p..+size_of TYPE('a)} \<inter>
          {ptr_val q..+size_of TYPE('b)} = {}"
  apply (clarsimp simp only: size_of_tag [symmetric])
  apply (rule valid_simple_footprint_neq_disjoint [where d="d"])
    apply (clarsimp simp: heap_ptr_valid_def)
   apply (clarsimp simp: heap_ptr_valid_def)
  apply simp
  done

lemma heap_ptr_valid_type_neq_disjoint:
  "\<lbrakk> heap_ptr_valid d (p::'a::c_type ptr);
     heap_ptr_valid d (q::'b::c_type ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   {ptr_val p..+size_of TYPE('a)} \<inter>
          {ptr_val q..+size_of TYPE('b)} = {}"
  apply (subgoal_tac "ptr_val p \<noteq> ptr_val q")
   apply (rule heap_ptr_valid_neq_disjoint, auto)[1]
  apply (clarsimp simp: heap_ptr_valid_def valid_simple_footprint_def)
  done

(* If we update one pointer in the heap, other valid pointers will be unaffected. *)
lemma heap_ptr_valid_heap_update_other:
  assumes val_p: "heap_ptr_valid d (p::'a::mem_type ptr)"
      and val_q: "heap_ptr_valid d (q::'b::c_type ptr)"
      and neq: "ptr_val p \<noteq> ptr_val q"
  shows "h_val (heap_update p v h) q = h_val h q"
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply simp
   apply (rule heap_ptr_valid_neq_disjoint [OF val_p val_q neq])
  apply simp
  done

(* If we update one type in the heap, other types will be unaffected. *)
lemma heap_ptr_valid_heap_update_other_typ:
  assumes val_p: "heap_ptr_valid d (p::'a::mem_type ptr)"
      and val_q: "heap_ptr_valid d (q::'b::c_type ptr)"
      and neq: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b)"
  shows "h_val (heap_update p v h) q = h_val h q"
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply simp
   apply (rule heap_ptr_valid_type_neq_disjoint [OF val_p val_q neq])
  apply simp
  done

(* Updating the raw heap is equivalent to updating the lifted heap. *)
lemma simple_lift_heap_update:
  "\<lbrakk> heap_ptr_valid (hrs_htd h) p \<rbrakk> \<Longrightarrow>
      simple_lift (hrs_mem_update (heap_update p v) h)
          = (simple_lift h)(p := Some (v::'a::mem_type))"
  apply (rule ext)
  apply (clarsimp simp: simple_lift_def hrs_mem_update h_val_heap_update)
  apply (fastforce simp: heap_ptr_valid_heap_update_other)
  done

(* Updating the raw heap of one type doesn't affect the lifted heap of other types. *)
lemma simple_lift_heap_update_other:
  "\<lbrakk> heap_ptr_valid (hrs_htd d) (p::'b::mem_type ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update p v) d) = ((simple_lift d)::'a::c_type typ_heap)"
  apply (rule ext)+
  apply (clarsimp simp: simple_lift_def h_val_heap_update hrs_mem_update)
  apply (auto intro: heap_ptr_valid_heap_update_other_typ)
  done

lemma h_val_simple_lift:
  "simple_lift h p = Some v \<Longrightarrow> h_val (hrs_mem h) p = v"
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  done

lemma h_val_field_simple_lift:
  "\<lbrakk> simple_lift h (pa :: 'a ptr) = Some (v::'a::mem_type);
     \<exists>t. field_ti TYPE('a) f = Some t;
     export_uinfo (the (field_ti TYPE('a) f)) = export_uinfo (typ_info_t TYPE('b :: mem_type)) \<rbrakk> \<Longrightarrow>
   h_val (hrs_mem h) (Ptr &(pa\<rightarrow>f) :: 'b :: mem_type ptr) = from_bytes (access_ti\<^sub>0 (the (field_ti TYPE('a) f)) v)"
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  apply (clarsimp simp: h_val_field_from_bytes)
  done

lemma simple_lift_heap_update':
  "simple_lift h p = Some v' \<Longrightarrow>
      simple_lift (hrs_mem_update (heap_update (p::('a::{mem_type}) ptr) v) h)
          = (simple_lift h)(p := Some v)"
  apply (rule simple_lift_heap_update)
  apply (erule simple_lift_heap_ptr_valid)
  done

lemma simple_lift_hrs_mem_update_None [simp]:
    "(simple_lift (hrs_mem_update a hp) x = None) = (simple_lift hp x = None)"
  apply (clarsimp simp: simple_lift_def)
  done

lemma simple_lift_data_eq:
   "\<lbrakk> h_val (hrs_mem h) p = h_val (hrs_mem h') p';
     heap_ptr_valid (hrs_htd h) p = heap_ptr_valid (hrs_htd h') p' \<rbrakk> \<Longrightarrow>
    simple_lift h p = simple_lift h' p'"
  apply (clarsimp simp: simple_lift_def)
  done

lemma h_val_heap_update_disjoint:
  "\<lbrakk> {ptr_val p ..+ size_of TYPE('a::c_type)}
        \<inter> {ptr_val q ..+ size_of TYPE('b::mem_type)} = {} \<rbrakk> \<Longrightarrow>
      h_val (heap_update (q :: 'b ptr) r h) (p :: 'a ptr) = h_val h p"
  apply (clarsimp simp: h_val_def)
  apply (clarsimp simp: heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
   apply blast
   apply clarsimp
  done

lemma update_ti_t_valid_size:
  "size_of TYPE('b) = size_td t \<Longrightarrow>
   update_ti_t t (to_bytes_p (val::'b::mem_type)) obj = update_ti t (to_bytes_p val) obj"
  apply (clarsimp simp: update_ti_t_def to_bytes_p_def)
  done

lemma h_val_field_from_bytes':
  "\<lbrakk> field_ti TYPE('a::{mem_type}) f = Some t;
     export_uinfo t = export_uinfo (typ_info_t TYPE('b::{mem_type})) \<rbrakk> \<Longrightarrow>
    h_val h (Ptr &(pa\<rightarrow>f) :: 'b ptr) = from_bytes (access_ti\<^sub>0 t (h_val h pa))"
  apply (insert h_val_field_from_bytes[where f=f and pa=pa and t=t and h="(h,x)"
                                         and 'a='a and 'b='b for x])
  apply (clarsimp simp: hrs_mem_def)
  done

lemma simple_lift_super_field_update_lookup:
  fixes dummy :: "'b :: mem_type"
  assumes "field_lookup (typ_info_t TYPE('b::mem_type)) f 0 = Some (s,n)"
    and "typ_uinfo_t TYPE('a) = export_uinfo s"
    and "simple_lift h p = Some v'"
  shows "(super_field_update_t (Ptr (&(p\<rightarrow>f))) (v::'a::mem_type) ((simple_lift h)::'b ptr \<Rightarrow> 'b option)) =
          ((simple_lift h)(p \<mapsto> field_update (field_desc s) (to_bytes_p v) v'))"
proof -
  from assms have [simp]: "unat (of_nat n :: addr) = n"
     apply (subst unat_of_nat)
     apply (subst mod_less)
      apply (drule td_set_field_lookupD)+
      apply (drule td_set_offset_size)+
      apply (subst len_of_addr_card)
      apply (subst (asm) size_of_def [symmetric, where t="TYPE('b)"])+
      apply (subgoal_tac "size_of TYPE('b) < addr_card")
       apply arith
      apply simp
     apply simp
     done
  from assms show ?thesis
    apply (clarsimp simp: super_field_update_t_def)
    apply (rule ext)
    apply (clarsimp simp: field_lvalue_def split: option.splits)
    apply (safe, simp_all)
       apply (frule_tac v=v and v'=v' in update_field_update)
       apply (clarsimp simp: field_of_t_def field_of_def typ_uinfo_t_def)
       apply (frule_tac m=0 in field_names_SomeD2)
        apply simp
       apply clarsimp
       apply (simp add: field_typ_def field_typ_untyped_def)
       apply (frule field_lookup_export_uinfo_Some)
       apply (frule_tac s=k in field_lookup_export_uinfo_Some)
       apply simp
       apply (drule (1) field_lookup_inject)
        apply (subst typ_uinfo_t_def [symmetric, where t="TYPE('b)"])
        apply simp
       apply simp
      apply (drule field_of_t_mem)+
      apply (case_tac h)
      apply (clarsimp simp: simple_lift_def split: if_split_asm)
      apply (drule (1) heap_ptr_valid_neq_disjoint)
       apply simp
      apply fast
     apply (clarsimp simp: field_of_t_def field_of_def)
     apply (subst (asm) td_set_field_lookup)
      apply simp
     apply simp
     apply (frule field_lookup_export_uinfo_Some)
     apply (simp add: typ_uinfo_t_def)
    apply (clarsimp simp: field_of_t_def field_of_def)
    apply (subst (asm) td_set_field_lookup)
     apply simp
    apply simp
    apply (frule field_lookup_export_uinfo_Some)
    apply (simp add: typ_uinfo_t_def)
    done
qed

lemma field_offset_addr_card:
  "\<exists>x. field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some x
    \<Longrightarrow> field_offset TYPE('a) f < addr_card"
  apply (clarsimp simp: field_offset_def field_offset_untyped_def typ_uinfo_t_def)
  apply (subst field_lookup_export_uinfo_Some)
   apply assumption
  apply (frule td_set_field_lookupD)
  apply (drule td_set_offset_size)
  apply (insert max_size [where ?'a="'a"])
  apply (clarsimp simp: size_of_def)
  done

lemma unat_of_nat_field_offset:
  "\<exists>x. field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some x \<Longrightarrow>
      unat (of_nat (field_offset TYPE('a) f)  :: addr) = field_offset TYPE('a) f"
  apply (subst word_unat.Abs_inverse)
   apply (clarsimp simp: unats_def)
   apply (insert field_offset_addr_card [where f=f and ?'a="'a"])[1]
   apply (fastforce simp: addr_card)
  apply simp
  done

lemma field_of_t_field_lookup:
  assumes a: "field_lookup (typ_info_t TYPE('a::mem_type)) f 0 = Some (s, n)"
  assumes b: "export_uinfo s = typ_uinfo_t TYPE('b::mem_type)"
  assumes n: "n = field_offset TYPE('a) f"
  shows "field_of_t (Ptr &(ptr\<rightarrow>f) :: ('b ptr)) (ptr :: 'a ptr)"
  apply (clarsimp simp del: field_lookup_offset_eq
      simp: field_of_t_def field_of_def)
  apply (subst td_set_field_lookup)
   apply (rule wf_desc_typ_tag)
  apply (rule exI [where x=f])
  using a[simplified n] b
  apply (clarsimp simp: typ_uinfo_t_def)
  apply (subst field_lookup_export_uinfo_Some)
   apply assumption
  apply (clarsimp simp del: field_lookup_offset_eq
      simp: field_lvalue_def unat_of_nat_field_offset)
  done

lemma simple_lift_field_update':
  fixes val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes   fl: "field_lookup (typ_info_t TYPE('a)) f 0 =
                     Some (adjust_ti (typ_info_t TYPE('b)) xf xfu, n)"
  and   xf_xfu: "fg_cons xf xfu"
  and       cl: "simple_lift hp ptr = Some z"
  shows "(simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) =
                simple_lift hp(ptr \<mapsto> xfu val z)"
    (is "?LHS = ?RHS")
proof (rule ext)
  fix p

  have eui: "typ_uinfo_t TYPE('b) =
       export_uinfo (adjust_ti (typ_info_t TYPE('b)) xf xfu)"
    using xf_xfu
    apply (subst export_tag_adjust_ti2 [OF _ wf_lf wf_desc])
    apply (simp add: fg_cons_def )
    apply (rule meta_eq_to_obj_eq [OF typ_uinfo_t_def])
    done

  have n_is_field_offset: "n = field_offset TYPE('a) f"
    apply (insert field_lookup_offset_eq [OF fl])
    apply (clarsimp)
    done

  have equal_case: "?LHS ptr = ?RHS ptr"
    apply (insert cl)
    apply (clarsimp simp: simple_lift_def split: if_split_asm)
    apply (clarsimp simp: hrs_mem_update)
    apply (subst h_val_super_update_bs)
     apply (rule field_of_t_field_lookup [OF fl])
      apply (clarsimp simp: eui)
     apply (clarsimp simp: n_is_field_offset)
    apply clarsimp
    apply (unfold from_bytes_def)
    apply (subst fi_fu_consistentD [where f=f and s="adjust_ti (typ_info_t TYPE('b)) xf xfu"])
        apply (clarsimp simp: fl)
        apply (clarsimp simp: n_is_field_offset field_lvalue_def)
        apply (metis unat_of_nat_field_offset fl)
       apply clarsimp
      apply (clarsimp simp: size_of_def)
     apply (clarsimp simp: size_of_def)
    apply clarsimp
    apply (subst update_ti_s_from_bytes)
     apply clarsimp
    apply (subst update_ti_adjust_ti)
     apply (rule xf_xfu)
    apply (subst update_ti_s_from_bytes)
     apply clarsimp
    apply clarsimp
    apply (clarsimp simp: h_val_def)
    done

  show "?LHS p = ?RHS p"
    apply (case_tac "p = ptr")
     apply (erule ssubst)
     apply (rule equal_case)
    apply (insert cl)
    apply (clarsimp simp: simple_lift_def hrs_mem_update split: if_split_asm)
    apply (rule h_val_heap_update_disjoint)
    apply (insert field_tag_sub [OF fl, where p=ptr])
    apply (clarsimp simp: size_of_def)
    apply (clarsimp simp: heap_ptr_valid_def)
    apply (frule (1) valid_simple_footprint_neq_disjoint, fastforce)
    apply clarsimp
    apply blast
    done
qed

lemma simple_lift_field_update:
  fixes val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes   fl: "field_ti TYPE('a) f =
                     Some (adjust_ti (typ_info_t TYPE('b)) xf (xfu o (\<lambda>x _. x)))"
  and   xf_xfu: "fg_cons xf (xfu o (\<lambda>x _. x))"
  and       cl: "simple_lift hp ptr = Some z"
  shows "(simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) =
                simple_lift hp(ptr \<mapsto> xfu (\<lambda>_. val) z)"
    (is "?LHS = ?RHS")
  apply (insert fl [unfolded field_ti_def])
  apply (clarsimp split: option.splits)
  apply (subst simple_lift_field_update' [where xf=xf and xfu="xfu o (\<lambda>x _. x)" and z=z])
     apply (clarsimp simp: o_def split: option.splits)
     apply (rule refl)
    apply (rule xf_xfu)
   apply (rule cl)
  apply clarsimp
  done

lemma simple_heap_diff_types_impl_diff_ptrs:
  "\<lbrakk> heap_ptr_valid h (p::('a::c_type) ptr);
     heap_ptr_valid h (q::('b::c_type) ptr);
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   ptr_val p \<noteq> ptr_val q"
  apply (clarsimp simp: heap_ptr_valid_def)
  apply (clarsimp simp: valid_simple_footprint_def)
  done

lemma h_val_update_regions_disjoint:
  "\<lbrakk> { ptr_val p ..+ size_of TYPE('a) } \<inter> { ptr_val x ..+ size_of TYPE('b)} = {} \<rbrakk> \<Longrightarrow>
        h_val (heap_update p (v::('a::mem_type)) h) x = h_val h (x::('b::c_type) ptr)"
  apply (clarsimp simp: heap_update_def)
  apply (clarsimp simp: h_val_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
  apply clarsimp
  done

lemma simple_lift_field_update_t:
  fixes    val :: "'b :: mem_type" and ptr :: "'a :: mem_type ptr"
  assumes  fl: "field_ti TYPE('a) f = Some t"
  and      diff: "typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('c :: c_type)"
  and      eu: "export_uinfo t = export_uinfo (typ_info_t TYPE('b))"
  and      cl: "simple_lift hp ptr = Some z"
  shows "((simple_lift (hrs_mem_update (heap_update (Ptr &(ptr\<rightarrow>f)) val) hp)) :: 'c ptr \<Rightarrow> 'c option) =
             simple_lift hp"
  apply (rule ext)
  apply (case_tac "simple_lift hp x")
   apply clarsimp
  apply (case_tac "ptr_val x = ptr_val ptr")
   apply clarsimp
   apply (clarsimp simp: simple_lift_def hrs_mem_update split: if_split_asm)
   apply (cut_tac simple_lift_heap_ptr_valid [OF cl])
   apply (drule (1) simple_heap_diff_types_impl_diff_ptrs [OF _ _ diff])
   apply simp
  apply (clarsimp simp: simple_lift_def hrs_mem_update split: if_split_asm)
  apply (rule field_ti_field_lookupE [OF fl])
  apply (frule_tac p=ptr in field_tag_sub)
  apply (clarsimp simp: h_val_def heap_update_def)
  apply (subst heap_list_update_disjoint_same)
   apply clarsimp
   apply (cut_tac simple_lift_heap_ptr_valid [OF cl])
   apply (drule (2) heap_ptr_valid_neq_disjoint)
   apply (clarsimp simp: export_size_of [unfolded typ_uinfo_t_def, OF eu])
   apply blast
  apply simp
  done

lemma simple_lift_heap_update_other':
  "\<lbrakk> simple_lift h (p::'b::mem_type ptr) = Some v';
     typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b) \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update p v) h) = ((simple_lift h)::'a::c_type typ_heap)"
  apply (rule simple_lift_heap_update_other)
   apply (erule simple_lift_heap_ptr_valid)
  apply simp
  done

(* If you update bytes inside an object of one type, it won't affect
 * heaps of other types. *)
lemma simple_lift_heap_update_bytes_in_other:
  "\<lbrakk> simple_lift h (p::'b::mem_type ptr) = Some v';
     typ_uinfo_t TYPE('b) \<noteq> typ_uinfo_t TYPE('c);
     { ptr_val q ..+ size_of TYPE('a)} \<subseteq> {ptr_val p  ..+ size_of TYPE('b) }  \<rbrakk> \<Longrightarrow>
   simple_lift (hrs_mem_update (heap_update (q::'a::mem_type ptr) v) h) = ((simple_lift h)::'c::mem_type typ_heap)"
  apply (rule ext)
  apply (clarsimp simp: simple_lift_def split: if_split_asm)
  apply (drule (1) heap_ptr_valid_type_neq_disjoint, simp)
  apply (clarsimp simp: hrs_mem_update)
  apply (rule h_val_heap_update_disjoint)
  apply blast
  done

lemma typ_name_neq:
    "typ_name (export_uinfo (typ_info_t TYPE('a::c_type)))
        \<noteq> typ_name (export_uinfo (typ_info_t TYPE('b::c_type)))
    \<Longrightarrow> typ_uinfo_t TYPE('a) \<noteq> typ_uinfo_t TYPE('b)"
  apply (metis typ_uinfo_t_def)
  done

lemma of_nat_mod_div_decomp:
  "of_nat k
        = of_nat (k div size_of TYPE('b)) * of_nat (size_of TYPE('b::mem_type)) +
              of_nat (k mod size_of TYPE('b))"
  by (metis mod_div_decomp of_nat_add of_nat_mult)

lemma c_guard_array_c_guard:
  "\<lbrakk> \<And>x. x < CARD('a) \<Longrightarrow> c_guard (ptr_coerce p +\<^sub>p int x :: 'b ptr) \<rbrakk> \<Longrightarrow> c_guard ( p :: ('b :: mem_type, 'a :: finite) array ptr)"
  apply atomize
  apply (clarsimp simp: c_guard_def)
  apply (rule conjI)
   apply (drule_tac x=0 in spec)
   apply (clarsimp simp: ptr_aligned_def align_of_def align_td_array)
  apply (simp add: c_null_guard_def)
  apply (clarsimp simp: intvl_def)
  apply (drule_tac x="k div size_of TYPE('b)" in spec)
  apply (erule impE)
   apply (metis (full_types) less_nat_zero_code mult_is_0 neq0_conv td_gal_lt)
  apply clarsimp
  apply (drule_tac x="k mod size_of TYPE('b)" in spec)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  apply (subst (asm) add.assoc)
  apply (subst (asm) of_nat_mod_div_decomp [symmetric])
  apply clarsimp
  done

lemma heap_list_update_list':
  "\<lbrakk> n + x \<le> length v; length v < addr_card; q = (p + of_nat x) \<rbrakk> \<Longrightarrow>
      heap_list (heap_update_list p v h) n q = take n (drop x v)"
  by (metis heap_list_update_list)

lemma outside_intvl_range:
    "p \<notin> {a ..+ b} \<Longrightarrow> p < a \<or> p \<ge> a + of_nat b"
  apply (clarsimp simp: intvl_def not_le not_less)
  apply (drule_tac x="unat (p-a)" in spec)
  apply clarsimp
  apply (metis add_diff_cancel2 le_less_linear le_unat_uoi
      mpl_lem not_add_less2 unat_mono word_less_minus_mono_left)
  done

lemma first_in_intvl:
  "b \<noteq> 0 \<Longrightarrow> a \<in> {a ..+ b}"
  by (force simp: intvl_def)

lemma zero_not_in_intvl_no_overflow:
  "0 \<notin> {a :: 'a::len word ..+ b} \<Longrightarrow> unat a + b \<le> 2 ^ len_of TYPE('a)"
  apply (rule ccontr)
  apply (simp add: intvl_def not_le)
  apply (drule_tac x="2 ^ len_of TYPE('a) - unat a" in spec)
  apply (clarsimp simp: not_less)
  apply (erule disjE)
  apply (metis (erased, hide_lams) diff_add_inverse less_imp_add_positive of_nat_2p of_nat_add
           unat_lt2p word_neq_0_conv word_unat.Rep_inverse)
  apply (metis le_add_diff_inverse le_antisym le_diff_conv le_refl
           less_imp_le_nat add.commute not_add_less1 unat_lt2p)
  done

lemma intvl_split:
  "\<lbrakk> n \<ge> a \<rbrakk> \<Longrightarrow> { p :: ('a :: len) word ..+ n } = { p ..+ a } \<union> { p + of_nat a ..+ (n - a)}"
  apply (rule set_eqI, rule iffI)
   apply (clarsimp simp: intvl_def not_less)
   apply (rule_tac x=k in exI)
   apply clarsimp
   apply (rule classical)
   apply (drule_tac x="k - a" in spec)
   apply (clarsimp simp: not_less)
   apply (metis diff_less_mono not_less)
  apply (clarsimp simp: intvl_def not_less)
  apply (rule_tac x="unat (x - p)" in exI)
  apply clarsimp
  apply (erule disjE)
   apply clarsimp
   apply (metis le_unat_uoi less_or_eq_imp_le not_less order_trans)
  apply clarsimp
  apply (metis le_def le_eq_less_or_eq le_unat_uoi less_diff_conv
    add.commute of_nat_add)
  done

lemma heap_ptr_valid_range_not_NULL:
  "heap_ptr_valid htd (p :: ('a :: c_type) ptr)
      \<Longrightarrow> 0 \<notin> {ptr_val p ..+ size_of TYPE('a)}"
  apply (clarsimp simp: heap_ptr_valid_def)
  apply (metis c_guard_def c_null_guard_def)
  done

lemma heap_ptr_valid_last_byte_no_overflow:
  "heap_ptr_valid htd (p :: ('a :: c_type) ptr)
      \<Longrightarrow> unat (ptr_val p) + size_of TYPE('a) \<le> 2 ^ len_of TYPE(addr_bitsize)"
  by (metis c_guard_def c_null_guard_def heap_ptr_valid_def
        zero_not_in_intvl_no_overflow)

lemma heap_ptr_valid_intersect_array:
  "\<lbrakk> \<forall>j < n. heap_ptr_valid htd (p +\<^sub>p int j);
        heap_ptr_valid htd (q :: ('a :: c_type) ptr) \<rbrakk>
         \<Longrightarrow> (\<exists>m < n. q = (p +\<^sub>p int m))
    \<or> ({ptr_val p ..+ size_of TYPE ('a) * n} \<inter> {ptr_val q ..+ size_of TYPE ('a :: c_type)} = {})"
  apply (induct n)
   apply clarsimp
  apply atomize
  apply simp
  apply (case_tac "n = 0")
   apply clarsimp
   apply (metis heap_ptr_valid_neq_disjoint ptr_val_inj)
  apply (erule disjE)
   apply (metis less_Suc_eq)
  apply (case_tac "q = p +\<^sub>p int n")
   apply force
  apply (frule_tac x=n in spec)
  apply (erule impE, simp)
  apply (drule (1) heap_ptr_valid_neq_disjoint)
  apply simp
  apply (simp add: CTypesDefs.ptr_add_def)
  apply (rule disjI2)
  apply (cut_tac a=" of_nat n * of_nat (size_of TYPE('a))"
      and p="ptr_val p" and n="n * size_of TYPE('a) + size_of TYPE('a)" in intvl_split)
   apply clarsimp
  apply (clarsimp simp: field_simps Int_Un_distrib2)
  apply (metis IntI emptyE intvl_empty intvl_inter intvl_self neq0_conv)
  done

(* Simplification rules for dealing with "lift_simple". *)

lemmas simple_lift_simps =
  typ_name_neq
  simple_lift_c_guard
  h_val_simple_lift
  simple_lift_heap_update'
  simple_lift_heap_update_other'
  c_guard_field
  h_val_field_simple_lift
  simple_lift_field_update
  simple_lift_field_update_t
  c_guard_array_field
  nat_to_bin_string_simps

(* Old name for the above simpset. *)
lemmas typ_simple_heap_simps = simple_lift_simps

end