theory SINVAR_NonInterference_impl
imports SINVAR_NonInterference "../TopoS_Interface_impl"
begin

code_identifier code_module SINVAR_NonInterference_impl => (Scala) SINVAR_NonInterference

subsubsection \<open>SecurityInvariant NonInterference List Implementation\<close>

definition undirected_reachable :: "'v list_graph \<Rightarrow> 'v => 'v list" where
  "undirected_reachable G v = removeAll v (succ_tran (undirected G) v)"

lemma undirected_reachable_set: "set (undirected_reachable G v) = {e2. (v,e2) \<in> (set (edgesL (undirected G)))\<^sup>+} - {v}"
  by(simp add: undirected_succ_tran_set undirected_nodes_set undirected_reachable_def)

fun sinvar_set :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar_set G nP = (\<forall> n \<in> set (nodesL G). (nP n) = Interfering \<longrightarrow> set (map nP (undirected_reachable G n)) \<subseteq> {Unrelated})"

(* equal: lemma sinvar_list_eq_set*)
fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> n \<in> set (nodesL G). (nP n) = Interfering \<longrightarrow> (let result = remdups (map nP (undirected_reachable G n)) in result = [] \<or> result = [Unrelated]))"

lemma "P = Q \<Longrightarrow> (\<forall> x. P x) = (\<forall> x. Q x)"
  by(erule arg_cong)

lemma sinvar_eq_help1: "nP ` set (undirected_reachable G n) = set (map nP (undirected_reachable G n))"
  by auto
lemma sinvar_eq_help2: "set l = {Unrelated} \<Longrightarrow> remdups l = [Unrelated]"
 apply(induction l)
  apply simp
 apply(simp)
  apply (metis empty_iff insertI1 set_empty2 subset_singletonD)
 done
lemma sinvar_eq_help3: "(let result = remdups (map nP (undirected_reachable G n)) in result = [] \<or> result = [Unrelated]) = (set (map nP (undirected_reachable G n)) \<subseteq> {Unrelated})"
  apply simp
  apply(rule iffI)
   apply(erule disjE)
    apply simp
   apply(simp only: set_map[symmetric])
   apply(subst set_remdups[symmetric])
   apply simp
  apply(case_tac " nP ` set (undirected_reachable G n) = {}")
   apply fast
  apply(case_tac " nP ` set (undirected_reachable G n) = {Unrelated}")
   defer
   apply(subgoal_tac "nP ` set (undirected_reachable G n) \<subseteq> {Unrelated} \<Longrightarrow>
    nP ` set (undirected_reachable G n) \<noteq> {} \<Longrightarrow>
    nP ` set (undirected_reachable G n) \<noteq> {Unrelated} \<Longrightarrow> False")
    apply fast
   apply (metis subset_singletonD)
  apply simp
  apply(rule disjI2)
  apply(simp only: sinvar_eq_help1)
  apply(simp add:sinvar_eq_help2)
  done

lemma sinvar_list_eq_set: "sinvar = sinvar_set"
  apply(insert sinvar_eq_help3)
  apply(simp add: fun_eq_iff)
  apply(rule allI)+
  apply fastforce
  done

value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. SINVAR_NonInterference.default_node_properties)"
value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4)] \<rparr>
    ((\<lambda>e. SINVAR_NonInterference.default_node_properties)(1:= Interfering, 2:= Unrelated, 3:= Unrelated, 4:= Unrelated))"
value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4,5, 8,9,10], edgesL = [(1,2), (2,3), (3,4), (5,4), (8,9),(9,8)] \<rparr>
    ((\<lambda>e. SINVAR_NonInterference.default_node_properties)(1:= Interfering, 2:= Unrelated, 3:= Unrelated, 4:= Unrelated))"
value "sinvar
    \<lparr> nodesL = [1::nat], edgesL = [(1,1)] \<rparr>
    ((\<lambda>e. SINVAR_NonInterference.default_node_properties)(1:= Interfering))"

value "(undirected_reachable \<lparr> nodesL = [1::nat], edgesL = [(1,1)] \<rparr> 1) = []"
  (* apply(simp add: removeAll_def remdups_def undirected_reachable_def succ_tran_def trancl_list_impl_def trancl_impl_def) *)

definition NonInterference_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) list list" where
  "NonInterference_offending_list = Generic_offending_list sinvar"

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_NonInterference.default_node_properties))"

definition "NonInterference_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_NonInterference.default_node_properties P))"

lemma sinvar_correct: "wf_list_graph G \<Longrightarrow> SINVAR_NonInterference.sinvar (list_graph_to_graph G) nP = sinvar G nP"
   apply(simp add: sinvar_list_eq_set)
   apply(rule all_nodes_list_I)
   by (simp add: SINVAR_NonInterference.undirected_reachable_def succ_tran_correct undirected_correct undirected_reachable_def)

interpretation NonInterference_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_NonInterference.default_node_properties
  and sinvar_spec=SINVAR_NonInterference.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_NonInterference.receiver_violation
  and offending_flows_impl=NonInterference_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=NonInterference_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(rule conjI)
   apply(simp add: TopoS_NonInterference; fail)
  apply(intro allI impI)
  apply(fact sinvar_correct)
 apply(rule conjI)
  apply(unfold NonInterference_offending_list_def)
  apply(intro allI impI)
  apply(rule Generic_offending_list_correct)
   apply(assumption)
  apply(simp only: sinvar_correct)
 apply(rule conjI)
  apply(intro allI)
  apply(simp only: NetModel_node_props_def)
  apply(metis NonInterference.node_props.simps NonInterference.node_props_eq_node_props_formaldef)
 apply(simp only: NonInterference_eval_def)
 apply(intro allI impI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_NonInterference])
 apply(simp only: sinvar_correct)
done

subsubsection \<open>NonInterference packing\<close>
  definition SINVAR_LIB_NonInterference :: "('v::vertex, node_config) TopoS_packed" where
    "SINVAR_LIB_NonInterference \<equiv>
    \<lparr> nm_name = ''NonInterference'',
      nm_receiver_violation = SINVAR_NonInterference.receiver_violation,
      nm_default = SINVAR_NonInterference.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = NonInterference_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = NonInterference_eval
      \<rparr>"
  interpretation SINVAR_LIB_NonInterference_interpretation: TopoS_modelLibrary SINVAR_LIB_NonInterference
      SINVAR_NonInterference.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_NonInterference_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text \<open>Example:\<close>
context begin
  private definition "example_graph = \<lparr> nodesL = [1::nat,2,3,4,5, 8,9,10], edgesL = [(1,2), (2,3), (3,4), (5,4), (8,9), (9,8)] \<rparr>"
  private definition"example_conf = ((\<lambda>e. SINVAR_NonInterference.default_node_properties)
      (1:= Interfering, 2:= Unrelated, 3:= Unrelated, 4:= Unrelated, 8:= Unrelated, 9:= Unrelated))"

  private lemma "\<not> sinvar example_graph example_conf" by eval
  private lemma "NonInterference_offending_list example_graph example_conf =
                     [[(1, 2)], [(2, 3)], [(3, 4)], [(5, 4)]]" by eval
end

hide_const (open) NetModel_node_props
hide_const (open) sinvar

end


section \<open>Graph Type Class Instantiations\<close>

theory
  IRGraphSort
imports
  Graph.IRGraph
begin

text \<open>
An @{typ IRGraph} can be treated as an instantiation of
various type classes such as the equal type class.

Here we define the instantiations for all type classes
of which @{typ IRGraph} belongs.
\<close>

subsection \<open>Equal Instance\<close>
text \<open>
The following is an incorrect definition of equality
which is used to allow code generation of the Canonicalization
phase. Without this we have to use the values command to generate
all possible results of the canonicalization phase.

Note that we should be able to find a correct equality definition
in terms of the ids, kind, and stamp function. However, we are
yet to find a satisfactory definition as yet.
\<close>
(* Code generation issues
definition IRGraph_equal :: "IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool" where
  "IRGraph_equal g1 g2 = (as_list g1 = as_list g2)"
*)
definition IRGraph_equal :: "IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool" where
  "IRGraph_equal g1 g2 = True"

(*lemma graph_eq:
  fixes g1 g2 :: IRGraph
  shows "g1 = g2 \<longleftrightarrow> IRGraph_equal g1 g2"
  sorry*)

instantiation IRGraph :: equal
begin

definition equal_IRGraph :: "IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool" where
  "equal_IRGraph = IRGraph_equal"

instance proof
  fix g1 g2 :: IRGraph
  show "equal_class.equal g1 g2 \<longleftrightarrow> (g1 = g2)"
    apply standard
    unfolding equal_IRGraph_def IRGraph_equal_def
    unfolding as_list_def
    apply transfer
    sorry
qed
end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_SKIP
imports CSP_T_law_basic
begin

(*****************************************************************

         1. SKIP |[X]| SKIP
         2. SKIP |[X]| P
         3. P |[X]| SKIP
         4. SKIP -- X
         5. SKIP [[r]]
         6. SKIP ;; P
         7. P ;; SKIP
         8. SKIP |. n

 *****************************************************************)

(*********************************************************
                    SKIP |[X]| SKIP
 *********************************************************)

lemma cspT_Parallel_term:
   "SKIP |[X]| SKIP =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)
done

(*********************************************************
                      SKIP |[X]| P
 *********************************************************)

lemma cspT_Parallel_preterm_l:
   "SKIP |[X]| (? :Y -> Qf) =T[M,M] ? x:(Y-X) -> (SKIP |[X]| Qf x)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (insert trace_nil_or_Tick_or_Ev)
 apply (elim disjE conjE exE)
  apply (simp_all)

  apply (drule_tac x="t" in spec)
  apply (erule disjE, simp)
  apply (erule disjE, simp)
  apply (elim conjE exE, simp)
  apply (simp add: par_tr_head)
  apply (rule_tac x="<>" in exI)
  apply (rule_tac x="sa" in exI, simp)

  apply (drule_tac x="t" in spec)
  apply (erule disjE, simp)
  apply (erule disjE, simp)
  apply (elim conjE exE, simp)
  apply (simp add: par_tr_head)
  apply (rule_tac x="<Tick>" in exI)
  apply (rule_tac x="sa" in exI, simp)

(* <= *)

 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
  apply (simp_all)

  apply (rule_tac x="<>" in exI)
  apply (rule_tac x="<Ev a> ^^^ ta" in exI, simp)
  apply (simp add: par_tr_head)

  apply (rule_tac x="<Tick>" in exI)
  apply (rule_tac x="<Ev a> ^^^ ta" in exI, simp)
  apply (simp add: par_tr_head)
done

(*********************************************************
                      P |[X]| SKIP
 *********************************************************)

lemma cspT_Parallel_preterm_r:
   "(? :Y -> Pf) |[X]| SKIP
     =T[M,M] ? x:(Y-X) -> (Pf x |[X]| SKIP)"
apply (rule cspT_trans)
apply (rule cspT_Parallel_commut)
apply (rule cspT_trans)
apply (rule cspT_Parallel_preterm_l)
apply (rule cspT_rm_head, simp)
apply (rule cspT_Parallel_commut)
done

lemmas cspT_Parallel_preterm = cspT_Parallel_preterm_l cspT_Parallel_preterm_r

(*********************************************************
                      SKIP and Parallel
 *********************************************************)

(* p.288 *)

lemma cspT_SKIP_Parallel_Ext_choice_SKIP_l:
  "((? :Y -> Pf) [+] SKIP) |[X]| SKIP =T[M,M]
   (? x:(Y - X) -> (Pf x |[X]| SKIP)) [+] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (rule disjI2)
  apply (rule disjI1)
  apply (simp add: par_tr_nil_right)
  apply (elim conjE)
  apply (simp add: image_iff)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<>" in exI)
  apply (simp add: par_tr_nil_right)

  apply (rule disjI2)
  apply (rule disjI1)
  apply (simp add: par_tr_Tick_right)
  apply (elim conjE)
  apply (simp add: image_iff)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<Tick>" in exI)
  apply (simp add: par_tr_Tick_right)

(* <= *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (simp add: par_tr_nil_right)
  apply (elim conjE)
  apply (rule_tac x="<Ev a> ^^^ sa" in exI)
  apply (rule_tac x="<>" in exI)
  apply (simp add: par_tr_nil_right)
  apply (simp add: image_iff)

  apply (simp add: par_tr_Tick_right)
  apply (elim conjE)
  apply (rule_tac x="<Ev a> ^^^ sa" in exI)
  apply (rule_tac x="<Tick>" in exI)
  apply (simp add: par_tr_Tick_right)
  apply (simp add: image_iff)
done

lemma cspT_SKIP_Parallel_Ext_choice_SKIP_r:
  "SKIP |[X]| ((? :Y -> Pf) [+] SKIP)  =T[M,M]
   (? x:(Y - X) -> (SKIP |[X]| Pf x)) [+] SKIP"
apply (rule cspT_rw_left)
apply (rule cspT_commut)
apply (rule cspT_rw_left)
apply (rule cspT_SKIP_Parallel_Ext_choice_SKIP_l)
apply (rule cspT_rw_left)
apply (rule cspT_decompo)
apply (rule cspT_decompo)
apply (simp)
apply (rule cspT_commut)
apply (rule cspT_reflex)
apply (rule cspT_reflex)
done

lemmas cspT_SKIP_Parallel_Ext_choice_SKIP =
       cspT_SKIP_Parallel_Ext_choice_SKIP_l
       cspT_SKIP_Parallel_Ext_choice_SKIP_r

(*********************************************************
                      SKIP -- X
 *********************************************************)

lemma cspT_SKIP_Hiding_Id:
   "SKIP -- X =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)
 apply (rule_tac x="<>" in exI)
 apply (simp)
 apply (rule_tac x="<Tick>" in exI)
 apply (simp)
done

(*********************************************************
                      SKIP and Hiding
 *********************************************************)

(*           p.288 version

  "((? :Y -> Pf) [+] SKIP) -- X =T[M1,M2]
       IF (Y Int X = {}) THEN ((? x:Y -> (Pf x -- X)) [+] SKIP)
                         ELSE (((? x:(Y-X) -> (Pf x -- X)) [+] SKIP)
                               |~| (! x:(Y Int X) .. (Pf x -- X)))"
*)

lemma cspT_SKIP_Hiding_step:
  "((? :Y -> Pf) [+] SKIP) -- X =T[M,M]
   ((? x:(Y-X) -> (Pf x -- X)) [+] SKIP) |~| (! x:(Y Int X) .. (Pf x -- X))"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (case_tac "a : X", force)
  apply (force)

(* <= *)
 apply (rule)

  apply (simp add: in_traces)
  apply (elim conjE exE bexE disjE)
  apply (simp_all)

   apply (force)

   apply (rule_tac x="<Ev a> ^^^ sa" in exI)
   apply (simp)

   apply (force)

   apply (rule_tac x="<Tick>" in exI)
   apply (simp)

   apply (force)

   apply (rule_tac x="<Ev a> ^^^ s" in exI)
   apply (simp)
done

(*********************************************************
                      SKIP [[r]]
 *********************************************************)

lemma cspT_SKIP_Renaming_Id:
   "SKIP [[r]] =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (force)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (force)
done

(*********************************************************
                       SKIP ;; P
 *********************************************************)

lemma cspT_Seq_compo_unit_l: "SKIP ;; P =T[M,M] P"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (force)

(* <= *)
 apply (rule, simp add: in_traces)
 apply (rule disjI2)
 apply (rule_tac x="<>" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)
done

(*********************************************************
                       P ;; SKIP
 *********************************************************)

lemma cspT_Seq_compo_unit_r: "P ;; SKIP =T[M,M] P"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)
 apply (rule memT_prefix_closed, simp)
 apply (simp add: rmTick_prefix_rev)
 apply (rule memT_prefix_closed, simp, simp)

(* <= *)
 apply (rule, simp add: in_traces)
 apply (insert trace_last_noTick_or_Tick)
 apply (drule_tac x="t" in spec)
 apply (erule disjE)
  apply (rule disjI1)
  apply (rule_tac x="t" in exI, simp)
  (* *)
  apply (rule disjI2)
  apply (elim conjE exE)
  apply (rule_tac x="s" in exI)
  apply (rule_tac x="<Tick>" in exI)
  apply (simp)
done

lemmas cspT_Seq_compo_unit = cspT_Seq_compo_unit_l cspT_Seq_compo_unit_r

(*********************************************************
               SKIP and Sequential composition
 *********************************************************)

(* p.141 *)

lemma cspT_SKIP_Seq_compo_step:
  "((? :X -> Pf) [> SKIP) ;; Q =T[M,M] (? x:X -> (Pf x ;; Q)) [> Q"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)

 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (rule disjI1)
  apply (fast)

  apply (rule disjI2)
  apply (rule disjI1)
  apply (insert trace_nil_or_Tick_or_Ev)
  apply (drule_tac x="s" in spec)

  apply (elim disjE conjE exE)
  apply (simp_all)

  apply (simp add: appt_assoc)
  apply (rule disjI2)

  apply (rule_tac x="sb" in exI)
  apply (rule_tac x="ta" in exI)
  apply (simp)

(* <= *)
 apply (rule, simp add: in_traces)

 apply (elim conjE exE disjE)
 apply (simp_all)

 apply (rule disjI1)
 apply (rule_tac x="<>" in exI)
 apply (simp)

 apply (rule disjI1)
 apply (rule_tac x="<Ev a> ^^^ sa" in exI)
 apply (simp)

 apply (rule disjI2)
 apply (rule_tac x="<Ev a> ^^^ sa" in exI)
 apply (rule_tac x="ta" in exI)
 apply (simp add: appt_assoc)

 apply (rule disjI1)
 apply (rule_tac x="<>" in exI)
 apply (simp)

 apply (rule disjI2)
 apply (rule_tac x="<>" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)
done

(*********************************************************
                      SKIP |. n
 *********************************************************)

lemma cspT_SKIP_Depth_rest:
   "SKIP |. (Suc n) =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (force)
done

(*********************************************************
                      cspT_SKIP
 *********************************************************)

lemmas cspT_SKIP =
       cspT_Parallel_term
       cspT_Parallel_preterm
       cspT_SKIP_Parallel_Ext_choice_SKIP
       cspT_SKIP_Hiding_Id
       cspT_SKIP_Hiding_step
       cspT_SKIP_Renaming_Id
       cspT_Seq_compo_unit
       cspT_SKIP_Seq_compo_step
       cspT_SKIP_Depth_rest

(*********************************************************
                       P [+] SKIP
 *********************************************************)

(* p.141 *)

lemma cspT_Ext_choice_SKIP_resolve: "P [+] SKIP =T[M,M] P [> SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)

(* <= *)
 apply (rule, simp add: in_traces)
done

lemma cspT_Ext_choice_SKIP_resolve_sym: "P [> SKIP =T[M,M] P [+] SKIP"
apply (rule cspT_sym)
apply (simp add: cspT_Ext_choice_SKIP_resolve)
done

(*********************************************************
                    SKIP ||| P
 *********************************************************)

lemma cspT_Interleave_unit_l:
  "SKIP ||| P =T[M,M] P"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
 apply (simp add: par_tr_nil_left)
 apply (simp add: par_tr_Tick_left)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (case_tac "noTick t")

  apply (rule_tac x="<>" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)
  apply (simp add: par_tr_nil_left)
  apply (simp add: noTick_def)

  apply (rule_tac x="<Tick>" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)
  apply (simp add: par_tr_Tick_left)
  apply (simp add: noTick_def)

done

(*********************************************************
                    P ||| SKIP
 *********************************************************)

lemma cspT_Interleave_unit_r:
  "P ||| SKIP =T[M,M] P"
apply (rule cspT_rw_left)
apply (rule cspT_commut)
apply (simp add: cspT_Interleave_unit_l)
done

lemmas cspT_Interleave_unit =
       cspT_Interleave_unit_l
       cspT_Interleave_unit_r

end


(*  Title:      JinjaThreads/Common/TypeRel.thy
    Author:     Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/Type.thy by Tobias Nipkow
*)

section \<open>Relations between Jinja Types\<close>

theory TypeRel
imports
  Decl
begin

subsection\<open>The subclass relations\<close>

inductive subcls1 :: "'m prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sup>1 _" [71, 71, 71] 70)
  for P :: "'m prog"
where subcls1I: "\<lbrakk> class P C = Some (D, rest); C \<noteq> Object \<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"

abbreviation subcls :: "'m prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool" ("_ \<turnstile> _ \<preceq>\<^sup>* _"  [71,71,71] 70)
where "P \<turnstile> C \<preceq>\<^sup>* D \<equiv> (subcls1 P)\<^sup>*\<^sup>* C D"

lemma subcls1D:
  "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class P C = Some (D,fs,ms))"
by(auto elim: subcls1.cases)

lemma Object_subcls1 [iff]: "\<not> P \<turnstile> Object \<prec>\<^sup>1 C"
by(simp add: subcls1.simps)

lemma Object_subcls_conv [iff]: "(P \<turnstile> Object \<preceq>\<^sup>* C) = (C = Object)"
by(auto elim: converse_rtranclpE)

lemma finite_subcls1: "finite {(C, D). P \<turnstile> C \<prec>\<^sup>1 D}"
proof -
  let ?A = "SIGMA C:{C. is_class P C}. {D. C\<noteq>Object \<and> fst (the (class P C))=D}"
  have "finite ?A" by(rule finite_SigmaI [OF finite_is_class]) auto
  also have "?A = {(C, D). P \<turnstile> C \<prec>\<^sup>1 D}"
    by(fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
  finally show ?thesis .
qed

lemma finite_subcls1':
  "finite ({(D, C). P \<turnstile> C \<prec>\<^sup>1 D})"
by(subst finite_converse[symmetric])
  (simp add: converse_unfold finite_subcls1 del: finite_converse)

lemma subcls_is_class: "(subcls1 P)\<^sup>+\<^sup>+ C D \<Longrightarrow> is_class P C"
by(auto elim: converse_tranclpE dest!: subcls1D simp add: is_class_def)

lemma subcls_is_class1: "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* D; is_class P D \<rbrakk> \<Longrightarrow> is_class P C"
by(auto elim: converse_rtranclpE dest!: subcls1D simp add: is_class_def)

subsection\<open>The subtype relations\<close>

inductive widen :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ \<le> _"   [71,71,71] 70)
  for P :: "'m prog"
where
  widen_refl[iff]: "P \<turnstile> T \<le> T"
| widen_subcls: "P \<turnstile> C \<preceq>\<^sup>* D  \<Longrightarrow>  P \<turnstile> Class C \<le> Class D"
| widen_null[iff]: "P \<turnstile> NT \<le> Class C"
| widen_null_array[iff]: "P \<turnstile> NT \<le> Array A"
| widen_array_object: "P \<turnstile> Array A \<le> Class Object"
| widen_array_array: "P \<turnstile> A \<le> B \<Longrightarrow> P \<turnstile> Array A \<le> Array B"

abbreviation
  widens :: "'m prog \<Rightarrow> ty list \<Rightarrow> ty list \<Rightarrow> bool" ("_ \<turnstile> _ [\<le>] _" [71,71,71] 70)
where
  "P \<turnstile> Ts [\<le>] Ts' == list_all2 (widen P) Ts Ts'"

lemma [iff]: "(P \<turnstile> T \<le> Boolean) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Integer) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Void \<le> T) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Boolean \<le> T) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Integer \<le> T) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma Class_widen: "P \<turnstile> Class C \<le> T  \<Longrightarrow>  \<exists>D. T = Class D"
by(erule widen.cases, auto)

lemma Array_Array_widen:
  "P \<turnstile> Array T \<le> Array U \<Longrightarrow> P \<turnstile> T \<le> U"
by(auto elim: widen.cases)

lemma widen_Array: "(P \<turnstile> T \<le> U\<lfloor>\<rceil>) \<longleftrightarrow> (T = NT \<or> (\<exists>V. T = V\<lfloor>\<rceil> \<and> P \<turnstile> V \<le> U))"
by(induct T)(auto dest: Array_Array_widen elim: widen.cases intro: widen_array_array)

lemma Array_widen: "P \<turnstile> Array A \<le> T \<Longrightarrow> (\<exists>B. T = Array B \<and> P \<turnstile> A \<le> B) \<or> T = Class Object"
by(auto elim: widen.cases)

lemma [iff]: "(P \<turnstile> T \<le> NT) = (T = NT)"
by(induct T)(auto dest:Class_widen Array_widen)

lemma Class_widen_Class [iff]: "(P \<turnstile> Class C \<le> Class D) = (P \<turnstile> C \<preceq>\<^sup>* D)"
by (auto elim: widen_subcls widen.cases)

lemma widen_Class: "(P \<turnstile> T \<le> Class C) = (T = NT \<or> (\<exists>D. T = Class D \<and> P \<turnstile> D \<preceq>\<^sup>* C) \<or> (C = Object \<and> (\<exists>A. T = Array A)))"
by(induct T)(auto dest: Array_widen intro: widen_array_object)

lemma NT_widen:
  "P \<turnstile> NT \<le> T = (T = NT \<or> (\<exists>C. T = Class C) \<or> (\<exists>U. T = U\<lfloor>\<rceil>))"
by(cases T) auto

lemma Class_widen2: "P \<turnstile> Class C \<le> T = (\<exists>D. T = Class D \<and> P \<turnstile> C \<preceq>\<^sup>* D)"
by (cases T, auto elim: widen.cases)

lemma Object_widen: "P \<turnstile> Class Object \<le> T \<Longrightarrow> T = Class Object"
by(cases T, auto elim: widen.cases)

lemma NT_Array_widen_Object:
  "is_NT_Array T \<Longrightarrow>  P \<turnstile> T \<le> Class Object"
by(induct T, auto intro: widen_array_object)

lemma widen_trans[trans]:
  assumes "P \<turnstile> S \<le> U" "P \<turnstile> U \<le> T"
  shows "P \<turnstile> S \<le> T"
using assms
proof(induct arbitrary: T)
  case (widen_refl T T') thus "P \<turnstile> T \<le> T'" .
next
  case (widen_subcls C D T)
  then obtain E where "T = Class E" by (blast dest: Class_widen)
  with widen_subcls show "P \<turnstile> Class C \<le> T" by (auto elim: rtrancl_trans)
next
  case (widen_null C RT)
  then obtain D where "RT = Class D" by (blast dest: Class_widen)
  thus "P \<turnstile> NT \<le> RT" by auto
next
  case widen_null_array thus ?case by(auto dest: Array_widen)
next
  case (widen_array_object A T)
  hence "T = Class Object" by(rule Object_widen)
  with widen_array_object show "P \<turnstile> A\<lfloor>\<rceil> \<le> T"
    by(auto intro: widen.widen_array_object)
next
  case widen_array_array thus ?case
    by(auto dest!: Array_widen intro: widen.widen_array_array widen_array_object)
qed

lemma widens_trans: "\<lbrakk>P \<turnstile> Ss [\<le>] Ts; P \<turnstile> Ts [\<le>] Us\<rbrakk> \<Longrightarrow> P \<turnstile> Ss [\<le>] Us"
by (rule list_all2_trans)(rule widen_trans)

lemma class_type_of'_widenD:
  "class_type_of' T = \<lfloor>C\<rfloor> \<Longrightarrow> P \<turnstile> T \<le> Class C"
by(cases T)(auto intro: widen_array_object)

lemma widen_is_class_type_of:
  assumes "class_type_of' T = \<lfloor>C\<rfloor>" "P \<turnstile> T' \<le> T" "T' \<noteq> NT"
  obtains C' where "class_type_of' T' = \<lfloor>C'\<rfloor>" "P \<turnstile> C' \<preceq>\<^sup>* C"
using assms by(cases T)(auto simp add: widen_Class widen_Array)

lemma widens_refl: "P \<turnstile> Ts [\<le>] Ts"
by(rule list_all2_refl[OF widen_refl])

lemma widen_append1:
  "P \<turnstile> (xs @ ys) [\<le>] Ts = (\<exists>Ts1 Ts2. Ts = Ts1 @ Ts2 \<and> length xs = length Ts1 \<and> length ys = length Ts2 \<and> P \<turnstile> xs [\<le>] Ts1 \<and> P \<turnstile> ys [\<le>] Ts2)"
unfolding list_all2_append1 by fastforce

lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P

lemma widens_lengthD:
  "P \<turnstile> xs [\<le>] ys \<Longrightarrow> length xs = length ys"
by(rule list_all2_lengthD)

lemma widen_refT: "\<lbrakk> is_refT T; P \<turnstile> U \<le> T \<rbrakk> \<Longrightarrow> is_refT U"
by(erule refTE)(auto simp add: widen_Class widen_Array)

lemma refT_widen: "\<lbrakk> is_refT T; P \<turnstile> T \<le> U \<rbrakk> \<Longrightarrow> is_refT U"
by(erule widen.cases) auto

inductive is_lub :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> lub'((_,/ _)') = _" [51,51,51,51] 50)
for P :: "'m prog" and U :: ty and V :: ty and T ::  ty
where
  "\<lbrakk> P \<turnstile> U \<le> T; P \<turnstile> V \<le> T;
     \<And>T'. \<lbrakk> P \<turnstile> U \<le> T'; P \<turnstile> V \<le> T' \<rbrakk> \<Longrightarrow> P \<turnstile> T \<le> T' \<rbrakk>
  \<Longrightarrow> P \<turnstile> lub(U, V) = T"

lemma is_lub_upper:
  "P \<turnstile> lub(U, V) = T \<Longrightarrow> P \<turnstile> U \<le> T \<and> P \<turnstile> V \<le> T"
by(auto elim: is_lub.cases)

lemma is_lub_least:
  "\<lbrakk> P \<turnstile> lub(U, V) = T; P \<turnstile> U \<le> T'; P \<turnstile> V \<le> T' \<rbrakk> \<Longrightarrow> P \<turnstile> T \<le> T'"
by(auto elim: is_lub.cases)

lemma is_lub_Void [iff]:
  "P \<turnstile> lub(Void, Void) = T \<longleftrightarrow> T = Void"
by(auto intro: is_lub.intros elim: is_lub.cases)

lemma is_lubI [code_pred_intro]:
  "\<lbrakk>P \<turnstile> U \<le> T; P \<turnstile> V \<le> T; \<forall>T'. P \<turnstile> U \<le> T' \<longrightarrow> P \<turnstile> V \<le> T' \<longrightarrow> P \<turnstile> T \<le> T'\<rbrakk> \<Longrightarrow> P \<turnstile> lub(U, V) = T"
by(blast intro: is_lub.intros)

subsection\<open>Method lookup\<close>

inductive Methods :: "'m prog \<Rightarrow> cname \<Rightarrow> (mname \<rightharpoonup> (ty list \<times> ty \<times> 'm option) \<times> cname) \<Rightarrow> bool"
  ("_ \<turnstile> _ sees'_methods _" [51,51,51] 50)
  for P :: "'m prog"
where
sees_methods_Object:
 "\<lbrakk> class P Object = Some(D,fs,ms); Mm = map_option (\<lambda>m. (m,Object)) \<circ> map_of ms \<rbrakk>
  \<Longrightarrow> P \<turnstile> Object sees_methods Mm"
| sees_methods_rec:
 "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D sees_methods Mm;
    Mm' = Mm ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms) \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees_methods Mm'"

lemma sees_methods_fun:
  assumes "P \<turnstile> C sees_methods Mm"
  shows "P \<turnstile> C sees_methods Mm' \<Longrightarrow> Mm' = Mm"
using assms
proof(induction arbitrary: Mm')
  case sees_methods_Object thus ?case by(auto elim: Methods.cases)
next
  case (sees_methods_rec C D fs ms Dres Cres Cres')
  from \<open>P \<turnstile> C sees_methods Cres'\<close> \<open>C \<noteq> Object\<close> \<open>class P C = \<lfloor>(D, fs, ms)\<rfloor>\<close>
  obtain Dres' where Dmethods': "P \<turnstile> D sees_methods Dres'"
    and Cres': "Cres' = Dres' ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
    by cases auto
  from sees_methods_rec.IH[OF Dmethods'] \<open>Cres = Dres ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)\<close> Cres'
  show ?case by simp
qed

lemma visible_methods_exist:
  "P \<turnstile> C sees_methods Mm \<Longrightarrow> Mm M = Some(m,D) \<Longrightarrow>
   (\<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some m)"
by(induct rule:Methods.induct) auto

lemma sees_methods_decl_above:
  assumes "P \<turnstile> C sees_methods Mm"
  shows "Mm M = Some(m,D) \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
using assms
by induct(auto elim: converse_rtranclp_into_rtranclp[where r = "subcls1 P", OF subcls1I])

lemma sees_methods_idemp:
  assumes "P \<turnstile> C sees_methods Mm" and "Mm M = Some(m,D)"
  shows "\<exists>Mm'. (P \<turnstile> D sees_methods Mm') \<and> Mm' M = Some(m,D)"
using assms
by(induct arbitrary: m D)(fastforce dest: Methods.intros)+

lemma sees_methods_decl_mono:
  assumes sub: "P \<turnstile> C' \<preceq>\<^sup>* C" and "P \<turnstile> C sees_methods Mm"
  shows "\<exists>Mm' Mm\<^sub>2. P \<turnstile> C' sees_methods Mm' \<and> Mm' = Mm ++ Mm\<^sub>2 \<and> (\<forall>M m D. Mm\<^sub>2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
      (is "\<exists>Mm' Mm2. ?Q C' C Mm' Mm2")
using assms
proof (induction rule: converse_rtranclp_induct)
  case base
  hence "?Q C C Mm Map.empty" by simp
  thus "\<exists>Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
  case (step C'' C')
  note sub1 = \<open>P \<turnstile> C'' \<prec>\<^sup>1 C'\<close> and sub = \<open>P \<turnstile> C' \<preceq>\<^sup>* C\<close>
    and Csees = \<open>P \<turnstile> C sees_methods Mm\<close>
  from step.IH[OF Csees] obtain Mm' Mm2 where C'sees: "P \<turnstile> C' sees_methods Mm'"
    and Mm': "Mm' = Mm ++ Mm2"
    and subC: "\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C" by blast
  obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C'' \<noteq> Object"
    using subcls1D[OF sub1] by blast
  let ?Mm3 = "map_option (\<lambda>m. (m,C'')) \<circ> map_of ms"
  have "P \<turnstile> C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
    using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
  hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
    using converse_rtranclp_into_rtranclp[OF sub1 sub]
    by simp (simp add:map_add_def subC split:option.split)
  thus "\<exists>Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed

definition Method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm option \<Rightarrow> cname \<Rightarrow> bool"
            ("_ \<turnstile> _ sees _: _\<rightarrow>_ = _ in _" [51,51,51,51,51,51,51] 50)
where
  "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D  \<equiv>
  \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> Mm M = Some((Ts,T,m),D)"

text \<open>
  Output translation to replace @{term "None"} with its notation \<open>Native\<close>
  when used as method body in @{term "Method"}.
\<close>
abbreviation (output)
  Method_native :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
  ("_ \<turnstile> _ sees _: _\<rightarrow>_ = Native in _" [51,51,51,51,51,51] 50)
where "Method_native P C M Ts T D \<equiv> Method P C M Ts T Native D"

definition has_method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> bool" ("_ \<turnstile> _ has _" [51,0,51] 50)
where
  "P \<turnstile> C has M \<equiv> \<exists>Ts T m D. P \<turnstile> C sees M:Ts\<rightarrow>T = m in D"

lemma has_methodI:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C has M"
  by (unfold has_method_def) blast

lemma sees_method_fun:
  "\<lbrakk>P \<turnstile> C sees M:TS\<rightarrow>T = m in D; P \<turnstile> C sees M:TS'\<rightarrow>T' = m' in D' \<rbrakk>
   \<Longrightarrow> TS' = TS \<and> T' = T \<and> m' = m \<and> D' = D"
 (*<*)by(fastforce dest: sees_methods_fun simp:Method_def)(*>*)

lemma sees_method_decl_above:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)by(clarsimp simp:Method_def sees_methods_decl_above)(*>*)

lemma visible_method_exists:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow>
  \<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some(Ts,T,m)"
(*<*)by(fastforce simp:Method_def dest!: visible_methods_exist)(*>*)

lemma sees_method_idemp:
  "P \<turnstile> C sees M:Ts\<rightarrow>T=m in D \<Longrightarrow> P \<turnstile> D sees M:Ts\<rightarrow>T=m in D"
 (*<*)by(fastforce simp: Method_def intro:sees_methods_idemp)(*>*)

lemma sees_method_decl_mono:
  "\<lbrakk> P \<turnstile> C' \<preceq>\<^sup>* C; P \<turnstile> C sees M:Ts\<rightarrow>T = m in D;
     P \<turnstile> C' sees M:Ts'\<rightarrow>T' = m' in D' \<rbrakk> \<Longrightarrow> P \<turnstile> D' \<preceq>\<^sup>* D"
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtranclp_trans)
done

lemma sees_method_is_class:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> is_class P C"
by (auto simp add: is_class_def Method_def elim: Methods.cases)

subsection\<open>Field lookup\<close>

inductive Fields :: "'m prog \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> (ty \<times> fmod)) list \<Rightarrow> bool"
  ("_ \<turnstile> _ has'_fields _" [51,51,51] 50)
  for P :: "'m prog"
where
  has_fields_rec:
  "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D has_fields FDTs;
     FDTs' = map (\<lambda>(F,Tm). ((F,C),Tm)) fs @ FDTs \<rbrakk>
   \<Longrightarrow> P \<turnstile> C has_fields FDTs'"

| has_fields_Object:
  "\<lbrakk> class P Object = Some(D,fs,ms); FDTs = map (\<lambda>(F,T). ((F,Object),T)) fs \<rbrakk>
   \<Longrightarrow> P \<turnstile> Object has_fields FDTs"

lemma has_fields_fun:
  assumes "P \<turnstile> C has_fields FDTs" and "P \<turnstile> C has_fields FDTs'"
  shows "FDTs' = FDTs"
using assms
proof(induction arbitrary: FDTs')
  case has_fields_Object thus ?case by(auto elim: Fields.cases)
next
  case (has_fields_rec C D fs ms Dres Cres Cres')
  from \<open>P \<turnstile> C has_fields Cres'\<close> \<open>C \<noteq> Object\<close> \<open>class P C = Some (D, fs, ms)\<close>
  obtain Dres' where DFields': "P \<turnstile> D has_fields Dres'"
    and Cres': "Cres' = map (\<lambda>(F,Tm). ((F,C),Tm)) fs @ Dres'"
    by cases auto
  from has_fields_rec.IH[OF DFields'] \<open>Cres = map (\<lambda>(F,Tm). ((F,C),Tm)) fs @ Dres\<close> Cres'
  show ?case by simp
qed

lemma all_fields_in_has_fields:
  assumes "P \<turnstile> C has_fields FDTs"
  and "P \<turnstile> C \<preceq>\<^sup>* D" "class P D = Some(D',fs,ms)" "(F,Tm) \<in> set fs"
  shows "((F,D),Tm) \<in> set FDTs"
using assms
by induct (auto 4 3 elim: converse_rtranclpE dest: subcls1D)

lemma has_fields_decl_above:
  assumes "P \<turnstile> C has_fields FDTs" "((F,D),Tm) \<in> set FDTs"
  shows "P \<turnstile> C \<preceq>\<^sup>* D"
using assms
by induct (auto intro: converse_rtranclp_into_rtranclp subcls1I)

lemma subcls_notin_has_fields:
  assumes "P \<turnstile> C has_fields FDTs" "((F,D),Tm) \<in> set FDTs"
  shows "\<not> (subcls1 P)\<^sup>+\<^sup>+ D C"
using assms apply(induct)
 prefer 2 apply(fastforce dest: tranclpD)
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
 apply(drule tranclpD)
 apply clarify
 apply(frule subcls1D)
 apply(fastforce dest:tranclpD all_fields_in_has_fields)
apply(blast dest:subcls1I tranclp.trancl_into_trancl)
done

lemma has_fields_mono_lem:
  assumes "P \<turnstile> D \<preceq>\<^sup>* C" "P \<turnstile> C has_fields FDTs"
  shows "\<exists>pre. P \<turnstile> D has_fields pre@FDTs \<and> dom(map_of pre) \<inter> dom(map_of FDTs) = {}"
using assms
apply(induct rule:converse_rtranclp_induct)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(subcls1 P)^++ D' C")
 prefer 2 apply(erule (1) rtranclp_into_tranclp2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
 apply(rule refl)
apply(rule_tac x = "map (\<lambda>(F,Tm). ((F,D'),Tm)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done

lemma has_fields_is_class:
  "P \<turnstile> C has_fields FDTs \<Longrightarrow> is_class P C"
by (auto simp add: is_class_def elim: Fields.cases)

lemma Object_has_fields_Object:
  assumes "P \<turnstile> Object has_fields FDTs"
  shows "snd ` fst ` set FDTs \<subseteq> {Object}"
using assms by cases auto

definition
  has_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> fmod \<Rightarrow> cname \<Rightarrow> bool"
                   ("_ \<turnstile> _ has _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
  "P \<turnstile> C has F:T (fm) in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and> map_of FDTs (F,D) = Some (T, fm)"

lemma has_field_mono:
  "\<lbrakk> P \<turnstile> C has F:T (fm) in D; P \<turnstile> C' \<preceq>\<^sup>* C \<rbrakk> \<Longrightarrow> P \<turnstile> C' has F:T (fm) in D"
by(fastforce simp:has_field_def map_add_def dest: has_fields_mono_lem)

lemma has_field_is_class:
  "P \<turnstile> C has M:T (fm) in D \<Longrightarrow> is_class P C"
by (auto simp add: is_class_def has_field_def elim: Fields.cases)

lemma has_field_decl_above:
  "P \<turnstile> C has F:T (fm) in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
unfolding has_field_def
by(auto dest: map_of_SomeD has_fields_decl_above)

lemma has_field_fun:
  "\<lbrakk>P \<turnstile> C has F:T (fm) in D; P \<turnstile> C has F:T' (fm') in D\<rbrakk> \<Longrightarrow> T' = T \<and> fm = fm'"
by(auto simp:has_field_def dest:has_fields_fun)

definition
  sees_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> fmod \<Rightarrow> cname \<Rightarrow> bool"
                  ("_ \<turnstile> _ sees _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
  "P \<turnstile> C sees F:T (fm) in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and>
            map_of (map (\<lambda>((F,D),Tm). (F,(D,Tm))) FDTs) F = Some(D,T,fm)"

lemma map_of_remap_SomeD:
  "map_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) \<Longrightarrow> map_of t (k, k') = Some x"
by (induct t) (auto simp:fun_upd_apply split: if_split_asm)

lemma has_visible_field:
  "P \<turnstile> C sees F:T (fm) in D \<Longrightarrow> P \<turnstile> C has F:T (fm) in D"
by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)

lemma sees_field_fun:
  "\<lbrakk>P \<turnstile> C sees F:T (fm) in D; P \<turnstile> C sees F:T' (fm') in D'\<rbrakk> \<Longrightarrow> T' = T \<and> D' = D \<and> fm = fm'"
by(fastforce simp:sees_field_def dest:has_fields_fun)

lemma sees_field_decl_above:
  "P \<turnstile> C sees F:T (fm) in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
by(clarsimp simp add: sees_field_def)
  (blast intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)

lemma sees_field_idemp:
  assumes "P \<turnstile> C sees F:T (fm) in D"
  shows "P \<turnstile> D sees F:T (fm) in D"
proof -
  from assms obtain FDTs where has: "P \<turnstile> C has_fields FDTs"
    and F: "map_of (map (\<lambda>((F, D), Tm). (F, D, Tm)) FDTs) F = \<lfloor>(D, T, fm)\<rfloor>"
    unfolding sees_field_def by blast
  thus ?thesis
  proof induct
    case has_fields_rec thus ?case unfolding sees_field_def
      by(auto)(fastforce dest: map_of_SomeD intro!: exI intro: Fields.has_fields_rec)
  next
    case has_fields_Object thus ?case unfolding sees_field_def
      by(fastforce dest: map_of_SomeD intro: Fields.has_fields_Object intro!: exI)
  qed
qed

subsection "Functional lookup"

definition "method" :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> cname \<times> ty list \<times> ty \<times> 'm option"
where "method P C M  \<equiv>  THE (D,Ts,T,m). P \<turnstile> C sees M:Ts \<rightarrow> T = m in D"

definition field  :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> cname \<times> ty \<times> fmod"
where "field P C F  \<equiv>  THE (D,T,fm). P \<turnstile> C sees F:T (fm) in D"

definition fields :: "'m prog \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> (ty \<times> fmod)) list"
where "fields P C  \<equiv>  THE FDTs. P \<turnstile> C has_fields FDTs"

lemma field_def2 [simp]: "P \<turnstile> C sees F:T (fm) in D \<Longrightarrow> field P C F = (D,T,fm)"
(*<*)by (unfold field_def) (auto dest: sees_field_fun)(*>*)

lemma method_def2 [simp]: "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D \<Longrightarrow> method P C M = (D,Ts,T,m)"
(*<*)by (unfold method_def) (auto dest: sees_method_fun)(*>*)

lemma has_fields_b_fields:
  "P \<turnstile> C has_fields FDTs \<Longrightarrow> fields P C = FDTs"
unfolding fields_def
by (blast intro: the_equality has_fields_fun)

lemma has_field_map_of_fields [simp]:
  "P \<turnstile> C has F:T (fm) in D \<Longrightarrow> map_of (fields P C) (F, D) = \<lfloor>(T, fm)\<rfloor>"
by(auto simp add: has_field_def)

subsection \<open>Code generation\<close>

text \<open>New introduction rules for subcls1\<close>

code_pred
  \<comment> \<open>Disallow mode @{text "i_o_o"} to force @{text code_pred} in subsequent predicates not to use this inefficient mode\<close>
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  subcls1
.

text \<open>
  Introduce proper constant \<open>subcls'\<close> for @{term "subcls"}
  and generate executable equation for \<open>subcls'\<close>
\<close>

definition subcls' where "subcls' = subcls"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  subcls'
.

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 P)^** = subcls' P"
by(simp add: subcls'_def)

text \<open>
  Change rule @{thm widen_array_object} such that predicate compiler
  tests on class @{term Object} first. Otherwise \<open>widen_i_o_i\<close> never terminates.
\<close>

lemmas [code_pred_intro] =
  widen_refl widen_subcls widen_null widen_null_array widen_array_object_code widen_array_array
code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  widen
by(erule widen.cases) auto

text \<open>
  Readjust the code equations for @{term widen} such that @{term widen_i_i_i} is guaranteed to
  contain @{term "()"} at most once (even in the code representation!). This is important
  for the scheduler and the small-step semantics because of the weaker code equations
  for @{term "the"}.

  A similar problem cannot hit the subclass relation because, for acyclic subclass hierarchies,
  the paths in the hieararchy are unique and cycle-free.
\<close>

definition widen_i_i_i' where "widen_i_i_i' = widen_i_i_i"

declare widen.equation [code del]
lemmas widen_i_i_i'_equation [code] = widen.equation[folded widen_i_i_i'_def]

lemma widen_i_i_i_code [code]:
  "widen_i_i_i P T T' = (if P \<turnstile> T \<le> T' then Predicate.single () else bot)"
by(auto intro!: pred_eqI intro: widen_i_i_iI elim: widen_i_i_iE)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Methods
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool)
  [inductify]
  Method
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  [inductify]
  has_method
.

(* FIXME: Necessary only because of bug in code_pred *)
declare fun_upd_def [code_pred_inline]

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Fields
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool)
  [inductify, skip_proof]
  has_field
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool)
  [inductify, skip_proof]
  sees_field
.

lemma eval_Method_i_i_i_o_o_o_o_conv:
  "Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (\<lambda>(Ts, T, m, D). P \<turnstile> C sees M:Ts\<rightarrow>T=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)

lemma method_code [code]:
  "method P C M =
  Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (\<lambda>(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_sees_field_i_i_i_o_o_o_conv:
  "Predicate.eval (sees_field_i_i_i_o_o_o P C F) = (\<lambda>(T, fm, D). P \<turnstile> C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_oI elim: sees_field_i_i_i_o_o_oE)

lemma eval_sees_field_i_i_i_o_i_conv:
  "Predicate.eval (sees_field_i_i_i_o_o_i P C F D) = (\<lambda>(T, fm). P \<turnstile> C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_iI elim: sees_field_i_i_i_o_o_iE)

lemma field_code [code]:
  "field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o_o P C F) (\<lambda>(T, fm, D). Predicate.single (D, T, fm)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_Fields_conv:
  "Predicate.eval (Fields_i_i_o P C) = (\<lambda>FDTs. P \<turnstile> C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)

lemma fields_code [code]:
  "fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)

code_identifier
  code_module TypeRel \<rightharpoonup>
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module Decl \<rightharpoonup>
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel

end


section "Ignore Failures"

theory ignore_fails
  imports execution_invariants utils simulation_proofs
begin

text "In this section we show that we do not handle crashes (action @{term ACrash}) in order to prove
correctness.
The main idea is that we we cannot distinguish a crash from arbitrary long waiting."

text_raw \<open>\DefineSnippet{can_ignore_fails}{\<close>
lemma can_ignore_fails:
  shows "(\<forall>tr\<in>traces program. traceCorrect tr)
  \<longleftrightarrow> (\<forall>tr\<in>traces program. (\<nexists>s. (s, ACrash) \<in> set tr) \<longrightarrow>  traceCorrect tr)"
text_raw \<open>}%EndSnippet\<close>
proof (rule iffI2; clarsimp)
  fix tr
  assume is_trace: "tr \<in> traces program"
    and tr_fail: "\<not> traceCorrect tr"

  from this obtain aFail S'
    where "aFail\<in>set tr"
      and "\<not>actionCorrect (get_action aFail)"
      and "initialState program ~~ tr \<leadsto>* S'"
    by (auto simp add: traceCorrect_def traces_def)

  text \<open>
  Idea: a failed node and a node without progress are not really distinguishable in practice.
  In our semantics there are two small differences:

  1) state is different after failure
\<close>

  show "\<exists>tr\<in>traces program. (\<forall>s. (s, ACrash) \<notin> set tr) \<and> \<not> traceCorrect tr"
  proof (rule bexI[where x="[x\<leftarrow>tr . \<not>isACrash (get_action x)]"], intro conjI allI)

    show "\<And>s. (s, ACrash) \<notin> set [x\<leftarrow>tr . \<not>isACrash (get_action x)]"
      by (auto simp add: isACrash_def)

    show "\<not> traceCorrect [tr\<leftarrow>tr . \<not> isACrash (get_action tr)]"
      using tr_fail by (auto simp add: traceCorrect_def isACrash_def actionCorrect_def, force+)

    from \<open>initialState program ~~ tr \<leadsto>* S'\<close>
    have "\<exists>S''. (initialState program ~~ [tr\<leftarrow>tr . \<not> isACrash (get_action tr)] \<leadsto>* S'')
        \<and> (
           calls S'' = calls S'
         \<and> happensBefore S'' = happensBefore S'
         \<and> prog S'' = prog S'
         \<and> txStatus S'' = txStatus S'
         \<and> callOrigin S'' = callOrigin S'
         \<and> txOrigin S'' = txOrigin S'
         \<and> generatedIds S'' = generatedIds S'
         \<and> knownIds S'' = knownIds S'
         \<and> invocOp S'' = invocOp S'
         \<and> invocRes S'' = invocRes S'
         \<and> (\<forall>s. (s, ACrash) \<notin> set tr \<longrightarrow> (
             localState S'' s = localState S' s
           \<and> currentTx S'' s = currentTx S' s
           \<and> currentProc S'' s = currentProc S' s
           \<and> visibleCalls S'' s = visibleCalls S' s
         ))
        )"
    proof (induct rule: trace_simulationProof)
      case initial
      then show ?case by auto
    next
      case f_empty_to_empty
      then show ?case by auto
    next
      case (induct_step tr a S1 S2 S1')
      from steps_append2[OF induct_step.steps2]
      have [simp]: "(initialState program ~~ [tr\<leftarrow>tr . \<not> isACrash (get_action tr)] @ trb \<leadsto>* C) \<longleftrightarrow> (S2 ~~ trb \<leadsto>* C)" for trb C .

      from \<open>S1 ~~ a \<leadsto> S1'\<close>
      show ?case
      proof (cases rule: step.cases)
        case (local s ls f failed ls')

        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>localState S1 s \<triangleq> ls\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (metis (full_types) everything_starts_with_an_invocation in_set_conv_nth option.simps(3))

        show ?thesis
          by (rule exI[where x="S2\<lparr>localState := localState S2(s \<mapsto> ls')\<rparr>"],
              intro conjI,
              insert induct_step.coupling no_fail local,
              auto simp add: step_simps state_ext local induct_step steps_single)
      next
        case (newId s ls f ls' uid uidv ls'')
        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>localState S1 s \<triangleq> ls\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (metis (full_types) everything_starts_with_an_invocation in_set_conv_nth option.simps(3))

        show ?thesis
          by (rule exI[where x="S2\<lparr>localState := localState S2(s \<mapsto> ls''), generatedIds := (generatedIds S2)(uid \<mapsto> s )\<rparr>"],
              insert induct_step.coupling no_fail newId,
              auto simp add: step_simps state_ext  induct_step steps_single)

      next
        case (beginAtomic s ls f ls' t vis snapshot)
        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>localState S1 s \<triangleq> ls\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (metis (full_types) everything_starts_with_an_invocation in_set_conv_nth option.simps(3))

        show ?thesis
          by (rule exI[where x="S2\<lparr>
                  localState := localState S2(s \<mapsto> ls'),
                  currentTx := currentTx S2(s \<mapsto> t),
                  txStatus := txStatus S1(t \<mapsto> Uncommitted),
                  txOrigin := txOrigin S2(t \<mapsto> s),
                  visibleCalls := visibleCalls S2(s \<mapsto> snapshot)\<rparr>"],
              insert induct_step.coupling no_fail beginAtomic,
              auto simp add: step_simps state_ext  induct_step steps_single )

      next
        case (endAtomic s ls f ls' t)
        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>localState S1 s \<triangleq> ls\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (metis (full_types) everything_starts_with_an_invocation in_set_conv_nth option.simps(3))

        show ?thesis
          by (rule exI[where x="S2\<lparr>localState := localState S2(s \<mapsto> ls'), currentTx := (currentTx S2)(s := None), txStatus := txStatus S1(t \<mapsto> Committed)\<rparr>"],
              insert induct_step.coupling no_fail endAtomic,
              auto simp add: step_simps state_ext  induct_step steps_single)
      next
        case (dbop s ls f Op ls' t c res vis)
        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>localState S1 s \<triangleq> ls\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (metis (full_types) everything_starts_with_an_invocation in_set_conv_nth option.simps(3))

        show ?thesis
          by (rule exI[where x="S2\<lparr>localState := localState S2(s \<mapsto> ls' res), calls := calls S2(c \<mapsto> Call Op res), callOrigin := callOrigin S1(c \<mapsto> t), visibleCalls := visibleCalls S2(s \<mapsto> vis \<union> {c}), happensBefore := happensBefore S1 \<union> vis \<times> {c}\<rparr>"],
              insert induct_step.coupling no_fail dbop,
              auto simp add: step_simps state_ext  induct_step steps_single)

      next
        case (invocation s procName initialLocalState impl)
        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>invocOp S1 s = None\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (meson everything_starts_with_an_invocation in_set_conv_nth)

        show ?thesis
          by (rule exI[where x="S2\<lparr>localState := localState S2(s \<mapsto> initialLocalState), currentProc := currentProc S2(s \<mapsto> impl), visibleCalls := visibleCalls S2(s \<mapsto> {}), invocOp := invocOp S2(s \<mapsto> procName)\<rparr>"],
              insert induct_step.coupling no_fail invocation,
              auto simp add: step_simps state_ext  induct_step steps_single)
      next
        case (return s ls f res)
        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>localState S1 s \<triangleq> ls\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (metis (full_types) everything_starts_with_an_invocation in_set_conv_nth option.simps(3))

        show ?thesis
          by (rule exI[where x="S2\<lparr>localState := (localState S2)(s := None), currentProc := (currentProc S2)(s := None), visibleCalls := (visibleCalls S2)(s := None), invocRes := invocRes S1(s \<mapsto> res), knownIds := knownIds S1 \<union> uniqueIds res\<rparr>"],
              insert induct_step.coupling no_fail return,
              auto simp add: step_simps state_ext  induct_step steps_single)
      next
        case (crash s ls)
        from \<open>initialState program ~~ tr \<leadsto>* S1\<close> \<open>localState S1 s \<triangleq> ls\<close>
        have no_fail: "(s, ACrash) \<notin> set tr"
          by (metis (full_types) everything_starts_with_an_invocation in_set_conv_nth option.simps(3))
        show ?thesis
          by (rule exI[where x="S2"],
              auto simp add: step_simps state_ext  induct_step  crash)

      next
        case (invCheck res s)

        show ?thesis
          by (rule exI[where x="S2"],
              insert  induct_step.coupling  invCheck,
              auto simp add: step_simps state_ext  induct_step steps_single)
      qed
    qed

    then show "[tr\<leftarrow>tr . \<not> isACrash (get_action tr)] \<in> traces program"
      by (auto simp add: traces_def)
  qed
qed

end


theory Inca_to_Ubx_compiler
  imports Inca_to_Ubx_simulation Result
    "VeriComp.Compiler"
    "HOL-Library.Monad_Syntax"
begin

section \<open>Generic program rewriting\<close>

primrec monadic_fold_map where
  "monadic_fold_map f acc [] = Some (acc, [])" |
  "monadic_fold_map f acc (x # xs) = do {
    (acc', x') \<leftarrow> f acc x;
    (acc'', xs') \<leftarrow> monadic_fold_map f acc' xs;
    Some (acc'', x' # xs')
  }"

lemma monadic_fold_map_length:
  "monadic_fold_map f acc xs = Some (acc', xs') \<Longrightarrow> length xs = length xs'"
  by (induction xs arbitrary: acc xs') (auto simp: bind_eq_Some_conv)

lemma monadic_fold_map_ConsD[dest]:
  assumes "monadic_fold_map f a (x # xs) = Some (c, ys)"
  shows "\<exists>y ys' b. ys = y # ys' \<and> f a x = Some (b, y) \<and> monadic_fold_map f b xs = Some (c, ys')"
  using assms
  by (auto simp add: bind_eq_Some_conv)

lemma monadic_fold_map_list_all2:
  assumes "monadic_fold_map f acc xs = Some (acc', ys)" and
    "\<And>acc acc' x y. f acc x = Some (acc', y) \<Longrightarrow> P x y"
  shows "list_all2 P xs ys"
  using assms(1)
proof (induction xs arbitrary: acc ys)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  show ?case
    using Cons.prems
    by (auto simp: bind_eq_Some_conv intro: assms(2) Cons.IH)
qed

lemma monadic_fold_map_list_all:
  assumes "monadic_fold_map f acc xs = Some (acc', ys)" and
    "\<And>acc acc' x y. f acc x = Some (acc', y) \<Longrightarrow> P y"
  shows "list_all P ys"
proof -
  have "list_all2 (\<lambda>_. P) xs ys"
    using assms
    by (auto elim: monadic_fold_map_list_all2)
  thus ?thesis
    by (auto elim: list_rel_imp_pred2)
qed

fun gen_pop_push where
  "gen_pop_push instr (domain, codomain) \<Sigma> = (
    let ar = length domain in
    if ar \<le> length \<Sigma> \<and> take ar \<Sigma> = domain then
      Some (instr, codomain @ drop ar \<Sigma>)
    else
      None
  )"

context inca_to_ubx_simulation begin

section \<open>Lifting\<close>

fun lift_instr where
  "lift_instr F L ret N (Inca.IPush d) \<Sigma> = Some (IPush d, None # \<Sigma>)" |
  "lift_instr F L ret N Inca.IPop (_ # \<Sigma>) = Some (IPop, \<Sigma>)" |
  "lift_instr F L ret N (Inca.IGet n) \<Sigma> = (if n < N then Some (IGet n, None # \<Sigma>) else None)" |
  "lift_instr F L ret N (Inca.ISet n) (None # \<Sigma>) = (if n < N then Some (ISet n, \<Sigma>) else None)" |
  "lift_instr F L ret N (Inca.ILoad x) (None # \<Sigma>) = Some (ILoad x, None # \<Sigma>)" |
  "lift_instr F L ret N (Inca.IStore x) (None # None # \<Sigma>) = Some (IStore x, \<Sigma>)" |
  "lift_instr F L ret N (Inca.IOp op) \<Sigma> =
    gen_pop_push (IOp op) (replicate (\<AA>\<rr>\<ii>\<tt>\<yy> op) None, [None]) \<Sigma>" |
  "lift_instr F L ret N (Inca.IOpInl opinl) \<Sigma> =
    gen_pop_push (IOpInl opinl) (replicate (\<AA>\<rr>\<ii>\<tt>\<yy> (\<DD>\<ee>\<II>\<nn>\<ll> opinl)) None, [None]) \<Sigma>" |
  "lift_instr F L ret N (Inca.ICJump l\<^sub>t l\<^sub>f) [None] =
    (if List.member L l\<^sub>t \<and> List.member L l\<^sub>f then Some (ICJump l\<^sub>t l\<^sub>f, []) else None)" |
  "lift_instr F L ret N (Inca.ICall f) \<Sigma> = do {
    (ar, ret) \<leftarrow> F f;
    gen_pop_push (ICall f) (replicate ar None, replicate ret None) \<Sigma>
  }" |
  "lift_instr F L ret N Inca.IReturn \<Sigma> =
    (if \<Sigma> = replicate ret None then Some (IReturn, []) else None)" |
  "lift_instr _ _ _ _ _ _ = None"

definition lift_instrs where
  "lift_instrs F L ret N \<equiv>
    monadic_fold_map (\<lambda>\<Sigma> instr. map_option prod.swap (lift_instr F L ret N instr \<Sigma>))"

lemma lift_instrs_length:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "length xs = length ys"
  using assms unfolding lift_instrs_def
  by (auto intro: monadic_fold_map_length)

lemma lift_instrs_not_Nil: "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys) \<Longrightarrow> xs \<noteq> [] \<longleftrightarrow> ys \<noteq> []"
  using lift_instrs_length by fastforce

lemma lift_instrs_NilD[dest]:
  assumes "lift_instrs F L ret N \<Sigma>i [] = Some (\<Sigma>o, ys)"
  shows "\<Sigma>o = \<Sigma>i \<and> ys = []"
  using assms
  by (simp_all add: lift_instrs_def)

lemmas Some_eq_bind_conv =
  bind_eq_Some_conv[unfolded eq_commute[of "Option.bind f g" "Some x" for f g x]]

lemma lift_instr_is_jump:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Inca.is_jump x \<longleftrightarrow> Ubx.is_jump y"
  using assms
  by (rule lift_instr.elims)
    (auto simp add: if_split_eq2 Let_def Some_eq_bind_conv)

lemma lift_instr_is_return:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Inca.is_return x \<longleftrightarrow> Ubx.is_return y"
  using assms
  by (rule lift_instr.elims)
    (auto simp add: if_split_eq2 Let_def Some_eq_bind_conv)

lemma lift_instrs_all_not_jump_not_return:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows
    "list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) xs \<longleftrightarrow>
     list_all (\<lambda>i. \<not> Ubx.is_jump i \<and> \<not> Ubx.is_return i) ys"
  using assms
proof (induction xs arbitrary: \<Sigma>i \<Sigma>o ys)
  case Nil
  then show ?case by (simp add: lift_instrs_def)
next
  case (Cons x xs)
  from Cons.prems show ?case
    apply (simp add: lift_instrs_def bind_eq_Some_conv)
    apply (fold lift_instrs_def)
    by (auto simp add: Cons.IH lift_instr_is_jump lift_instr_is_return)
qed

lemma lift_instrs_all_butlast_not_jump_not_return:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows
    "list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) (butlast xs) \<longleftrightarrow>
     list_all (\<lambda>i. \<not> Ubx.is_jump i \<and> \<not> Ubx.is_return i) (butlast ys)"
  using lift_instrs_length[OF assms(1)] assms unfolding lift_instrs_def
proof (induction xs ys arbitrary: \<Sigma>i \<Sigma>o rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons x xs y ys)
  thus ?case
    by (auto simp add: bind_eq_Some_conv lift_instr_is_jump lift_instr_is_return)
qed

lemma lift_instr_sp:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.sp_instr F ret y \<Sigma>i \<Sigma>o"
  using assms
  apply (induction F L ret N x \<Sigma>i rule: lift_instr.induct;
      auto simp: Let_def intro: Subx.sp_instr.intros)
    apply (rule Subx.sp_instr.Op, metis append_take_drop_id)
   apply (rule Subx.sp_instr.OpInl, metis append_take_drop_id)
  apply (auto simp add: bind_eq_Some_conv intro!: Subx.sp_instr.Call, metis append_take_drop_id)
  done

lemma lift_instrs_sp:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "Subx.sp_instrs F ret ys \<Sigma>i \<Sigma>o"
  using assms unfolding lift_instrs_def
proof (induction xs arbitrary: \<Sigma>i \<Sigma>o ys)
  case Nil
  thus ?case by (auto intro: Subx.sp_instrs.Nil)
next
  case (Cons x xs)
  from Cons.prems show ?case
    by (auto simp add: bind_eq_Some_conv intro: Subx.sp_instrs.Cons lift_instr_sp Cons.IH)
qed

lemma lift_instr_fun_call_in_range:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.fun_call_in_range F y"
  using assms
  by (induction F L ret N x \<Sigma>i rule: lift_instr.induct) (auto simp: Let_def bind_eq_Some_conv)

lemma lift_instrs_all_fun_call_in_range:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.fun_call_in_range F) ys"
  using assms unfolding lift_instrs_def
  by (auto intro!: monadic_fold_map_list_all intro: lift_instr_fun_call_in_range)

lemma lift_instr_local_var_in_range:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.local_var_in_range N y"
  using assms
  by (induction F L ret N x \<Sigma>i rule: lift_instr.induct) (auto simp: Let_def bind_eq_Some_conv)

lemma lift_instrs_all_local_var_in_range:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.local_var_in_range N) ys"
  using assms unfolding lift_instrs_def
  by (auto intro!: monadic_fold_map_list_all intro: lift_instr_local_var_in_range)

lemma lift_instr_jump_in_range:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.jump_in_range (set L) y"
  using assms
  by (induction F L ret N x \<Sigma>i rule: lift_instr.induct)
    (auto simp: Let_def bind_eq_Some_conv in_set_member)

lemma lift_instrs_all_jump_in_range:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.jump_in_range (set L)) ys"
  using assms unfolding lift_instrs_def
  by (auto intro!: monadic_fold_map_list_all intro: lift_instr_jump_in_range)

lemma lift_instr_norm:
  "lift_instr F L ret N instr1 \<Sigma>1 = Some (instr2, \<Sigma>2) \<Longrightarrow> norm_eq instr1 instr2"
  by (induction instr1 \<Sigma>1 rule: lift_instr.induct) (auto simp: Let_def bind_eq_Some_conv)

lemma lift_instrs_all_norm:
  assumes "lift_instrs F L ret N \<Sigma>1 instrs1 = Some (\<Sigma>2, instrs2)"
  shows "list_all2 norm_eq instrs1 instrs2"
  using assms unfolding lift_instrs_def
  by (auto simp: lift_instr_norm elim!: monadic_fold_map_list_all2)

section \<open>Optimization\<close>

context
  fixes load_oracle :: "nat \<Rightarrow> type option"
begin

definition orelse :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"  (infixr "orelse" 55) where
  "x orelse y = (case x of Some x' \<Rightarrow> Some x' | None \<Rightarrow> y)"

lemma orelse_eq_Some_conv:
  "x orelse y = Some z \<longleftrightarrow> (x = Some z \<or> x = None \<and> y = Some z)"
  by (cases x) (simp_all add: orelse_def)

lemma orelse_eq_SomeE:
  assumes
    "x orelse y = Some z" and
    "x = Some z \<Longrightarrow> P" and
    "x = None \<Longrightarrow> y = Some z \<Longrightarrow> P"
  shows "P"
  using assms(1)
  unfolding orelse_def
  by (cases x; auto intro: assms(2,3))

fun drop_prefix where
  "drop_prefix [] ys = Some ys" |
  "drop_prefix (x # xs) (y # ys) = (if x = y then drop_prefix xs ys else None)" |
  "drop_prefix _ _ = None "

lemma drop_prefix_eq_Some_conv: "drop_prefix xs ys = Some zs \<longleftrightarrow> ys = xs @ zs"
  by (induction xs ys arbitrary: zs rule: drop_prefix.induct)
    (auto simp: if_split_eq1)

fun optim_instr where
  "optim_instr _ _ _ (IPush d) \<Sigma> =
    Some Pair \<diamondop> (Some IPushUbx1 \<diamondop> (unbox_ubx1 d)) \<diamondop> Some (Some Ubx1 # \<Sigma>) orelse
    Some Pair \<diamondop> (Some IPushUbx2 \<diamondop> (unbox_ubx2 d)) \<diamondop> Some (Some Ubx2 # \<Sigma>) orelse
    Some (IPush d, None # \<Sigma>)
  " |
  "optim_instr _ _ _ (IPushUbx1 n) \<Sigma> = Some (IPushUbx1 n, Some Ubx1 # \<Sigma>)" |
  "optim_instr _ _ _ (IPushUbx2 b) \<Sigma> = Some (IPushUbx2 b, Some Ubx2 # \<Sigma>)" |
  "optim_instr _ _ _ IPop (_ # \<Sigma>) = Some (IPop, \<Sigma>)" |
  "optim_instr _ _ pc (IGet n) \<Sigma> =
    map_option (\<lambda>\<tau>. (IGetUbx \<tau> n, Some \<tau> # \<Sigma>)) (load_oracle pc) orelse
    Some (IGet n, None # \<Sigma>)" |
  "optim_instr _ _ pc (IGetUbx \<tau> n) \<Sigma> = Some (IGetUbx \<tau> n, Some \<tau> # \<Sigma>)" |
  "optim_instr _ _ _ (ISet n) (None # \<Sigma>) = Some (ISet n, \<Sigma>)" |
  "optim_instr _ _ _ (ISet n) (Some \<tau> # \<Sigma>) = Some (ISetUbx \<tau> n, \<Sigma>)" |
  "optim_instr _ _ _ (ISetUbx _ n) (None # \<Sigma>) = Some (ISet n, \<Sigma>)" |
  "optim_instr _ _ _ (ISetUbx _ n) (Some \<tau> # \<Sigma>) = Some (ISetUbx \<tau> n, \<Sigma>)" |
  "optim_instr _ _ pc (ILoad x) (None # \<Sigma>) =
    map_option (\<lambda>\<tau>. (ILoadUbx \<tau> x, Some \<tau> # \<Sigma>)) (load_oracle pc) orelse
    Some (ILoad x, None # \<Sigma>)" |
  "optim_instr _ _ _ (ILoadUbx \<tau> x) (None # \<Sigma>) = Some (ILoadUbx \<tau> x, Some \<tau> # \<Sigma>)" |
  "optim_instr _ _ _ (IStore x) (None # None # \<Sigma>) = Some (IStore x, \<Sigma>)" |
  "optim_instr _ _ _ (IStore x) (None # Some \<tau> # \<Sigma>) = Some (IStoreUbx \<tau> x, \<Sigma>)" |
  "optim_instr _ _ _ (IStoreUbx _ x) (None # None # \<Sigma>) = Some (IStore x, \<Sigma>)" |
  "optim_instr _ _ _ (IStoreUbx _ x) (None # Some \<tau> # \<Sigma>) = Some (IStoreUbx \<tau> x, \<Sigma>)" |
  "optim_instr _ _ _ (IOp op) \<Sigma> =
    map_option (\<lambda>\<Sigma>o. (IOp op, None # \<Sigma>o)) (drop_prefix (replicate (\<AA>\<rr>\<ii>\<tt>\<yy> op) None) \<Sigma>)" |
  "optim_instr _ _ _ (IOpInl opinl) \<Sigma> = (
    let ar = \<AA>\<rr>\<ii>\<tt>\<yy> (\<DD>\<ee>\<II>\<nn>\<ll> opinl) in
    if ar \<le> length \<Sigma> then
      case \<UU>\<bb>\<xx> opinl (take ar \<Sigma>) of
        None \<Rightarrow> map_option (\<lambda>\<Sigma>o. (IOpInl opinl, None # \<Sigma>o)) (drop_prefix (replicate ar None) \<Sigma>) |
        Some opubx \<Rightarrow> map_option (\<lambda>\<Sigma>o. (IOpUbx opubx, snd (\<TT>\<yy>\<pp>\<ee>\<OO>\<ff>\<OO>\<pp> opubx) # \<Sigma>o))
          (drop_prefix (fst (\<TT>\<yy>\<pp>\<ee>\<OO>\<ff>\<OO>\<pp> opubx)) \<Sigma>)
    else
      None
  )" |
  "optim_instr _ _ _ (IOpUbx opubx) \<Sigma> =
    (let p = \<TT>\<yy>\<pp>\<ee>\<OO>\<ff>\<OO>\<pp> opubx in
     map_option (\<lambda>\<Sigma>o. (IOpUbx opubx, snd p # \<Sigma>o)) (drop_prefix (fst p) \<Sigma>))" |
  "optim_instr _ _ _ (ICJump l\<^sub>t l\<^sub>f) [None] = Some (ICJump l\<^sub>t l\<^sub>f, []) " |
  "optim_instr F _ _ (ICall f) \<Sigma> = do {
    (ar, ret) \<leftarrow> F f;
    \<Sigma>o \<leftarrow> drop_prefix (replicate ar None) \<Sigma>;
    Some (ICall f, replicate ret None @ \<Sigma>o)
  }" |
  "optim_instr _ ret _ IReturn \<Sigma> = (if \<Sigma> = replicate ret None then Some (IReturn, []) else None)" |
  "optim_instr _ _ _ _ _ = None"

definition optim_instrs where
  "optim_instrs F ret \<equiv> \<lambda>pc \<Sigma>i instrs.
    map_option (\<lambda>((_, \<Sigma>o), instrs'). (\<Sigma>o, instrs'))
      (monadic_fold_map (\<lambda>(pc, \<Sigma>) instr.
        map_option (\<lambda>(instr', \<Sigma>o). ((Suc pc, \<Sigma>o), instr')) (optim_instr F ret pc instr \<Sigma>))
      (pc, \<Sigma>i) instrs)"

lemma optim_instrs_length:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "length xs = length ys"
  using assms unfolding optim_instrs_def
  by (auto intro: monadic_fold_map_length)

lemma optim_instrs_not_Nil: "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys) \<Longrightarrow> xs \<noteq> [] \<longleftrightarrow> ys \<noteq> []"
  using optim_instrs_length by fastforce

lemma optim_instrs_NilD[dest]:
  assumes "optim_instrs F ret pc \<Sigma>i [] = Some (\<Sigma>o, ys)"
  shows "\<Sigma>o = \<Sigma>i \<and> ys = []"
  using assms
  by (simp_all add: optim_instrs_def)

lemma optim_instrs_ConsD[dest]:
  assumes "optim_instrs F ret pc \<Sigma>i (x # xs) = Some (\<Sigma>o, ys)"
  shows "\<exists>y ys' \<Sigma>. ys = y # ys' \<and>
    optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>) \<and>
    optim_instrs F ret (Suc pc) \<Sigma> xs = Some (\<Sigma>o, ys')"
  using assms
  unfolding optim_instrs_def
  by (auto simp: bind_eq_Some_conv)

lemma optim_instr_norm:
  assumes "optim_instr F ret pc instr1 \<Sigma>1 = Some (instr2, \<Sigma>2)"
  shows "norm_instr instr1 = norm_instr instr2"
  using assms
  by (cases "(F, ret, pc, instr1, \<Sigma>1)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 bind_eq_Some_conv option.case_eq_if
      orelse_eq_Some_conv
      dest!: Subx.box_unbox_inverse dest: Subx.\<UU>\<bb>\<xx>_invertible)

lemma optim_instrs_all_norm:
  assumes "optim_instrs F ret pc \<Sigma>1 instrs1 = Some (\<Sigma>2, instrs2)"
  shows "list_all2 (\<lambda>i1 i2. norm_instr i1 = norm_instr i2) instrs1 instrs2"
  using assms unfolding optim_instrs_def
  by (auto simp: optim_instr_norm elim!: monadic_fold_map_list_all2)

lemma optim_instr_is_jump:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "is_jump x \<longleftrightarrow> is_jump y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases;
      simp add: orelse_eq_Some_conv ap_option_eq_Some_conv bind_eq_Some_conv
        Let_def if_split_eq1 option.case_eq_if;
      safe; simp)

lemma optim_instr_is_return:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "is_return x \<longleftrightarrow> is_return y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases;
      simp add: orelse_eq_Some_conv ap_option_eq_Some_conv bind_eq_Some_conv
        Let_def if_split_eq1 option.case_eq_if;
      safe; simp)

lemma optim_instrs_all_butlast_not_jump_not_return:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows
    "list_all (\<lambda>i. \<not> is_jump i \<and> \<not> is_return i) (butlast xs) \<longleftrightarrow>
     list_all (\<lambda>i. \<not> is_jump i \<and> \<not> is_return i) (butlast ys)"
  using optim_instrs_length[OF assms(1)] assms
proof (induction xs ys arbitrary: pc \<Sigma>i \<Sigma>o rule: list_induct2)
  case Nil
  thus ?case by simp
next
  case (Cons x xs y ys)
  from Cons.prems obtain \<Sigma> where
    optim_x: "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>)" and
    optim_xs: "optim_instrs F ret (Suc pc) \<Sigma> xs = Some (\<Sigma>o, ys)"
    by auto
  show ?case
    using Cons.hyps
    using optim_x optim_xs
    apply (simp add: Cons.IH optim_instr_is_jump optim_instr_is_return)
    by fastforce
qed

lemma optim_instr_jump_in_range:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.jump_in_range L x \<longleftrightarrow> Subx.jump_in_range L y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 option.case_eq_if
      bind_eq_Some_conv orelse_eq_Some_conv)

lemma optim_instrs_all_jump_in_range:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.jump_in_range L) xs \<longleftrightarrow> list_all (Subx.jump_in_range L) ys"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys) (auto simp: optim_instr_jump_in_range)

lemma optim_instr_fun_call_in_range:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.fun_call_in_range F x \<longleftrightarrow> Subx.fun_call_in_range F y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 option.case_eq_if
      bind_eq_Some_conv orelse_eq_Some_conv)

lemma optim_instrs_all_fun_call_in_range:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.fun_call_in_range F) xs \<longleftrightarrow> list_all (Subx.fun_call_in_range F) ys"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys) (auto simp: optim_instr_fun_call_in_range)

lemma optim_instr_local_var_in_range:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.local_var_in_range N x \<longleftrightarrow> Subx.local_var_in_range N y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 option.case_eq_if
      bind_eq_Some_conv orelse_eq_Some_conv)

lemma optim_instrs_all_local_var_in_range:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.local_var_in_range N) xs \<longleftrightarrow> list_all (Subx.local_var_in_range N) ys"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys) (auto simp: optim_instr_local_var_in_range)

lemma optim_instr_sp:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.sp_instr F ret y \<Sigma>i \<Sigma>o"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp add: Let_def if_split_eq1 option.case_eq_if
      simp: ap_option_eq_Some_conv orelse_eq_Some_conv drop_prefix_eq_Some_conv bind_eq_Some_conv
      intro: Subx.sp_instr.intros)

lemma optim_instrs_sp:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "Subx.sp_instrs F ret ys \<Sigma>i \<Sigma>o"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys)
    (auto intro!: Subx.sp_instrs.intros optim_instr_sp)

section \<open>Compilation of function definition\<close>

definition lift_basic_block where
  "lift_basic_block F L ret N \<equiv>
    ap_map_prod Some (\<lambda>i1. do {
      _ \<leftarrow> if i1 \<noteq> [] then Some () else None;
      _ \<leftarrow> if list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) (butlast i1) then Some () else None;
      (\<Sigma>o, i2) \<leftarrow> lift_instrs F L ret N ([] :: type option list) i1;
      (\<Sigma>o', i2') \<leftarrow> optim_instrs F ret 0 ([] :: type option list) i2;
      (if \<Sigma>o' = [] then
        Some i2'
      else (if \<Sigma>o = [] then
        Some i2
      else
        None))
    })"

lemma lift_basic_block_rel_prod_all_norm_eq:
  assumes "lift_basic_block F L ret N bblock1 = Some bblock2"
  shows "rel_prod (=) (list_all2 norm_eq) bblock1 bblock2"
  using assms
  unfolding lift_basic_block_def
  apply (auto simp add: ap_map_prod_eq_Some_conv bind_eq_Some_conv
      simp: if_split_eq1
      intro: lift_instrs_all_norm
      dest!: optim_instrs_all_norm lift_instrs_all_norm)
  subgoal for _ xs zs ys
    using list_all2_trans[of norm_eq "\<lambda>i. norm_eq (norm_instr i)" norm_eq xs ys zs, simplified]
    by simp
  done

lemma list_all_iff_butlast_last:
  assumes "xs \<noteq> []"
  shows "list_all P xs \<longleftrightarrow> list_all P (butlast xs) \<and> P (last xs)"
  using assms
  by (induction xs) auto

lemma lift_basic_block_wf:
  assumes "lift_basic_block F L ret N x = Some y"
  shows "Subx.wf_basic_block F (set L) ret N y"
proof -
  obtain f instrs1 \<Sigma>2 instrs2 \<Sigma>3 instrs3 instrs4 where
    x_def: "x = (f, instrs1)" and
    y_def: "y = (f, instrs4)" and
    "instrs1 \<noteq> []" and
    all_not_jump_not_return_instrs1:
      "list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) (butlast instrs1)" and
    lift_instrs1: "lift_instrs F L ret N ([] :: type option list) instrs1 = Some (\<Sigma>2, instrs2)" and
    optim_instrs2: "optim_instrs F ret 0 ([] :: type option list) instrs2 = Some (\<Sigma>3, instrs3)" and
    instr4_defs: "instrs4 = instrs3 \<and> \<Sigma>3 = [] \<or> instrs4 = instrs2 \<and> \<Sigma>2 = []"
    using assms
    unfolding lift_basic_block_def ap_map_prod_eq_Some_conv
    apply (auto simp: bind_eq_Some_conv if_split_eq1)
    by auto

  have "instrs4 \<noteq> []"
    using instr4_defs \<open>instrs1 \<noteq> []\<close>
    using lift_instrs_not_Nil[OF lift_instrs1]
    using optim_instrs_not_Nil[OF optim_instrs2]
    by meson
  moreover have "list_all (Subx.local_var_in_range N) instrs4"
    using instr4_defs lift_instrs1 optim_instrs2
    by (auto dest: lift_instrs_all_local_var_in_range simp: optim_instrs_all_local_var_in_range)
  moreover have "list_all (Subx.fun_call_in_range F) instrs4"
    using instr4_defs lift_instrs1 optim_instrs2
    by (auto dest: lift_instrs_all_fun_call_in_range simp: optim_instrs_all_fun_call_in_range)
  moreover have "list_all (Subx.jump_in_range (set L)) instrs4"
    using instr4_defs lift_instrs1 optim_instrs2
    by (auto dest: lift_instrs_all_jump_in_range simp: optim_instrs_all_jump_in_range)
  moreover have "list_all (\<lambda>i. \<not> Ubx.instr.is_jump i \<and> \<not> Ubx.instr.is_return i) (butlast instrs4)"
    using instr4_defs lift_instrs1 optim_instrs2 all_not_jump_not_return_instrs1
    by (auto simp:
        lift_instrs_all_butlast_not_jump_not_return
        optim_instrs_all_butlast_not_jump_not_return)
  moreover have "Subx.sp_instrs F ret instrs4 [] []"
    using instr4_defs lift_instrs1 optim_instrs2
    by (auto intro: lift_instrs_sp optim_instrs_sp)
  ultimately show ?thesis
    by (auto simp: y_def intro!: Subx.wf_basic_blockI)
qed

fun compile_fundef where
  "compile_fundef F (Fundef bblocks1 ar ret locals) = do {
    _ \<leftarrow> if bblocks1 = [] then None else Some ();
    bblocks2 \<leftarrow> ap_map_list (lift_basic_block F (map fst bblocks1) ret (ar + locals)) bblocks1;
    Some (Fundef bblocks2 ar ret locals)
  }"

lemma compile_fundef_arities: "compile_fundef F fd1 = Some fd2 \<Longrightarrow> arity fd1 = arity fd2"
  by (cases fd1) (auto simp: bind_eq_Some_conv)

lemma compile_fundef_returns: "compile_fundef F fd1 = Some fd2 \<Longrightarrow> return fd1 = return fd2"
  by (cases fd1) (auto simp: bind_eq_Some_conv)

lemma compile_fundef_locals:
  "compile_fundef F fd1 = Some fd2 \<Longrightarrow> fundef_locals fd1 = fundef_locals fd2"
  by (cases fd1) (auto simp: bind_eq_Some_conv)

lemma if_then_None_else_Some_eq[simp]:
  "(if a then None else Some b) = Some c \<longleftrightarrow> \<not> a \<and> b = c"
  "(if a then None else Some b) = None \<longleftrightarrow> a"
  by (cases a) simp_all

lemma
  assumes "compile_fundef F fd1 = Some fd2"
  shows
    rel_compile_fundef: "rel_fundef (=) norm_eq fd1 fd2" (is ?REL) and
    wf_compile_fundef: "Subx.wf_fundef F fd2" (is ?WF)
  unfolding atomize_conj
proof (cases fd1)
  case (Fundef bblocks1 ar ret locals)
  with assms obtain bblocks2 where
    "bblocks1 \<noteq> []" and
    lift_bblocks1:
      "ap_map_list (lift_basic_block F (map fst bblocks1) ret (ar + locals)) bblocks1 = Some bblocks2" and
    fd2_def: "fd2 = Fundef bblocks2 ar ret locals"
    by (auto simp add: bind_eq_Some_conv)

  show "?REL \<and> ?WF"
  proof (rule conjI)
    show ?REL
      unfolding Fundef fd2_def
    proof (rule fundef.rel_intros)
      show "list_all2 (rel_prod (=) (list_all2 norm_eq)) bblocks1 bblocks2"
        using lift_bblocks1
        unfolding ap_map_list_iff_list_all2
        by (auto elim: list.rel_mono_strong intro: lift_basic_block_rel_prod_all_norm_eq)
    qed simp_all
  next
    have "bblocks2 \<noteq> []"
      using \<open>bblocks1 \<noteq> []\<close> length_ap_map_list[OF lift_bblocks1] by force
    moreover have "list_all (Subx.wf_basic_block F (fst ` set bblocks1) ret (ar + locals)) bblocks2"
      using lift_bblocks1
      unfolding ap_map_list_iff_list_all2
      by (auto elim!: list_rel_imp_pred2 dest: lift_basic_block_wf)
    moreover have "fst ` set bblocks1 = fst ` set bblocks2"
      using lift_bblocks1
      unfolding ap_map_list_iff_list_all2
      by (induction bblocks1 bblocks2 rule: list.rel_induct)
        (auto simp add: lift_basic_block_def ap_map_prod_eq_Some_conv)
    ultimately show ?WF
      unfolding fd2_def
      by (auto intro: Subx.wf_fundefI)
  qed
qed

end

end

locale inca_ubx_compiler =
  inca_to_ubx_simulation Finca_empty Finca_get
  for
    Finca_empty and
    Finca_get :: "_ \<Rightarrow> 'fun \<Rightarrow> _ option" +
  fixes
    load_oracle :: "'fun \<Rightarrow> nat \<Rightarrow> type option"
begin

section \<open>Compilation of function environment\<close>

definition compile_env_entry where
  "compile_env_entry F \<equiv> \<lambda>p. ap_map_prod Some (compile_fundef (load_oracle (fst p)) F) p"

lemma rel_compile_env_entry:
  assumes "compile_env_entry F (f, fd1) = Some (f, fd2)"
  shows "rel_fundef (=) norm_eq fd1 fd2"
  using assms unfolding compile_env_entry_def
  by (auto simp: ap_map_prod_eq_Some_conv intro!: rel_compile_fundef)

definition compile_env where
  "compile_env e \<equiv> do {
    let fundefs1 = Finca_to_list e;
    fundefs2 \<leftarrow> ap_map_list (compile_env_entry (map_option funtype \<circ> Finca_get e)) fundefs1;
    Some (Subx.Fenv.from_list fundefs2)
  }"

lemma rel_ap_map_list_ap_map_list_compile_env_entries:
  assumes "ap_map_list (compile_env_entry F) xs = Some ys"
  shows "rel_fundefs (Finca_get (Sinca.Fenv.from_list xs)) (Fubx_get (Subx.Fenv.from_list ys))"
  using assms
proof (induction xs arbitrary: ys)
  case Nil
  thus ?case
    using rel_fundefs_empty by simp
next
  case (Cons x xs)
  from Cons.prems obtain y ys' where
    ys_def: "ys = y # ys'" and
    compile_env_x: "compile_env_entry F x = Some y" and
    compile_env_xs: "ap_map_list (compile_env_entry F) xs = Some ys'"
    by (auto simp add: ap_option_eq_Some_conv)

  obtain f fd1 fd2 where
    prods: "x = (f, fd1)" "y = (f, fd2)" and "compile_fundef (load_oracle f) F fd1 = Some fd2"
    using compile_env_x
    by (cases x) (auto simp: compile_env_entry_def eq_fst_iff ap_map_prod_eq_Some_conv)

  have "rel_fundef (=) norm_eq fd1 fd2"
    using compile_env_x[unfolded prods]
    by (auto intro: rel_compile_env_entry)
  thus ?case
    using Cons.IH[OF compile_env_xs, THEN rel_fundefsD]
    unfolding prods ys_def
    unfolding Sinca.Fenv.from_list_correct Subx.Fenv.from_list_correct
    by (auto intro: rel_fundefsI)
qed

lemma rel_fundefs_compile_env:
  assumes "compile_env F1 = Some F2"
  shows "rel_fundefs (Finca_get F1) (Fubx_get F2)"
proof -
  from assms obtain xs where
    ap_map_list_F1: "ap_map_list (compile_env_entry (map_option funtype \<circ> Finca_get F1)) (Finca_to_list F1) = Some xs" and
    F2_def: "F2 = Subx.Fenv.from_list xs"
    by (auto simp: compile_env_def bind_eq_Some_conv)

  show ?thesis
    using rel_ap_map_list_ap_map_list_compile_env_entries[OF ap_map_list_F1]
    unfolding F2_def Sinca.Fenv.get_from_list_to_list
    by assumption
qed

section \<open>Compilation of program\<close>

fun compile where
  "compile (Prog F1 H f) = Some Prog \<diamondop> compile_env F1 \<diamondop> Some H \<diamondop> Some f"

lemma ap_map_list_cong:
  assumes "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x" and "xs = ys"
  shows "ap_map_list f xs = ap_map_list g ys"
  using assms
  by (induction xs arbitrary: ys) auto

lemma compile_env_wf_fundefs:
  assumes "compile_env F1 = Some F2"
  shows "Subx.wf_fundefs (Fubx_get F2)"
proof (intro Subx.wf_fundefsI allI)
  fix f
  obtain xs where
    ap_map_list_F1: "ap_map_list (compile_env_entry (map_option funtype \<circ> Finca_get F1)) (Finca_to_list F1) = Some xs" and
    F2_def: "F2 = Subx.Fenv.from_list xs"
    using assms by (auto simp: compile_env_def bind_eq_Some_conv)

  have rel_map_of_F1_xs:
    "\<And>f. rel_option (\<lambda>x y. compile_fundef (load_oracle f) (map_option funtype \<circ> Finca_get F1) x = Some y)
      (map_of (Finca_to_list F1) f) (map_of xs f)"
    using ap_map_list_F1
    by (auto simp: compile_env_entry_def ap_map_prod_eq_Some_conv
        dest: ap_map_list_imp_rel_option_map_of)

  have funtype_F1_eq_funtype_F2:
    "map_option funtype \<circ> Finca_get F1 = map_option funtype \<circ> Fubx_get F2"
  proof (rule ext, simp)
    fix x
    show "map_option funtype (Finca_get F1 x) = map_option funtype (Fubx_get F2 x)"
      unfolding F2_def Subx.Fenv.from_list_correct Sinca.Fenv.to_list_correct[symmetric]
      using rel_map_of_F1_xs[of x]
      by (cases rule: option.rel_cases)
        (simp_all add: funtype_def compile_fundef_arities compile_fundef_returns)
  qed

  show "pred_option (Subx.wf_fundef (map_option funtype \<circ> Fubx_get F2)) (Fubx_get F2 f) "
  proof (cases "map_of (Finca_to_list F1) f")
    case None
    thus ?thesis
      using rel_map_of_F1_xs[of f, unfolded None]
      by (simp add: F2_def Subx.Fenv.from_list_correct)
  next
    case (Some fd1)
    show ?thesis
      using rel_map_of_F1_xs[of f, unfolded Some option_rel_Some1]
      unfolding funtype_F1_eq_funtype_F2 F2_def Subx.Fenv.from_list_correct
      by (auto intro: wf_compile_fundef)
  qed
qed

lemma compile_load:
  assumes
    compile_p1: "compile p1 = Some p2" and
    load: "Subx.load p2 s2"
  shows "\<exists>s1. Sinca.load p1 s1 \<and> match s1 s2"
proof -
  obtain F1 H main where p1_def: "p1 = Prog F1 H main"
    by (cases p1) simp
  then obtain F2 where
    compile_F1: "compile_env F1 = Some F2" and
    p2_def: "p2 = Prog F2 H main"
    using compile_p1
    by (auto simp: ap_option_eq_Some_conv)

  note rel_F1_F2 = rel_fundefs_compile_env[OF compile_F1]

  show ?thesis
    using assms(2) unfolding p2_def Subx.load_def
  proof (cases _ _ _ s2 rule: Global.load.cases)
    case (1 fd2)
    then obtain fd1 where
      F1_main: "Finca_get F1 main = Some fd1" and rel_fd1_fd2: "rel_fundef (=) norm_eq fd1 fd2"
      using rel_fundefs_Some2[OF rel_F1_F2]
      by auto

    let ?s1 = "State F1 H [allocate_frame main fd1 [] uninitialized]"

    show ?thesis
    proof (intro exI conjI)
      show "Sinca.load p1 ?s1"
        unfolding Sinca.load_def p1_def
        using 1 F1_main rel_fd1_fd2
        by (auto simp: rel_fundef_arities intro!: Global.load.intros dest: rel_fundef_body_length)
    next
      have "Subx.wf_state s2"
        unfolding 1
        using compile_F1
        by (auto intro!: Subx.wf_stateI intro: compile_env_wf_fundefs)
      then show "match ?s1 s2"
        using 1 rel_F1_F2 rel_fd1_fd2
        by (auto simp: allocate_frame_def rel_fundef_locals
            simp: rel_fundef_rel_fst_hd_bodies[OF rel_fd1_fd2 disjI2]
            intro!: match.intros rel_stacktraces.intros intro: Subx.sp_instrs.Nil)
    qed
  qed
qed

interpretation std_to_inca_compiler:
  compiler Sinca.step Subx.step "final Finca_get Inca.IReturn" "final Fubx_get Ubx.IReturn"
    Sinca.load Subx.load
    "\<lambda>_ _. False" "\<lambda>_. match" compile
using compile_load
  by unfold_locales auto

end

end