theory Simulation_Graphs_TA
  imports Simulation_Graphs DBM_Zone_Semantics Approx_Beta
begin

section \<open>Instantiation of Simulation Locales\<close>

inductive step_trans ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) cval \<Rightarrow> (('c, 't) cconstraint \<times> 'a \<times> 'c list)
  \<Rightarrow> 's \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile>\<^sub>t \<langle>_, _\<rangle> \<rightarrow>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  "\<lbrakk>A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'; u \<turnstile> g; u' \<turnstile> inv_of A l'; u' = [r \<rightarrow> 0]u\<rbrakk>
  \<Longrightarrow> (A \<turnstile>\<^sub>t \<langle>l, u\<rangle> \<rightarrow>\<^bsub>(g,a,r)\<^esub> \<langle>l', u'\<rangle>)"

inductive step_trans' ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) cval \<Rightarrow> ('c, 't) cconstraint \<times> 'a \<times> 'c list
  \<Rightarrow> 's \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile>'' \<langle>_, _\<rangle> \<rightarrow>\<^bsup>_\<^esup> \<langle>_, _\<rangle>" [61,61,61,61] 61)
where
  step': "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l', u'\<rangle> \<Longrightarrow> A \<turnstile>\<^sub>t \<langle>l', u'\<rangle> \<rightarrow>\<^bsub>t\<^esub> \<langle>l'', u''\<rangle> \<Longrightarrow> A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>\<^bsup>t\<^esup> \<langle>l'', u''\<rangle>"

inductive step_trans_z ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) zone
  \<Rightarrow> (('c, 't) cconstraint \<times> 'a \<times> 'c list) action \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>\<^bsup>_\<^esup> \<langle>_, _\<rangle>" [61,61,61,61] 61)
where
  step_trans_t_z:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l, Z\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}\<rangle>" |
  step_trans_a_z:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>(g,a,r)\<^esup> \<langle>l', zone_set (Z \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}\<rangle>"
  if "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'"

inductive step_trans_z' ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, ('t::time)) zone \<Rightarrow> (('c, 't) cconstraint \<times> 'a \<times> 'c list)
  \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> bool"
("_ \<turnstile>'' \<langle>_, _\<rangle> \<leadsto>\<^bsup>_\<^esup> \<langle>_, _\<rangle>" [61,61,61,61] 61)
where
  step_trans_z':
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l, Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, Z'\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>t\<^esup> \<langle>l', Z''\<rangle> \<Longrightarrow> A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z''\<rangle>"

lemmas [intro] =
  step_trans.intros
  step_trans'.intros
  step_trans_z.intros
  step_trans_z'.intros

context
  notes [elim!]  =
    step.cases step_t.cases
    step_trans.cases step_trans'.cases step_trans_z.cases step_trans_z'.cases
begin

lemma step_trans_t_z_sound:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l',Z'\<rangle> \<Longrightarrow> \<forall> u' \<in> Z'. \<exists> u \<in> Z. \<exists> d.  A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle>"
  by (auto 4 5 simp: zone_delay_def zone_set_def)

lemma step_trans_a_z_sound:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>t\<^esup> \<langle>l',Z'\<rangle> \<Longrightarrow> \<forall> u' \<in> Z'. \<exists> u \<in> Z. \<exists> d.  A \<turnstile>\<^sub>t \<langle>l, u\<rangle> \<rightarrow>\<^bsub>t\<^esub> \<langle>l',u'\<rangle>"
  by (auto 4 4 simp: zone_delay_def zone_set_def)

lemma step_trans_a_z_complete:
  "A \<turnstile>\<^sub>t \<langle>l, u\<rangle> \<rightarrow>\<^bsub>t\<^esub> \<langle>l', u'\<rangle> \<Longrightarrow> u \<in> Z \<Longrightarrow> \<exists> Z'. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>t\<^esup> \<langle>l', Z'\<rangle> \<and> u' \<in> Z'"
  by (auto 4 4 simp: zone_delay_def zone_set_def elim!: step_a.cases)

lemma step_trans_t_z_complete:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l', u'\<rangle> \<Longrightarrow> u \<in> Z \<Longrightarrow> \<exists> Z'. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l', Z'\<rangle> \<and> u' \<in> Z'"
  by (auto 4 4 simp: zone_delay_def zone_set_def elim!: step_a.cases)

lemma step_trans_t_z_iff:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l', Z'\<rangle> = A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l', Z'\<rangle>"
  by auto

lemma step_trans_a_z_exact:
  "u' \<in> Z'" if "A \<turnstile>\<^sub>t \<langle>l, u\<rangle> \<rightarrow>\<^bsub>t\<^esub> \<langle>l', u'\<rangle>" "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>t\<^esup> \<langle>l', Z'\<rangle>" "u \<in> Z"
  using that by (auto 4 4 simp: zone_delay_def zone_set_def)

lemma step_trans_t_z_exact:
  "u' \<in> Z'" if "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l', u'\<rangle>" "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l', Z'\<rangle>" "u \<in> Z"
  using that by (auto simp: zone_delay_def)

lemma step_trans_z'_exact:
  "u' \<in> Z'" if "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>\<^bsup>t\<^esup> \<langle>l', u'\<rangle>" "A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z'\<rangle>" "u \<in> Z"
  using that by (auto 4 4 simp: zone_delay_def zone_set_def)

lemma step_trans_z_step_z_action:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l',Z'\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>(g,a,r)\<^esup> \<langle>l', Z'\<rangle>"
  using that by auto

lemma step_trans_z_step_z:
  "\<exists> a. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l',Z'\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z'\<rangle>"
  using that by auto

lemma step_z_step_trans_z_action:
  "\<exists> g r. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>(g,a,r)\<^esup> \<langle>l', Z'\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l',Z'\<rangle>"
  using that by (auto 4 4)

lemma step_z_step_trans_z:
  "\<exists> t. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z'\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l',Z'\<rangle>"
  using that by cases auto

end (* Automation *)

lemma step_z'_step_trans_z':
  "\<exists> t. A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z''\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', Z''\<rangle>"
  using that unfolding step_z'_def
  by (auto dest!: step_z_step_trans_z_action simp: step_trans_t_z_iff[symmetric])

lemma step_trans_z'_step_z':
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', Z''\<rangle>" if "A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z''\<rangle>"
  using that unfolding step_z'_def
  by (auto elim!: step_trans_z'.cases dest!: step_trans_z_step_z_action simp: step_trans_t_z_iff)

lemma step_trans_z_determ:
  "Z1 = Z2" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z1\<rangle>" "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z2\<rangle>"
  using that by (auto elim!: step_trans_z.cases)

lemma step_trans_z'_determ:
  "Z1 = Z2" if "A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z1\<rangle>" "A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z2\<rangle>"
  using that by (auto elim!: step_trans_z'.cases step_trans_z.cases)

lemma (in Alpha_defs) step_trans_z_V: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<subseteq> V"
  by (induction rule: step_trans_z.induct; blast intro!: reset_V le_infI1 up_V)

subsection \<open>Additional Lemmas on Regions\<close>

context AlphaClosure
begin

inductive step_trans_r ::
  "('a, 'c, t, 's) ta \<Rightarrow> _ \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> (('c, t) cconstraint \<times> 'a \<times> 'c list) action
  \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> bool"
("_,_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>\<^bsup>_\<^esup> \<langle>_, _\<rangle>" [61,61,61,61,61] 61)
where
  step_trans_t_r:
  "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l,R'\<rangle>" if
  "valid_abstraction A X (\<lambda> x. real o k x)" "R \<in> \<R> l" "R' \<in> Succ (\<R> l) R" "R' \<subseteq> \<lbrace>inv_of A l\<rbrace>" |
  step_trans_a_r:
  "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>(g,a,r)\<^esup> \<langle>l', R'\<rangle>" if
  "valid_abstraction A X (\<lambda> x. real o k x)" "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'" "R \<in> \<R> l"
  "R \<subseteq> \<lbrace>g\<rbrace>" "region_set' R r 0 \<subseteq> R'" "R' \<subseteq> \<lbrace>inv_of A l'\<rbrace>" "R' \<in> \<R> l'"

lemmas [intro] = step_trans_r.intros

lemma step_trans_t_r_iff[simp]:
  "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l',R'\<rangle> = A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l',R'\<rangle>"
  by (auto elim!: step_trans_r.cases)

lemma step_trans_r_step_r_action:
  "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l',R'\<rangle>" if "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>(g,a,r)\<^esup> \<langle>l',R'\<rangle>"
  using that by (auto elim: step_trans_r.cases)

lemma step_r_step_trans_r_action:
  "\<exists> g r. A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>(g,a,r)\<^esup> \<langle>l',R'\<rangle>" if "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l',R'\<rangle>"
  using that by (auto elim: step_trans_r.cases)

inductive step_trans_r' ::
  "('a, 'c, t, 's) ta \<Rightarrow> _ \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> ('c, t) cconstraint \<times> 'a \<times> 'c list
  \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> bool"
("_,_ \<turnstile>'' \<langle>_, _\<rangle> \<leadsto>\<^bsup>_\<^esup> \<langle>_, _\<rangle>" [61,61,61,61,61] 61)
where
  "A,\<R> \<turnstile>' \<langle>l,R\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l',R''\<rangle>" if "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l,R'\<rangle>" "A,\<R> \<turnstile> \<langle>l,R'\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>t\<^esup> \<langle>l', R''\<rangle>"

lemma step_trans_r'_step_r':
  "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^sub>a \<langle>l',R'\<rangle>" if "A,\<R> \<turnstile>' \<langle>l,R\<rangle> \<leadsto>\<^bsup>(g,a,r)\<^esup> \<langle>l',R'\<rangle>"
  using that by cases (auto dest: step_trans_r_step_r_action intro!: step_r'.intros)

lemma step_r'_step_trans_r':
  "\<exists> g r. A,\<R> \<turnstile>' \<langle>l,R\<rangle> \<leadsto>\<^bsup>(g,a,r)\<^esup> \<langle>l',R'\<rangle>" if "A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^sub>a \<langle>l',R'\<rangle>"
  using that by cases (auto dest: step_r_step_trans_r_action intro!: step_trans_r'.intros)

lemma step_trans_a_r_sound:
  assumes "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>a\<^esup> \<langle>l',R'\<rangle>"
  shows "\<forall> u \<in> R. \<exists> u' \<in> R'. A \<turnstile>\<^sub>t \<langle>l, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l',u'\<rangle>"
using assms proof cases
  case A: (step_trans_a_r g a r)
  show ?thesis
  unfolding A(1) proof
    fix u assume "u \<in> R"
    from \<open>u \<in> R\<close> A have "u \<turnstile> g" "[r\<rightarrow>0]u \<turnstile> inv_of A l'" "[r\<rightarrow>0]u \<in> R'"
      unfolding region_set'_def ccval_def by auto
    with A show "\<exists>u'\<in>R'. A \<turnstile>\<^sub>t \<langle>l, u\<rangle> \<rightarrow>\<^bsub>(g,a,r)\<^esub> \<langle>l',u'\<rangle>"
      by auto
  qed
qed

lemma step_trans_r'_sound:
  assumes "A,\<R> \<turnstile>' \<langle>l, R\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', R'\<rangle>"
  shows "\<forall>u\<in>R. \<exists>u'\<in>R'. A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>\<^bsup>t\<^esup> \<langle>l', u'\<rangle>"
  using assms by cases (auto 6 0 dest!: step_trans_a_r_sound step_t_r_sound)

end (* Alpha Closure *)

context AlphaClosure
begin

context
  fixes l l' :: 's and A :: "('a, 'c, t, 's) ta"
  assumes valid_abstraction: "valid_abstraction A X k"
begin

interpretation alpha: AlphaClosure_global _ "k l" "\<R> l" by standard (rule finite)

interpretation alpha': AlphaClosure_global _ "k l'" "\<R> l'" by standard (rule finite)
lemma [simp]: "alpha'.cla = cla l'" unfolding alpha'.cla_def cla_def ..

lemma regions_poststable1:
  assumes
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsup>a\<^esup> \<langle>l',Z'\<rangle>" "Z \<subseteq> V" "R' \<in> \<R> l'" "R' \<inter> Z' \<noteq> {}"
  shows "\<exists> R \<in> \<R> l. A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsup>a\<^esup> \<langle>l',R'\<rangle> \<and> R \<inter> Z \<noteq> {}"
using assms proof (induction A \<equiv> A l \<equiv> l _ _ l' \<equiv> l' _rule: step_trans_z.induct)
  case A: (step_trans_t_z Z)
  from \<open>R' \<inter> (Z\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}) \<noteq> {}\<close> obtain u d where u:
    "u \<in> Z" "u \<oplus> d \<in> R'" "u \<oplus> d \<turnstile> inv_of A l" "0 \<le> d"
    unfolding zone_delay_def by blast+
  with alpha.closure_subs[OF A(2)] obtain R where R1: "u \<in> R" "R \<in> \<R> l"
    by (simp add: cla_def) blast
  from \<open>Z \<subseteq> V\<close> \<open>u \<in> Z\<close> have "\<forall>x\<in>X. 0 \<le> u x" unfolding V_def by fastforce
  from region_cover'[OF this] have R: "[u]\<^sub>l \<in> \<R> l" "u \<in> [u]\<^sub>l" by auto
  from SuccI2[OF \<R>_def' this(2,1) \<open>0 \<le> d\<close> HOL.refl] u(2) have v'1:
    "[u \<oplus> d]\<^sub>l \<in> Succ (\<R> l) ([u]\<^sub>l)" "[u \<oplus> d]\<^sub>l \<in> \<R> l"
    by auto
  from alpha.regions_closed'_spec[OF R(1,2) \<open>0 \<le> d\<close>] have v'2: "u \<oplus> d \<in> [u \<oplus> d]\<^sub>l" by simp
  from valid_abstraction have
    "\<forall>(x, m)\<in>clkp_set A l. m \<le> real (k l x) \<and> x \<in> X \<and> m \<in> \<nat>"
    by (auto elim!: valid_abstraction.cases)
  then have
    "\<forall>(x, m)\<in>collect_clock_pairs (inv_of A l). m \<le> real (k l x) \<and> x \<in> X \<and> m \<in> \<nat>"
    unfolding clkp_set_def collect_clki_def inv_of_def by fastforce
  from ccompatible[OF this, folded \<R>_def'] v'1(2) v'2 u(2,3) have
    "[u \<oplus> d]\<^sub>l \<subseteq> \<lbrace>inv_of A l\<rbrace>"
    unfolding ccompatible_def ccval_def by auto
  from
    alpha.valid_regions_distinct_spec[OF v'1(2) _ v'2 \<open>u \<oplus> d \<in> R'\<close>] \<open>R' \<in> _\<close> \<open>l = l'\<close>
    alpha.region_unique_spec[OF R1]
  have "[u \<oplus> d]\<^sub>l = R'" "[u]\<^sub>l = R" by auto
  from valid_abstraction \<open>R \<in> _\<close> \<open>_ \<in> Succ (\<R> l) _\<close> \<open>_ \<subseteq> \<lbrace>inv_of A l\<rbrace>\<close> have
    "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l, R'\<rangle>"
    by (auto simp: comp_def \<open>[u \<oplus> d]\<^sub>l = R'\<close> \<open>_ = R\<close>)
  with \<open>l = l'\<close> \<open>R \<in> _\<close> \<open>u \<in> R\<close> \<open>u \<in> Z\<close> show ?case by - (rule bexI[where x = R]; auto)
next
  case A: (step_trans_a_z g a r Z)
  from A(4) obtain u v' where
    "u \<in> Z" and v': "v' = [r\<rightarrow>0]u" "u \<turnstile> g" "v' \<turnstile> inv_of A l'" "v' \<in> R'"
    unfolding zone_set_def by blast
  from \<open>u \<in> Z\<close> alpha.closure_subs[OF A(2)] A(1) obtain u' R where u':
    "u \<in> R" "u' \<in> R" "R \<in> \<R> l"
    by (simp add: cla_def) blast
  then have "\<forall>x\<in>X. 0 \<le> u x" unfolding \<R>_def by fastforce
  from region_cover'[OF this] have "[u]\<^sub>l \<in> \<R> l" "u \<in> [u]\<^sub>l" by auto
  have *:
    "[u]\<^sub>l \<subseteq> \<lbrace>g\<rbrace>" "region_set' ([u]\<^sub>l) r 0 \<subseteq> [[r\<rightarrow>0]u]\<^sub>l'"
    "[[r\<rightarrow>0]u]\<^sub>l' \<in> \<R> l'" "[[r\<rightarrow>0]u]\<^sub>l' \<subseteq> \<lbrace>inv_of A l'\<rbrace>"
  proof -
    from valid_abstraction have "collect_clkvt (trans_of A) \<subseteq> X"
      "\<forall> l g a r l' c. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<and> c \<notin> set r \<longrightarrow> k l' c \<le> k l c"
      by (auto elim: valid_abstraction.cases)
    with A(1) have "set r \<subseteq> X" "\<forall>y. y \<notin> set r \<longrightarrow> k l' y \<le> k l y"
      unfolding collect_clkvt_def by (auto 4 8)
    with
      region_set_subs[
        of _ X "k l" _ 0, where k' = "k l'", folded \<R>_def, OF \<open>[u]\<^sub>l \<in> \<R> l\<close> \<open>u \<in> [u]\<^sub>l\<close> finite
        ]
    show "region_set' ([u]\<^sub>l) r 0 \<subseteq> [[r\<rightarrow>0]u]\<^sub>l'" "[[r\<rightarrow>0]u]\<^sub>l' \<in> \<R> l'" by auto
    from valid_abstraction have *:
      "\<forall>l. \<forall>(x, m)\<in>clkp_set A l. m \<le> real (k l x) \<and> x \<in> X \<and> m \<in> \<nat>"
      by (fastforce elim: valid_abstraction.cases)+
    with A(1) have "\<forall>(x, m)\<in>collect_clock_pairs g. m \<le> real (k l x) \<and> x \<in> X \<and> m \<in> \<nat>"
      unfolding clkp_set_def collect_clkt_def by fastforce
    from \<open>u \<in> [u]\<^sub>l\<close> \<open>[u]\<^sub>l \<in> \<R> l\<close> ccompatible[OF this, folded \<R>_def] \<open>u \<turnstile> g\<close> show "[u]\<^sub>l \<subseteq> \<lbrace>g\<rbrace>"
      unfolding ccompatible_def ccval_def by blast
    have **: "[r\<rightarrow>0]u \<in> [[r\<rightarrow>0]u]\<^sub>l'"
      using \<open>R' \<in> \<R> l'\<close> \<open>v' \<in> R'\<close> alpha'.region_unique_spec v'(1) by blast
    from * have
      "\<forall>(x, m)\<in>collect_clock_pairs (inv_of A l'). m \<le> real (k l' x) \<and> x \<in> X \<and> m \<in> \<nat>"
      unfolding inv_of_def clkp_set_def collect_clki_def by fastforce
    from ** \<open>[[r\<rightarrow>0]u]\<^sub>l' \<in> \<R> l'\<close> ccompatible[OF this, folded \<R>_def] \<open>v' \<turnstile> _\<close> show
      "[[r\<rightarrow>0]u]\<^sub>l' \<subseteq> \<lbrace>inv_of A l'\<rbrace>"
      unfolding ccompatible_def ccval_def \<open>v' = _\<close> by blast
  qed
  from * \<open>v' = _\<close> \<open>u \<in> [u]\<^sub>l\<close> have "v' \<in> [[r\<rightarrow>0]u]\<^sub>l'" unfolding region_set'_def by auto
  from alpha'.valid_regions_distinct_spec[OF *(3) \<open>R' \<in> \<R> l'\<close> \<open>v' \<in> [[r\<rightarrow>0]u]\<^sub>l'\<close> \<open>v' \<in> R'\<close>]
  have "[[r\<rightarrow>0]u]\<^sub>l' = R'" .
  from alpha.region_unique_spec[OF u'(1,3)] have "[u]\<^sub>l = R" by auto
  from A valid_abstraction \<open>R \<in> _\<close> * have "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>(g,a,r)\<^esup> \<langle>l', R'\<rangle>"
    by (auto simp: comp_def \<open>_ = R'\<close> \<open>_ = R\<close>)
  with \<open>R \<in> _\<close> \<open>u \<in> R\<close> \<open>u \<in> Z\<close> show ?case by - (rule bexI[where x = R]; auto)
qed

lemma regions_poststable':
  assumes
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l',Z'\<rangle>" "Z \<subseteq> V" "R' \<in> \<R> l'" "R' \<inter> Z' \<noteq> {}"
  shows "\<exists> R \<in> \<R> l. A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l',R'\<rangle> \<and> R \<inter> Z \<noteq> {}"
  using assms
  by (cases a)
     (auto dest!: regions_poststable1 dest: step_trans_r_step_r_action step_z_step_trans_z_action
           simp: step_trans_t_z_iff[symmetric]
     )

end (* End of context for fixed locations *)

lemma regions_poststable2:
  assumes valid_abstraction: "valid_abstraction A X k"
  and prems: "A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>a\<^esup> \<langle>l',Z'\<rangle>" "Z \<subseteq> V" "R' \<in> \<R> l'" "R' \<inter> Z' \<noteq> {}"
    shows "\<exists> R \<in> \<R> l. A,\<R> \<turnstile>' \<langle>l,R\<rangle> \<leadsto>\<^bsup>a\<^esup> \<langle>l',R'\<rangle> \<and> R \<inter> Z \<noteq> {}"
using prems(1) proof (cases)
  case steps: (step_trans_z' Z1)
  with prems have "Z1 \<subseteq> V"
    by (blast dest: step_trans_z_V)
  from regions_poststable1[OF valid_abstraction steps(2) \<open>Z1 \<subseteq> V\<close> prems(3,4)] obtain R1 where R1:
    "R1 \<in> \<R> l" "A,\<R> \<turnstile> \<langle>l, R1\<rangle> \<leadsto>\<^bsup>\<upharpoonleft>a\<^esup> \<langle>l', R'\<rangle>" "R1 \<inter> Z1 \<noteq> {}"
    by auto
  from regions_poststable1[OF valid_abstraction steps(1) \<open>Z \<subseteq> V\<close> R1(1,3)] obtain R where
    "R\<in>\<R> l" "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^bsup>\<tau>\<^esup> \<langle>l, R1\<rangle>" "R \<inter> Z \<noteq> {}"
    by auto
  with R1(2) show ?thesis
    by (auto intro: step_trans_r'.intros)
qed

text \<open>
  Poststability of Closures:
  For every transition in the zone graph and each region in the closure of the resulting zone,
  there exists a similar transition in the region graph.
\<close>
lemma regions_poststable:
  assumes valid_abstraction: "valid_abstraction A X k"
  and A:
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l',Z'\<rangle>" "A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l'',Z''\<rangle>"
    "Z \<subseteq> V" "R'' \<in> \<R> l''" "R'' \<inter> Z'' \<noteq> {}"
  shows "\<exists> R \<in> \<R> l. A,\<R> \<turnstile> \<langle>l,R\<rangle> \<leadsto>\<^sub>a \<langle>l'',R''\<rangle> \<and> R \<inter> Z \<noteq> {}"
proof -
  from A(1) \<open>Z \<subseteq> V\<close> have "Z' \<subseteq> V" by (rule step_z_V)
  from A(1) have [simp]: "l' = l" by auto
  from regions_poststable'[OF valid_abstraction A(2) \<open>Z' \<subseteq> V\<close> \<open>R'' \<in> _\<close> \<open>R'' \<inter> Z'' \<noteq> {}\<close>] obtain R'
    where R': "R'\<in>\<R> l'" "A,\<R> \<turnstile> \<langle>l', R'\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l'', R''\<rangle>" "R' \<inter> Z' \<noteq> {}"
    by auto
  from regions_poststable'[OF valid_abstraction A(1) \<open>Z \<subseteq> V\<close> R'(1,3)] obtain R where
    "R \<in> \<R> l" "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l, R'\<rangle>" "R \<inter> Z \<noteq> {}"
    by auto
  with R'(2) show ?thesis by - (rule bexI[where x = "R"]; auto intro: step_r'.intros)
qed

lemma step_t_r_loc:
  "l' = l" if "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l', R'\<rangle>"
  using that by cases auto

lemma \<R>_V:
  "u \<in> V" if "R \<in> \<R> l" "u \<in> R"
  using that unfolding \<R>_def V_def by auto

lemma step_r'_complete:
  assumes "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>" "valid_abstraction A X (\<lambda> x. real o k x)" "u \<in> V"
  shows "\<exists> a R'. u' \<in> R' \<and> A,\<R> \<turnstile> \<langle>l, [u]\<^sub>l\<rangle> \<leadsto>\<^sub>a \<langle>l',R'\<rangle>"
  using assms
  apply cases
  apply (drule step_t_r_complete, (rule assms; fail), simp add: V_def)
  apply clarify
  apply (frule step_a_r_complete)
  by (auto dest: step_t_r_loc simp: \<R>_def simp: region_unique intro!: step_r'.intros)

lemma step_r_\<R>:
  "R' \<in> \<R> l'" if "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', R'\<rangle>"
  using that by (auto elim: step_r.cases)

lemma step_r'_\<R>:
  "R' \<in> \<R> l'" if "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^sub>a \<langle>l', R'\<rangle>"
  using that by (auto intro: step_r_\<R> elim: step_r'.cases)

end (* End of Alpha Closure *)

context Regions
begin

lemma closure_parts_mono:
  "{R \<in> \<R> l. R \<inter> Z \<noteq> {}} \<subseteq> {R \<in> \<R> l. R \<inter> Z' \<noteq> {}}" if "Closure\<^sub>\<alpha>\<^sub>,\<^sub>l Z \<subseteq> Closure\<^sub>\<alpha>\<^sub>,\<^sub>l Z'"
proof (clarify, goal_cases)
  case prems: (1 R)
  with that have "R \<subseteq> Closure\<^sub>\<alpha>\<^sub>,\<^sub>l Z'"
    unfolding cla_def by auto
  from \<open>_ \<noteq> {}\<close> obtain u where "u \<in> R" "u \<in> Z" by auto
  with \<open>R \<subseteq> _\<close> obtain R' where "R' \<in> \<R> l" "u \<in> R'" "R' \<inter> Z' \<noteq> {}" unfolding cla_def by force
  from \<R>_regions_distinct[OF \<R>_def' this(1,2) \<open>R \<in> _\<close>] \<open>u \<in> R\<close> have "R = R'" by auto
  with \<open>R' \<inter> Z' \<noteq> {}\<close> \<open>R \<inter> Z' = {}\<close> show ?case by simp
qed

lemma closure_parts_id:
  "{R \<in> \<R> l. R \<inter> Z \<noteq> {}} = {R \<in> \<R> l. R \<inter> Z' \<noteq> {}}" if
  "Closure\<^sub>\<alpha>\<^sub>,\<^sub>l Z = Closure\<^sub>\<alpha>\<^sub>,\<^sub>l Z'"
  using closure_parts_mono that by blast

paragraph \<open>More lemmas on regions\<close>

(* XXX All of these should be considered for moving into the locales for global sets of regions *)
context
  fixes l' :: 's
begin

interpretation regions: Regions_global _ _ _ "k l'"
  by standard (rule finite clock_numbering not_in_X non_empty)+

context
  fixes A :: "('a, 'c, t, 's) ta"
  assumes valid_abstraction: "valid_abstraction A X k"
begin

lemmas regions_poststable = regions_poststable[OF valid_abstraction]

lemma clkp_set_clkp_set1:
  "\<exists> l. (c, x) \<in> clkp_set A l" if "(c, x) \<in> Timed_Automata.clkp_set A"
  using that
  unfolding Timed_Automata.clkp_set_def Closure.clkp_set_def
  unfolding Timed_Automata.collect_clki_def Closure.collect_clki_def
  unfolding Timed_Automata.collect_clkt_def Closure.collect_clkt_def
  by fastforce

lemma clkp_set_clkp_set2:
  "(c, x) \<in> Timed_Automata.clkp_set A" if "(c, x) \<in> clkp_set A l" for l
  using that
  unfolding Timed_Automata.clkp_set_def Closure.clkp_set_def
  unfolding Timed_Automata.collect_clki_def Closure.collect_clki_def
  unfolding Timed_Automata.collect_clkt_def Closure.collect_clkt_def
  by fastforce

lemma clock_numbering_le: "\<forall>c\<in>clk_set A. v c \<le> n"
proof
  fix c assume "c \<in> clk_set A"
  then have "c \<in> X"
  proof (safe, clarsimp, goal_cases)
    case (1 x)
    then obtain l where "(c, x) \<in> clkp_set A l" by (auto dest: clkp_set_clkp_set1)
    with valid_abstraction show "c \<in> X" by (auto elim!: valid_abstraction.cases)
  next
    case 2
    with valid_abstraction show "c \<in> X" by (auto elim!: valid_abstraction.cases)
  qed
  with clock_numbering show "v c \<le> n" by auto
qed

lemma beta_alpha_step:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<alpha>(a)\<^esub> \<langle>l', Closure\<^sub>\<alpha>\<^sub>,\<^sub>l' Z'\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<beta>(a)\<^esub> \<langle>l', Z'\<rangle>" "Z \<in> V'"
proof -
  from that obtain Z1' where Z1': "Z' = Approx\<^sub>\<beta> l' Z1'" "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z1'\<rangle>"
    by (clarsimp elim!: step_z_beta.cases)
  with \<open>Z \<in> V'\<close> have "Z1' \<in> V'"
    using valid_abstraction clock_numbering_le by (auto intro: step_z_V')
  let ?alpha = "Closure\<^sub>\<alpha>\<^sub>,\<^sub>l' Z1'" and ?beta = "Closure\<^sub>\<alpha>\<^sub>,\<^sub>l' (Approx\<^sub>\<beta> l' Z1')"
  have "?beta \<subseteq> ?alpha"
    using regions.approx_\<beta>_closure_\<alpha>'[OF \<open>Z1' \<in> V'\<close>] regions.alpha_interp.closure_involutive
    by (auto 4 3 dest: regions.alpha_interp.cla_mono)
  moreover have "?alpha \<subseteq> ?beta"
    by (intro regions.alpha_interp.cla_mono[simplified] regions.beta_interp.apx_subset)
  ultimately have "?beta = ?alpha" ..
  with Z1' show ?thesis by auto
qed

lemma beta_alpha_region_step:
  "\<exists> a. \<exists> R \<in> \<R> l. R \<inter> Z \<noteq> {} \<and> A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^sub>a \<langle>l', R'\<rangle>" if
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle>" "Z \<in> V'" "R' \<in> \<R> l'" "R' \<inter> Z' \<noteq> {}"
proof -
  from that(1) obtain l'' a Z'' where steps:
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l'', Z''\<rangle>" "A \<turnstile> \<langle>l'', Z''\<rangle> \<leadsto>\<^bsub>\<beta>(\<upharpoonleft>a)\<^esub> \<langle>l', Z'\<rangle>"
    unfolding step_z_beta'_def by metis
  with \<open>Z \<in> V'\<close> steps(1) have "Z'' \<in> V'"
    using valid_abstraction clock_numbering_le by (blast intro: step_z_V')
  from beta_alpha_step[OF steps(2) this] have "A \<turnstile> \<langle>l'', Z''\<rangle> \<leadsto>\<^bsub>\<alpha>\<upharpoonleft>a\<^esub> \<langle>l', Closure\<^sub>\<alpha>\<^sub>,\<^sub>l'(Z')\<rangle>" .
  from step_z_alpha.cases[OF this] obtain Z1 where Z1:
    "A \<turnstile> \<langle>l'', Z''\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l', Z1\<rangle>" "Closure\<^sub>\<alpha>\<^sub>,\<^sub>l'(Z') = Closure\<^sub>\<alpha>\<^sub>,\<^sub>l'(Z1)"
    by metis
  from closure_parts_id[OF this(2)] that(3,4) have "R' \<inter> Z1 \<noteq> {}" by blast
  from regions_poststable[OF steps(1) Z1(1) _ \<open>R' \<in> _\<close> this] \<open>Z \<in> V'\<close> show ?thesis
    by (auto dest: V'_V)
qed

lemmas step_z_beta'_V' = step_z_beta'_V'[OF valid_abstraction clock_numbering_le]

lemma step_trans_z'_closure_subs:
  assumes
    "A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z'\<rangle>" "Z \<subseteq> V" "\<forall> R \<in> \<R> l. R \<inter> Z \<noteq> {} \<longrightarrow> R \<inter> W \<noteq> {}"
  shows
    "\<exists> W'. A \<turnstile>' \<langle>l, W\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', W'\<rangle> \<and> (\<forall> R \<in> \<R> l'. R \<inter> Z' \<noteq> {} \<longrightarrow> R \<inter> W' \<noteq> {})"
proof -
  from assms(1) obtain W' where step: "A \<turnstile>' \<langle>l, W\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', W'\<rangle>"
    by (auto elim!: step_trans_z.cases step_trans_z'.cases)
  have "R' \<inter> W' \<noteq> {}" if "R' \<in> \<R> l'" "R' \<inter> Z' \<noteq> {}" for R'
  proof -
    from regions_poststable2[OF valid_abstraction assms(1) _ that] \<open>Z \<subseteq> V\<close> obtain R where R:
      "R\<in>\<R> l" "A,\<R> \<turnstile>' \<langle>l, R\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', R'\<rangle>" "R \<inter> Z \<noteq> {}"
      by auto
    with assms(3) obtain u where "u \<in> R" "u \<in> W"
      by auto
    with step_trans_r'_sound[OF R(2)] obtain u' where "u' \<in> R'" "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>\<^bsup>t\<^esup> \<langle>l', u'\<rangle>"
      by auto
    with step_trans_z'_exact[OF this(2) step \<open>u \<in> W\<close>] show ?thesis
      by auto
  qed
  with step show ?thesis
    by auto
qed

lemma step_trans_z'_closure_eq:
  assumes
    "A \<turnstile>' \<langle>l, Z\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', Z'\<rangle>" "Z \<subseteq> V" "W \<subseteq> V" "\<forall> R \<in> \<R> l. R \<inter> Z \<noteq> {} \<longleftrightarrow> R \<inter> W \<noteq> {}"
  shows
    "\<exists> W'. A \<turnstile>' \<langle>l, W\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', W'\<rangle> \<and> (\<forall> R \<in> \<R> l'. R \<inter> Z' \<noteq> {} \<longleftrightarrow> R \<inter> W' \<noteq> {})"
proof -
  from assms(4) have *:
    "\<forall> R \<in> \<R> l. R \<inter> Z \<noteq> {} \<longrightarrow> R \<inter> W \<noteq> {}" "\<forall> R \<in> \<R> l. R \<inter> W \<noteq> {} \<longrightarrow> R \<inter> Z \<noteq> {}"
    by auto
  from step_trans_z'_closure_subs[OF assms(1,2) *(1)] obtain W' where W':
    "A \<turnstile>' \<langle>l, W\<rangle> \<leadsto>\<^bsup>t\<^esup> \<langle>l', W'\<rangle>" "(\<forall>R\<in>\<R> l'. R \<inter> Z' \<noteq> {} \<longrightarrow> R \<inter> W' \<noteq> {})"
    by auto
  with step_trans_z'_closure_subs[OF W'(1) \<open>W \<subseteq> V\<close> *(2)] assms(1) show ?thesis
    by (fastforce dest: step_trans_z'_determ)
qed

lemma step_z'_closure_subs:
  assumes
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', Z'\<rangle>" "Z \<subseteq> V" "\<forall> R \<in> \<R> l. R \<inter> Z \<noteq> {} \<longrightarrow> R \<inter> W \<noteq> {}"
  shows
    "\<exists> W'. A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l', W'\<rangle> \<and> (\<forall> R \<in> \<R> l'. R \<inter> Z' \<noteq> {} \<longrightarrow> R \<inter> W' \<noteq> {})"
  using assms(1)
  by (auto
      dest: step_trans_z'_step_z'
      dest!: step_z'_step_trans_z' step_trans_z'_closure_subs[OF _ assms(2,3)]
     )

end (* Context for automaton *)

lemma apx_finite:
  "finite {Approx\<^sub>\<beta> l' Z | Z. Z \<subseteq> V}" (is "finite ?S")
proof -
  have "finite regions.\<R>\<^sub>\<beta>"
    by (simp add: regions.beta_interp.finite_\<R>)
  then have "finite {S. S \<subseteq> regions.\<R>\<^sub>\<beta>}"
    by auto
  then have "finite {\<Union> S | S. S \<subseteq> regions.\<R>\<^sub>\<beta>}"
    by auto
  moreover have "?S \<subseteq> {\<Union> S | S. S \<subseteq> regions.\<R>\<^sub>\<beta>}"
    by (auto dest!: regions.beta_interp.apx_in)
  ultimately show ?thesis by (rule finite_subset[rotated])
qed

lemmas apx_subset = regions.beta_interp.apx_subset

lemma step_z_beta'_empty:
  "Z' = {}" if "A \<turnstile> \<langle>l, {}\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle>"
  using that
  by (auto
      elim!: step_z.cases
      simp: step_z_beta'_def regions.beta_interp.apx_empty zone_delay_def zone_set_def
     )

end (* End of context for fixed location *)

lemma step_z_beta'_complete:
  assumes "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>" "u \<in> Z" "Z \<subseteq> V"
  shows "\<exists> Z'. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle> \<and> u' \<in> Z'"
proof -
  from assms(1) obtain l'' u'' d a where steps:
    "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l'', u''\<rangle>" "A \<turnstile> \<langle>l'', u''\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l', u'\<rangle>"
    by (force elim!: step'.cases)
  then obtain Z'' where
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l'', Z''\<rangle>" "u'' \<in> Z''"
    by (meson \<open>u \<in> Z\<close> step_t_z_complete)
  moreover with steps(2) obtain Z' where
    "A \<turnstile> \<langle>l'', Z''\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l', Z'\<rangle>" "u' \<in> Z'"
    by (meson \<open>u'' \<in> Z''\<close> step_a_z_complete)
  ultimately show ?thesis
    unfolding step_z_beta'_def using \<open>Z \<subseteq> V\<close> apx_subset by blast
qed

end (* End of Regions *)

subsection \<open>Instantiation of Double Simulation\<close>

subsection \<open>Auxiliary Definitions\<close>

definition state_set :: "('a, 'c, 'time, 's) ta \<Rightarrow> 's set" where
  "state_set A \<equiv> fst ` (fst A) \<union> (snd o snd o snd o snd) ` (fst A)"

lemma finite_trans_of_finite_state_set:
  "finite (state_set A)" if "finite (trans_of A)"
  using that unfolding state_set_def trans_of_def by auto

lemma state_setI1:
  "l \<in> state_set A" if "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'"
  using that unfolding state_set_def trans_of_def image_def by (auto 4 4)

lemma state_setI2:
  "l' \<in> state_set A" if "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'"
  using that unfolding state_set_def trans_of_def image_def by (auto 4 4)

lemma (in AlphaClosure) step_r'_state_set:
  "l' \<in> state_set A" if "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto>\<^sub>a \<langle>l', R'\<rangle>"
  using that by (blast intro: state_setI2 elim: step_r'.cases)

lemma (in Regions) step_z_beta'_state_set2:
  "l' \<in> state_set A" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle>"
  using that unfolding step_z_beta'_def by (force simp: state_set_def trans_of_def)

subsection \<open>Instantiation\<close>

locale Regions_TA = Regions X _ _  k for X :: "'c set" and k :: "'s \<Rightarrow> 'c \<Rightarrow> nat" +
  fixes A :: "('a, 'c, t, 's) ta"
  assumes valid_abstraction: "valid_abstraction A X k"
    and finite_state_set: "finite (state_set A)"
begin

(* XXX Bundle this? *)
no_notation Regions_Beta.part ("[_]\<^sub>_" [61,61] 61)
notation part'' ("[_]\<^sub>_" [61,61] 61)

(* XXX Move *)
lemma step_z_beta'_state_set1:
  "l \<in> state_set A" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle>"
  using that unfolding step_z_beta'_def by (force simp: state_set_def trans_of_def)

sublocale sim: Double_Simulation_paired
  "\<lambda> (l, u) (l', u'). A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>"  \<comment> \<open>Concrete step relation\<close>
  "\<lambda> (l, Z) (l', Z'). \<exists> a. A,\<R> \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>a \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  \<comment> \<open>Step relation for the first abstraction layer\<close>
  "\<lambda> (l, R). l \<in> state_set A \<and> R \<in> \<R> l" \<comment> \<open>Valid states of the first abstraction layer\<close>
  "\<lambda> (l, Z) (l', Z'). A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  \<comment> \<open>Step relation for the second abstraction layer\<close>
  "\<lambda> (l, Z). l \<in> state_set A \<and> Z \<in> V' \<and> Z \<noteq> {}" \<comment> \<open>Valid states of the second abstraction layer\<close>
proof (standard, goal_cases)
  case (1 S T)
  then show ?case
    by (auto dest!: step_r'_sound)
next
  case prems: (2 R' l' Z' l Z)
  from prems(3) have "l \<in> state_set A"
    by (blast intro: step_z_beta'_state_set1)
  from prems show ?case
    unfolding Double_Simulation_paired_Defs.closure'_def
    by (blast dest: beta_alpha_region_step[OF valid_abstraction] step_z_beta'_state_set1)
next
  case prems: (3 l R R')
  then show ?case
    using \<R>_regions_distinct[OF \<R>_def'] by auto
next
  case 4
  have *: "finite (\<R> l)" for l
    unfolding \<R>_def by (intro finite_\<R> finite)
  have
    "{(l, R). l \<in> state_set A \<and> R \<in> \<R> l} = (\<Union> l \<in> state_set A. ((\<lambda> R. (l, R)) ` {R. R \<in> \<R> l}))"
    by auto
  also have "finite \<dots>"
    by (auto intro: finite_UN_I[OF finite_state_set] *)
  finally show ?case by auto
next
  case (5 l Z)
  then show ?case
    apply safe
    subgoal for u
      using region_cover'[of u l] by (auto dest!: V'_V, auto simp: V_def)
    done
qed

sublocale Graph_Defs
  "\<lambda> (l, Z) (l', Z'). A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}" .

lemmas step_z_beta'_V' = step_z_beta'_V'[OF valid_abstraction]

lemma step_r'_complete_spec:
  assumes "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>" "u \<in> V"
  shows "\<exists> a R'. u' \<in> R' \<and> A,\<R> \<turnstile> \<langle>l, [u]\<^sub>l\<rangle> \<leadsto>\<^sub>a \<langle>l',R'\<rangle>"
  using assms valid_abstraction by (auto simp: comp_def V_def intro!: step_r'_complete)

end (* Regions TA *)

subsection \<open>Büchi Runs\<close>

locale Regions_TA_Start_State = Regions_TA _ _ _ _ _ A for A :: "('a, 'c, t, 's) ta" +
  fixes l\<^sub>0 :: "'s" and Z\<^sub>0 :: "('c, t) zone"
  assumes start_state: "l\<^sub>0 \<in> state_set A" "Z\<^sub>0 \<in> V'" "Z\<^sub>0 \<noteq> {}"
begin

definition "a\<^sub>0 = from_R l\<^sub>0 Z\<^sub>0"

sublocale sim_complete': Double_Simulation_Finite_Complete_paired
  "\<lambda> (l, u) (l', u'). A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>"  \<comment> \<open>Concrete step relation\<close>
  "\<lambda> (l, Z) (l', Z'). \<exists> a. A,\<R> \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>a \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  \<comment> \<open>Step relation for the first abstraction layer\<close>
  "\<lambda> (l, R). l \<in> state_set A \<and> R \<in> \<R> l" \<comment> \<open>Valid states of the first abstraction layer\<close>
  "\<lambda> (l, Z) (l', Z'). A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  \<comment> \<open>Step relation for the second abstraction layer\<close>
  "\<lambda> (l, Z). l \<in> state_set A \<and> Z \<in> V' \<and> Z \<noteq> {}" \<comment> \<open>Valid states of the second abstraction layer\<close>
  l\<^sub>0 Z\<^sub>0
proof (standard, goal_cases)
  case (1 x y S)
  \<comment> \<open>Completeness\<close>
  then show ?case
    by (force dest: step_z_beta'_complete[rotated 2, OF V'_V])
next
  case 4
  \<comment> \<open>Finiteness\<close>
  (* XXX *)
  have *: "Z \<in> V'" if "A \<turnstile> \<langle>l\<^sub>0, Z\<^sub>0\<rangle> \<leadsto>\<^sub>\<beta>* \<langle>l, Z\<rangle>" for l Z
    using that start_state step_z_beta'_V' by (induction rule: rtranclp_induct2) blast+
  have "Z \<in> {Approx\<^sub>\<beta> l Z | Z. Z \<subseteq> V} \<or> (l, Z) = (l\<^sub>0, Z\<^sub>0)"
    if "reaches (l\<^sub>0, Z\<^sub>0) (l, Z)" for l Z
    using that proof (induction rule: rtranclp_induct2)
    case refl
    then show ?case
      by simp
  next
    case prems: (step l Z l' Z')
    from prems(1) have "A \<turnstile> \<langle>l\<^sub>0, Z\<^sub>0\<rangle> \<leadsto>\<^sub>\<beta>* \<langle>l, Z\<rangle>"
      by induction (auto intro: rtranclp_trans)
    then have "Z \<in> V'"
      by (rule *)
    with prems show ?case
      unfolding step_z_beta'_def using start_state(2) by (auto 0 1 dest!: V'_V elim!: step_z_V)
  qed
  then have "{(l, Z). reaches (l\<^sub>0, Z\<^sub>0) (l, Z) \<and> l \<in> state_set A \<and> Z \<in> V' \<and> Z \<noteq> {}}
    \<subseteq> {(l, Z) | l Z. l \<in> state_set A \<and> Z \<in> {Approx\<^sub>\<beta> l Z | Z. Z \<subseteq> V}} \<union> {(l\<^sub>0, Z\<^sub>0)}"
    by auto
  also have "finite \<dots>" (is "finite ?S")
  proof -
    have "?S = {(l\<^sub>0, Z\<^sub>0)} \<union> \<Union> ((\<lambda> l. (\<lambda> Z. (l, Z)) ` {Approx\<^sub>\<beta> l Z | Z. Z \<subseteq> V}) ` (state_set A))"
      by blast
    also have "finite \<dots>"
      by (blast intro: apx_finite finite_state_set)
    finally show ?thesis .
  qed
  finally show ?case
    by simp
next
  case prems: (2 a a')
  then show ?case
    by (auto intro: step_z_beta'_V' step_z_beta'_state_set2)
next
  case 3
  from start_state show ?case unfolding a\<^sub>0_def by (auto simp: from_R_fst)
qed

sublocale sim_complete_bisim': Double_Simulation_Finite_Complete_Bisim_Cover_paired
  "\<lambda> (l, u) (l', u'). A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>"  \<comment> \<open>Concrete step relation\<close>
  "\<lambda> (l, Z) (l', Z'). \<exists> a. A,\<R> \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>a \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  \<comment> \<open>Step relation for the first abstraction layer\<close>
  "\<lambda> (l, R). l \<in> state_set A \<and> R \<in> \<R> l" \<comment> \<open>Valid states of the first abstraction layer\<close>
  "\<lambda> (l, Z) (l', Z'). A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  \<comment> \<open>Step relation for the second abstraction layer\<close>
  "\<lambda> (l, Z). l \<in> state_set A \<and> Z \<in> V' \<and> Z \<noteq> {}" \<comment> \<open>Valid states of the second abstraction layer\<close>
  l\<^sub>0 Z\<^sub>0
proof (standard, goal_cases)
  case (1 l x l' y S)
  then show ?case
    apply clarify
    apply (drule step_r'_complete_spec, (auto intro: \<R>_V; fail))
    by (auto simp: \<R>_def region_unique)
next
  case (2 l S l' T)
  then show ?case
    by (auto simp add: step_r'_state_set step_r'_\<R>)
next
  case prems: (3 l Z u)
  then show ?case
    using region_cover'[of u l] by (auto dest!: V'_V simp: V_def)+
qed

subsection \<open>State Formulas\<close>

context
  fixes P :: "'s \<Rightarrow> bool" \<comment> \<open>The state property we want to check\<close>
begin

definition "\<phi> = P o fst"

paragraph \<open>State formulas are compatible with closures.\<close>

paragraph \<open>Runs satisfying a formula all the way long\<close>

interpretation G\<^sub>\<phi>: Graph_Start_Defs
  "\<lambda> (l, Z) (l', Z'). A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {} \<and> P l'" "(l\<^sub>0, Z\<^sub>0)" .

theorem Alw_ev_mc1:
  "(\<forall>x\<^sub>0\<in>a\<^sub>0. sim.sim.Alw_ev (Not \<circ> \<phi>) x\<^sub>0) \<longleftrightarrow> \<not> (P l\<^sub>0 \<and> (\<exists>a. G\<^sub>\<phi>.reachable a \<and> G\<^sub>\<phi>.reaches1 a a))"
  using sim_complete_bisim'.Alw_ev_mc1
  unfolding G\<^sub>\<phi>.reachable_def a\<^sub>0_def sim_complete_bisim'.\<psi>_def \<phi>_def
  by auto

end (* Context for State Formula *)

subsection \<open>Leads-To Properties\<close>

context
  fixes P Q :: "'s \<Rightarrow> bool" \<comment> \<open>The state properties we want to check\<close>
begin

definition "\<psi> = Q o fst"

interpretation G\<^sub>\<psi>: Graph_Defs
  "\<lambda> (l, Z) (l', Z'). A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<beta> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {} \<and> Q l'" .

theorem leadsto_mc1:
  "(\<forall>x\<^sub>0\<in>a\<^sub>0. sim.sim.leadsto (\<phi> P) (Not \<circ> \<psi>) x\<^sub>0) \<longleftrightarrow>
   (\<nexists>x. reaches (l\<^sub>0, Z\<^sub>0) x \<and> P (fst x) \<and> Q (fst x) \<and> (\<exists>a. G\<^sub>\<psi>.reaches x a \<and> G\<^sub>\<psi>.reaches1 a a))"
  if "\<forall>x\<^sub>0\<in>a\<^sub>0. \<not> sim.sim.deadlock x\<^sub>0"
proof -
  from that have *: "\<forall>x\<^sub>0\<in>Z\<^sub>0. \<not> sim.sim.deadlock (l\<^sub>0, x\<^sub>0)"
    unfolding a\<^sub>0_def by auto
  show ?thesis
    using sim_complete_bisim'.leadsto_mc1[OF *, symmetric, of P Q]
    unfolding \<psi>_def \<phi>_def sim_complete_bisim'.\<phi>'_def sim_complete_bisim'.\<psi>_def a\<^sub>0_def
    by (auto dest: from_R_D from_R_loc)
qed

end (* Context for State Formulae *)

lemma from_R_reaches:
  assumes "sim.sim.Steps.reaches (from_R l\<^sub>0 Z\<^sub>0) b"
  obtains l Z where "b = from_R l Z"
  using assms by cases (fastforce simp: sim.A2'_def dest!: from_R_R_of)+

lemma ta_reaches_ex_iff:
  assumes compatible:
    "\<And>l u u' R.
      u \<in> R \<Longrightarrow> u' \<in> R \<Longrightarrow> R \<in> \<R> l \<Longrightarrow> l \<in> state_set A \<Longrightarrow> P (l, u) = P (l, u')"
  shows
    "(\<exists> x\<^sub>0 \<in> a\<^sub>0. \<exists> l u. sim.sim.reaches x\<^sub>0 (l, u) \<and> P (l, u)) \<longleftrightarrow>
     (\<exists> l Z. \<exists> u \<in> Z. reaches (l\<^sub>0, Z\<^sub>0) (l, Z) \<and> P (l, u))"
proof -
  have *: "(\<exists>x\<^sub>0 \<in> a\<^sub>0. \<exists> l u. sim.sim.reaches x\<^sub>0 (l, u) \<and> P (l, u))
    \<longleftrightarrow> (\<exists>y. \<exists>x\<^sub>0\<in>from_R l\<^sub>0 Z\<^sub>0. sim.sim.reaches x\<^sub>0 y \<and> P y)"
    unfolding a\<^sub>0_def by auto
  show ?thesis
    unfolding *
    apply (subst sim_complete_bisim'.sim_reaches_equiv)
    subgoal
      by (simp add: start_state)
    apply (subst sim_complete_bisim'.reaches_ex'[of P])
    unfolding a\<^sub>0_def
     apply clarsimp
    subgoal
      unfolding sim.P1'_def by (clarsimp simp: fst_simp) (metis R_ofI compatible fst_conv)
    apply safe
     apply (rule from_R_reaches, assumption)
    using from_R_fst by (force intro: from_R_val)+
qed

lemma ta_reaches_all_iff:
  assumes compatible:
    "\<And>l u u' R.
      u \<in> R \<Longrightarrow> u' \<in> R \<Longrightarrow> R \<in> \<R> l \<Longrightarrow> l \<in> state_set A \<Longrightarrow> P (l, u) = P (l, u')"
  shows
    "(\<forall> x\<^sub>0 \<in> a\<^sub>0. \<forall> l u. sim.sim.reaches x\<^sub>0 (l, u) \<longrightarrow> P (l, u)) \<longleftrightarrow>
     (\<forall> l Z. reaches (l\<^sub>0, Z\<^sub>0) (l, Z) \<longrightarrow> (\<forall> u \<in> Z. P (l, u)))"
proof -
  have *: "(\<forall>x\<^sub>0 \<in> a\<^sub>0. \<forall> l u. sim.sim.reaches x\<^sub>0 (l, u) \<longrightarrow> P (l, u))
    \<longleftrightarrow> (\<forall>y. \<forall>x\<^sub>0\<in>from_R l\<^sub>0 Z\<^sub>0. sim.sim.reaches x\<^sub>0 y \<longrightarrow> P y)"
    unfolding a\<^sub>0_def by auto
  show ?thesis
    unfolding *
    apply (subst sim_complete_bisim'.sim_reaches_equiv)
    subgoal
      by (simp add: start_state)
    apply (subst sim_complete_bisim'.reaches_all''[of P])
    unfolding a\<^sub>0_def
     apply clarsimp
    subgoal
      unfolding sim.P1'_def by (clarsimp simp: fst_simp) (metis R_ofI compatible fst_conv)
    apply auto
    apply (rule from_R_reaches, assumption)
    using from_R_fst by (force intro: from_R_val)+
qed

end (* Reachability Problem precompiled *)

end (* Theory *)


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

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

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

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

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

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

section "Examples for Parallel Assignments"

theory XVcgEx
imports "../XVcg"

begin

record "globals" =
  "G_'"::"nat"
  "H_'"::"nat"

record 'g vars = "'g state" +
  A_' :: nat
  B_' :: nat
  C_' :: nat
  I_' :: nat
  M_' :: nat
  N_' :: nat
  R_' :: nat
  S_' :: nat
  Arr_' :: "nat list"
  Abr_':: string

term "BASIC
         \<acute>A :== x,
         \<acute>B :== y
      END"

term "BASIC
         \<acute>G :== \<acute>H,
         \<acute>H :== \<acute>G
      END"

term "BASIC
        LET (x,y) = (\<acute>A,b);
            z = \<acute>B
        IN \<acute>A :== x,
           \<acute>G :== \<acute>A + y + z
      END"

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>A = 0\<rbrace>
      \<lbrace>\<acute>A < 0\<rbrace> \<longmapsto> BASIC
       LET (a,b,c) = foo \<acute>A
       IN
            \<acute>A :== a,
            \<acute>B :== b,
            \<acute>C :== c
      END
      \<lbrace>\<acute>A = x \<and> \<acute>B = y \<and> \<acute>C = c\<rbrace>"
apply vcg
oops

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>A = 0\<rbrace>
      \<lbrace>\<acute>A < 0\<rbrace> \<longmapsto> BASIC
       LET (a,b,c) = foo \<acute>A
       IN
            \<acute>A :== a,
            \<acute>G :== b + \<acute>B,
            \<acute>H :== c
      END
      \<lbrace>\<acute>A = x \<and> \<acute>G = y \<and> \<acute>H = c\<rbrace>"
apply vcg
oops

definition foo:: "nat \<Rightarrow> (nat \<times> nat \<times> nat)"
  where "foo n = (n,n+1,n+2)"

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>A = 0\<rbrace>
      \<lbrace>\<acute>A < 0\<rbrace> \<longmapsto> BASIC
       LET (a,b,c) = foo \<acute>A
       IN
            \<acute>A :== a,
            \<acute>G :== b + \<acute>B,
            \<acute>H :== c
      END
      \<lbrace>\<acute>A = x \<and> \<acute>G = y \<and> \<acute>H = c\<rbrace>"
apply (vcg add: foo_def snd_conv fst_conv)
oops

end


theory DYNAMIC_Post_Network
  imports
    DYNAMIC_Post_ISSUER
    Post_RECEIVER
    "../API_Network"
    "BD_Security_Compositional.Composing_Security_Network"
begin

subsubsection \<open>Confidentiality for the N-ary composition\<close>

type_synonym ttrans = "(state, act, out) trans"
type_synonym obs = Post_Observation_Setup_ISSUER.obs
type_synonym "value" = "Post.value + Post_RECEIVER.value"

lemma value_cases:
fixes v :: "value"
obtains (PVal) pst where "v = Inl (Post.PVal pst)"
      | (PValS) aid pst where "v = Inl (Post.PValS aid pst)"
      | (OVal) ov where "v = Inl (Post.OVal ov)"
      | (PValR) pst where "v = Inr (Post_RECEIVER.PValR pst)"
proof (cases v)
  case (Inl vl) then show thesis using PVal PValS OVal by (cases vl rule: Post.value.exhaust) auto next
  case (Inr vr) then show thesis using PValR by (cases vr rule: Post_RECEIVER.value.exhaust) auto
qed

locale Post_Network = Network
+ fixes UIDs :: "apiID \<Rightarrow> userID set"
  and AID :: "apiID" and PID :: "postID"
  assumes AID_in_AIDs: "AID \<in> AIDs"
begin

sublocale Iss: Post "UIDs AID" PID .

abbreviation \<phi> :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
where "\<phi> aid trn \<equiv> (if aid = AID then Iss.\<phi> trn else Post_RECEIVER.\<phi> PID AID trn)"

abbreviation f :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> value"
where "f aid trn \<equiv> (if aid = AID then Inl (Iss.f trn) else Inr (Post_RECEIVER.f PID AID trn))"

abbreviation \<gamma> :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
where "\<gamma> aid trn \<equiv> (if aid = AID then Iss.\<gamma> trn else ObservationSetup_RECEIVER.\<gamma> (UIDs aid) trn)"

abbreviation g :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> obs"
where "g aid trn \<equiv> (if aid = AID then Iss.g trn else ObservationSetup_RECEIVER.g PID AID trn)"

abbreviation T :: "apiID \<Rightarrow> (state, act, out) trans \<Rightarrow> bool"
  where "T aid trn \<equiv> (if aid = AID then Iss.T trn else Post_RECEIVER.T (UIDs aid) PID AID trn)"

(* Note that Iss.T is trivially False (since the issuer being dynamic, the trigger
is incorporated in the bound) so an alternative definition of the composite trigger is:  *)
lemma T_def:
"T aid trn \<longleftrightarrow> aid \<noteq> AID \<and> Post_RECEIVER.T (UIDs aid) PID AID trn"
by auto

abbreviation B :: "apiID \<Rightarrow> value list \<Rightarrow> value list \<Rightarrow> bool"
where "B aid vl vl1 \<equiv>
  (if aid = AID then list_all isl vl \<and> list_all isl vl1 \<and> Iss.B (map projl vl) (map projl vl1)
   else list_all (Not o isl) vl \<and> list_all (Not o isl) vl1 \<and> Post_RECEIVER.B (map projr vl) (map projr vl1))"

fun comOfV :: "apiID \<Rightarrow> value \<Rightarrow> com" where
  "comOfV aid (Inl (Post.PValS aid' pst)) = (if aid' \<noteq> aid then Send else Internal)"
| "comOfV aid (Inl (Post.PVal pst)) = Internal"
| "comOfV aid (Inl (Post.OVal ov)) = Internal"
| "comOfV aid (Inr v) = Recv"

fun tgtNodeOfV :: "apiID \<Rightarrow> value \<Rightarrow> apiID" where
  "tgtNodeOfV aid (Inl (Post.PValS aid' pst)) = aid'"
| "tgtNodeOfV aid (Inl (Post.PVal pst)) = undefined"
| "tgtNodeOfV aid (Inl (Post.OVal ov)) = undefined"
| "tgtNodeOfV aid (Inr v) = AID"

definition syncV :: "apiID \<Rightarrow> value \<Rightarrow> apiID \<Rightarrow> value \<Rightarrow> bool" where
  "syncV aid1 v1 aid2 v2 =
    (\<exists>pst. aid1 = AID \<and> v1 = Inl (Post.PValS aid2 pst) \<and> v2 = Inr (Post_RECEIVER.PValR pst))"

lemma syncVI: "syncV AID (Inl (Post.PValS aid' pst)) aid' (Inr (Post_RECEIVER.PValR pst))"
unfolding syncV_def by auto

lemma syncVE:
assumes "syncV aid1 v1 aid2 v2"
obtains pst where "aid1 = AID" "v1 = Inl (Post.PValS aid2 pst)" "v2 = Inr (Post_RECEIVER.PValR pst)"
using assms unfolding syncV_def by auto

fun getTgtV where
  "getTgtV (Inl (Post.PValS aid pst)) = Inr (Post_RECEIVER.PValR pst)"
| "getTgtV v = v"

lemma comOfV_AID:
  "comOfV AID v = Send \<longleftrightarrow> isl v \<and> Iss.isPValS (projl v) \<and> Iss.tgtAPI (projl v) \<noteq> AID"
  "comOfV AID v = Recv \<longleftrightarrow> Not (isl v)"
by (cases v rule: value_cases; auto)+

lemmas \<phi>_defs = Post_RECEIVER.\<phi>_def2 Iss.\<phi>_def3

sublocale Net: BD_Security_TS_Network_getTgtV
where istate = "\<lambda>_. istate" and validTrans = validTrans and srcOf = "\<lambda>_. srcOf" and tgtOf = "\<lambda>_. tgtOf"
  and nodes = AIDs and comOf = comOf and tgtNodeOf = tgtNodeOf
  and sync = sync and \<phi> = \<phi> and f = f and \<gamma> = \<gamma> and g = g and T = T and B = B
  and comOfV = comOfV and tgtNodeOfV = tgtNodeOfV and syncV = syncV
  and comOfO = comOfO and tgtNodeOfO = tgtNodeOfO and syncO = syncO (*and cmpO = cmpO*)
  and source = AID and getTgtV = getTgtV
using AID_in_AIDs proof (unfold_locales, goal_cases)
  case (1 nid trn) then show ?case using Iss.validTrans_isCOMact_open[of trn] by (cases trn rule: Iss.\<phi>.cases) (auto simp: \<phi>_defs split: prod.splits) next
  case (2 nid trn) then show ?case using Iss.validTrans_isCOMact_open[of trn] by (cases trn rule: Iss.\<phi>.cases) (auto simp: \<phi>_defs split: prod.splits) next
  case (3 nid trn)
    interpret Sink: Post_RECEIVER "UIDs nid" PID AID .
    show ?case using 3 by (cases "(nid,trn)" rule: tgtNodeOf.cases) (auto split: prod.splits)
next
  case (4 nid trn)
    interpret Sink: Post_RECEIVER "UIDs nid" PID AID .
    show ?case using 4 by (cases "(nid,trn)" rule: tgtNodeOf.cases) (auto split: prod.splits)
next
  case (5 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 5 by (elim sync_cases) (auto intro: syncVI)
next
  case (6 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 6 by (elim sync_cases) auto
next
  case (7 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 7(2,4,6-10)
      using Iss.validTrans_isCOMact_open[OF 7(2)] Iss.validTrans_isCOMact_open[OF 7(4)]
      by (elim sync_cases) (auto split: prod.splits, auto simp: sendPost_def)
next
  case (8 nid1 trn1 nid2 trn2)
    interpret Sink1: Post_RECEIVER "UIDs nid1" PID AID .
    interpret Sink2: Post_RECEIVER "UIDs nid2" PID AID .
    show ?case using 8(2,4,6-10,11,12,13)
      apply (elim syncO_cases; cases trn1; cases trn2)
          apply (auto simp: Iss.g_simps ObservationSetup_RECEIVER.g_simps split: prod.splits)
      apply (auto simp: sendPost_def split: prod.splits elim: syncVE)[]
      done
next
  case (9 nid trn)
    then show ?case
      by (cases "(nid,trn)" rule: tgtNodeOf.cases)
         (auto simp: ObservationSetup_RECEIVER.\<gamma>.simps)
next
  case (10 nid trn) then show ?case by (cases trn) (auto simp: \<phi>_defs)
next
  case (11 vSrc nid vn) then show ?case by (cases vSrc rule: value_cases) (auto simp: syncV_def)
next
  case (12 vSrc nid vn) then show ?case by (cases vSrc rule: value_cases) (auto simp: syncV_def)
qed

lemma list_all_Not_isl_projectSrcV: "list_all (Not o isl) (Net.projectSrcV aid vlSrc)"
proof (induction vlSrc)
  case (Cons vSrc vlSrc') then show ?case by (cases vSrc rule: value_cases) auto
qed auto

context
fixes AID' :: apiID
assumes AID': "AID' \<in> AIDs - {AID}"
begin

interpretation Recv: Post_RECEIVER "UIDs AID'" PID AID by unfold_locales

lemma Iss_BC_BO_tgtAPI:
shows "(Iss.BC vl vl1 \<longrightarrow> map Iss.tgtAPI (filter Iss.isPValS vl) =
                          map Iss.tgtAPI (filter Iss.isPValS vl1)) \<and>
       (Iss.BO vl vl1 \<longrightarrow> map Iss.tgtAPI (filter Iss.isPValS vl) =
                          map Iss.tgtAPI (filter Iss.isPValS vl1))"
by (induction rule: Iss.BC_BO.induct) auto

lemma Iss_B_Recv_B_aux:
assumes "list_all isl vl"
and "list_all isl vl1"
and "map Iss.tgtAPI (filter Iss.isPValS (map projl vl)) =
     map Iss.tgtAPI (filter Iss.isPValS (map projl vl1))"
shows "length (map projr (Net.projectSrcV AID' vl)) = length (map projr (Net.projectSrcV AID' vl1))"
using assms proof (induction vl vl1 rule: list22_induct)
  case (ConsCons v vl v1 vl1)
    consider (SendSend) aid pst pst1 where "v = Inl (Iss.PValS aid pst)" "v1 = Inl (Iss.PValS aid pst1)"
           | (Internal) "comOfV AID v = Internal" "\<not>Iss.isPValS (projl v)"
           | (Internal1) "comOfV AID v1 = Internal" "\<not>Iss.isPValS (projl v1)"
      using ConsCons(4-6) by (cases v rule: value_cases; cases v1 rule: value_cases) auto
    then show ?case proof cases
      case (SendSend) then show ?thesis using ConsCons.IH(1) ConsCons.prems by auto
    next
      case (Internal) then show ?thesis using ConsCons.IH(2)[of "v1 # vl1"] ConsCons.prems by auto
    next
      case (Internal1) then show ?thesis using ConsCons.IH(3)[of "v # vl"] ConsCons.prems by auto
    qed
qed (auto simp: comOfV_AID)

lemma Iss_B_Recv_B:
assumes "B AID vl vl1"
shows "Recv.B (map projr (Net.projectSrcV AID' vl)) (map projr (Net.projectSrcV AID' vl1))"
using assms Iss_B_Recv_B_aux Iss_BC_BO_tgtAPI by (auto simp: Iss.B_def Recv.B_def)

end

lemma map_projl_Inl: "map (projl o Inl) vl = vl"
by (induction vl) auto

lemma these_map_Inl_projl: "list_all isl vl \<Longrightarrow> these (map (Some o Inl o projl) vl) = vl"
by (induction vl) auto

lemma map_projr_Inr: "map (projr o Inr) vl = vl"
by (induction vl) auto

lemma these_map_Inr_projr: "list_all (Not o isl) vl \<Longrightarrow> these (map (Some o Inr o projr) vl) = vl"
by (induction vl) auto

sublocale BD_Security_TS_Network_Preserve_Source_Security_getTgtV
where istate = "\<lambda>_. istate" and validTrans = validTrans and srcOf = "\<lambda>_. srcOf" and tgtOf = "\<lambda>_. tgtOf"
  and nodes = AIDs and comOf = comOf and tgtNodeOf = tgtNodeOf
  and sync = sync and \<phi> = \<phi> and f = f and \<gamma> = \<gamma> and g = g and T = T and B = B
  and comOfV = comOfV and tgtNodeOfV = tgtNodeOfV and syncV = syncV
  and comOfO = comOfO and tgtNodeOfO = tgtNodeOfO and syncO = syncO (*and cmpO = cmpO*)
  and source = AID and getTgtV = getTgtV
proof (unfold_locales, goal_cases)
  case 1 show ?case using AID_in_AIDs .
next
  case 2
    interpret Iss': BD_Security_TS_Trans
      istate System_Specification.validTrans srcOf tgtOf Iss.\<phi> Iss.f Iss.\<gamma> Iss.g Iss.T Iss.B
      istate System_Specification.validTrans srcOf tgtOf Iss.\<phi> "\<lambda>trn. Inl (Iss.f trn)" Iss.\<gamma> Iss.g Iss.T "B AID"
      id id Some "Some o Inl"
    proof (unfold_locales, goal_cases)
      case (11 vl' vl1' tr) then show ?case
        by (intro exI[of _ "map projl vl1'"]) (auto simp: map_projl_Inl these_map_Inl_projl)
    qed auto
    show ?case using Iss.secure Iss'.translate_secure by auto
next
  case (3 aid tr vl' vl1)
    then show ?case
      using Iss_B_Recv_B[of aid "(Net.lV AID tr)" vl1] list_all_Not_isl_projectSrcV
      by auto
qed

theorem secure: "secure"
proof (intro preserve_source_secure ballI)
  fix aid
  assume aid: "aid \<in> AIDs - {AID}"
  interpret Node: Post_RECEIVER "UIDs aid" PID AID .
  interpret Node': BD_Security_TS_Trans
    istate System_Specification.validTrans srcOf tgtOf Node.\<phi> Node.f Node.\<gamma> Node.g Node.T Node.B
    istate System_Specification.validTrans srcOf tgtOf Node.\<phi> "\<lambda>trn. Inr (Node.f trn)" Node.\<gamma> Node.g Node.T "B aid"
    id id Some "Some o Inr"
  proof (unfold_locales, goal_cases)
    case (11 vl' vl1' tr) then show ?case using aid
      by (intro exI[of _ "map projr vl1'"]) (auto simp: map_projr_Inr these_map_Inr_projr)
  qed auto
  show "Net.lsecure aid"
    using aid Node.Post_secure Node'.translate_secure by auto
qed

end  (* context Post_Network *)

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Reflecting Pure types into HOL\<close>

theory Typerep
imports String
begin

datatype typerep = Typerep String.literal "typerep list"

class typerep =
  fixes typerep :: "'a itself \<Rightarrow> typerep"
begin

definition typerep_of :: "'a \<Rightarrow> typerep" where
  [simp]: "typerep_of x = typerep TYPE('a)"

end

syntax
  "_TYPEREP" :: "type => logic"  ("(1TYPEREP/(1'(_')))")

parse_translation \<open>
  let
    fun typerep_tr (*"_TYPEREP"*) [ty] =
          Syntax.const \<^const_syntax>\<open>typerep\<close> $
            (Syntax.const \<^syntax_const>\<open>_constrain\<close> $ Syntax.const \<^const_syntax>\<open>Pure.type\<close> $
              (Syntax.const \<^type_syntax>\<open>itself\<close> $ ty))
      | typerep_tr (*"_TYPEREP"*) ts = raise TERM ("typerep_tr", ts);
  in [(\<^syntax_const>\<open>_TYPEREP\<close>, K typerep_tr)] end
\<close>

typed_print_translation \<open>
  let
    fun typerep_tr' ctxt (*"typerep"*) \<^Type>\<open>fun \<^Type>\<open>itself T\<close> _\<close>
            (Const (\<^const_syntax>\<open>Pure.type\<close>, _) :: ts) =
          Term.list_comb
            (Syntax.const \<^syntax_const>\<open>_TYPEREP\<close> $ Syntax_Phases.term_of_typ ctxt T, ts)
      | typerep_tr' _ T ts = raise Match;
  in [(\<^const_syntax>\<open>typerep\<close>, typerep_tr')] end
\<close>

setup \<open>
let

fun add_typerep tyco thy =
  let
    val sorts = replicate (Sign.arity_number thy tyco) \<^sort>\<open>typerep\<close>;
    val vs = Name.invent_names Name.context "'a" sorts;
    val ty = Type (tyco, map TFree vs);
    val lhs = \<^Const>\<open>typerep ty\<close> $ Free ("T", Term.itselfT ty);
    val rhs = \<^Const>\<open>Typerep\<close> $ HOLogic.mk_literal tyco
      $ HOLogic.mk_list \<^Type>\<open>typerep\<close> (map (HOLogic.mk_typerep o TFree) vs);
    val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
  in
    thy
    |> Class.instantiation ([tyco], vs, \<^sort>\<open>typerep\<close>)
    |> `(fn lthy => Syntax.check_term lthy eq)
    |-> (fn eq => Specification.definition NONE [] [] (Binding.empty_atts, eq))
    |> snd
    |> Class.prove_instantiation_exit (fn ctxt => Class.intro_classes_tac ctxt [])
  end;

fun ensure_typerep tyco thy =
  if not (Sorts.has_instance (Sign.classes_of thy) tyco \<^sort>\<open>typerep\<close>)
    andalso Sorts.has_instance (Sign.classes_of thy) tyco \<^sort>\<open>type\<close>
  then add_typerep tyco thy else thy;

in

add_typerep \<^type_name>\<open>fun\<close>
#> Typedef.interpretation (Local_Theory.background_theory o ensure_typerep)
#> Code.type_interpretation ensure_typerep

end
\<close>

lemma [code nbe]:
  "HOL.equal (x :: typerep) x \<longleftrightarrow> True"
  by (fact equal_refl)

code_printing
  type_constructor typerep \<rightharpoonup> (Eval) "Term.typ"
| constant Typerep \<rightharpoonup> (Eval) "Term.Type/ (_, _)"

code_reserved Eval Term

hide_const (open) typerep Typerep

end


section \<open>Tree to Graph\<close>

theory TreeToGraph
  imports
    Semantics.IRTreeEval
    Graph.IRGraph
begin

subsection \<open>Subgraph to Data-flow Tree\<close>

fun find_node_and_stamp :: "IRGraph \<Rightarrow> (IRNode \<times> Stamp) \<Rightarrow> ID option" where
  "find_node_and_stamp g (n,s) =
     find (\<lambda>i. kind g i = n \<and> stamp g i = s) (sorted_list_of_set(ids g))"

export_code find_node_and_stamp

(* These kinds of nodes are evaluated during the control flow, so are already in MapState. *)
fun is_preevaluated :: "IRNode \<Rightarrow> bool" where
  "is_preevaluated (InvokeNode n _ _ _ _ _) = True" |
  "is_preevaluated (InvokeWithExceptionNode n _ _ _ _ _ _) = True" |
  "is_preevaluated (NewInstanceNode n _ _ _) = True" |
  "is_preevaluated (LoadFieldNode n _ _ _) = True" |
  "is_preevaluated (SignedDivNode n _ _ _ _ _) = True" |
  "is_preevaluated (SignedRemNode n _ _ _ _ _) = True" |
  "is_preevaluated (ValuePhiNode n _ _) = True" |
  "is_preevaluated _ = False"

inductive
  rep :: "IRGraph \<Rightarrow> ID \<Rightarrow> IRExpr \<Rightarrow> bool" ("_ \<turnstile> _ \<simeq> _" 55)
  for g where

  ConstantNode:
  "\<lbrakk>kind g n = ConstantNode c\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (ConstantExpr c)" |

  ParameterNode:
  "\<lbrakk>kind g n = ParameterNode i;
    stamp g n = s\<rbrakk>
    \<Longrightarrow> g  \<turnstile> n \<simeq> (ParameterExpr i s)" |

  ConditionalNode:
  "\<lbrakk>kind g n = ConditionalNode c t f;
    g \<turnstile> c \<simeq> ce;
    g \<turnstile> t \<simeq> te;
    g \<turnstile> f \<simeq> fe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (ConditionalExpr ce te fe)" |

(* Unary nodes *)
  AbsNode:
  "\<lbrakk>kind g n = AbsNode x;
    g \<turnstile> x \<simeq> xe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (UnaryExpr UnaryAbs xe)" |

  NotNode:
  "\<lbrakk>kind g n = NotNode x;
    g \<turnstile> x \<simeq> xe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (UnaryExpr UnaryNot xe)" |

  NegateNode:
  "\<lbrakk>kind g n = NegateNode x;
    g \<turnstile> x \<simeq> xe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (UnaryExpr UnaryNeg xe)" |

  LogicNegationNode:
  "\<lbrakk>kind g n = LogicNegationNode x;
    g \<turnstile> x \<simeq> xe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (UnaryExpr UnaryLogicNegation xe)" |

(* Binary nodes *)
  AddNode:
  "\<lbrakk>kind g n = AddNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinAdd xe ye)" |

  MulNode:
  "\<lbrakk>kind g n = MulNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinMul xe ye)" |

  SubNode:
  "\<lbrakk>kind g n = SubNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinSub xe ye)" |

  AndNode:
  "\<lbrakk>kind g n = AndNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinAnd xe ye)" |

  OrNode:
  "\<lbrakk>kind g n = OrNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinOr xe ye)" |

  XorNode:
  "\<lbrakk>kind g n = XorNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinXor xe ye)" |

  ShortCircuitOrNode:
  "\<lbrakk>kind g n = ShortCircuitOrNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinShortCircuitOr xe ye)" |

  LeftShiftNode:
  "\<lbrakk>kind g n = LeftShiftNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
   \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinLeftShift xe ye)" |

  RightShiftNode:
  "\<lbrakk>kind g n = RightShiftNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
   \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinRightShift xe ye)" |

  UnsignedRightShiftNode:
  "\<lbrakk>kind g n = UnsignedRightShiftNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
   \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinURightShift xe ye)" |

  IntegerBelowNode:
  "\<lbrakk>kind g n = IntegerBelowNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinIntegerBelow xe ye)" |

  IntegerEqualsNode:
  "\<lbrakk>kind g n = IntegerEqualsNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinIntegerEquals xe ye)" |

  IntegerLessThanNode:
  "\<lbrakk>kind g n = IntegerLessThanNode x y;
    g \<turnstile> x \<simeq> xe;
    g \<turnstile> y \<simeq> ye\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (BinaryExpr BinIntegerLessThan xe ye)" |

(* Convert Nodes *)
  NarrowNode:
  "\<lbrakk>kind g n = NarrowNode inputBits resultBits x;
    g \<turnstile> x \<simeq> xe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (UnaryExpr (UnaryNarrow inputBits resultBits) xe)" |

  SignExtendNode:
  "\<lbrakk>kind g n = SignExtendNode inputBits resultBits x;
    g \<turnstile> x \<simeq> xe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (UnaryExpr (UnarySignExtend inputBits resultBits) xe)" |

  ZeroExtendNode:
  "\<lbrakk>kind g n = ZeroExtendNode inputBits resultBits x;
    g \<turnstile> x \<simeq> xe\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (UnaryExpr (UnaryZeroExtend inputBits resultBits) xe)" |

(* Leaf Node *)
  LeafNode:
  "\<lbrakk>is_preevaluated (kind g n);
    stamp g n = s\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> (LeafExpr n s)" |

(* Ref Node *)
  RefNode:
  "\<lbrakk>kind g n = RefNode n';
    g \<turnstile> n' \<simeq> e\<rbrakk>
    \<Longrightarrow> g \<turnstile> n \<simeq> e"

code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as exprE) rep .

inductive
  replist :: "IRGraph \<Rightarrow> ID list \<Rightarrow> IRExpr list \<Rightarrow> bool" ("_ \<turnstile> _ \<simeq>\<^sub>L _" 55)
  for g where

  RepNil:
  "g \<turnstile> [] \<simeq>\<^sub>L []" |

  RepCons:
  "\<lbrakk>g \<turnstile> x \<simeq> xe;
    g \<turnstile> xs \<simeq>\<^sub>L xse\<rbrakk>
    \<Longrightarrow> g \<turnstile> x#xs \<simeq>\<^sub>L xe#xse"

code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as exprListE) replist .

definition wf_term_graph :: "MapState \<Rightarrow> Params \<Rightarrow> IRGraph \<Rightarrow> ID \<Rightarrow> bool" where
  "wf_term_graph m p g n = (\<exists> e. (g \<turnstile> n \<simeq> e) \<and> (\<exists> v. ([m, p] \<turnstile> e \<mapsto> v)))"

values "{t. eg2_sq \<turnstile> 4 \<simeq> t}"

inductive_cases ConstantNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (ConstantExpr c)"
inductive_cases ParameterNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (ParameterExpr i s)"
inductive_cases ConditionalNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (ConditionalExpr ce te fe)"
inductive_cases AbsNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (UnaryExpr UnaryAbs xe)"
inductive_cases NotNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (UnaryExpr UnaryNot xe)"
inductive_cases NegateNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (UnaryExpr UnaryNeg xe)"
inductive_cases LogicNegationNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (UnaryExpr UnaryLogicNegation xe)"
inductive_cases AddNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinAdd xe ye)"
inductive_cases MulNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinMul xe ye)"
inductive_cases SubNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinSub xe ye)"
inductive_cases AndNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinAnd xe ye)"
inductive_cases OrNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinOr xe ye)"
inductive_cases XorNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinXor xe ye)"
inductive_cases ShortCircuitOrE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinShortCircuitOr xe ye)"
inductive_cases LeftShiftNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinLeftShift xe ye)"
inductive_cases RightShiftNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinRightShift xe ye)"
inductive_cases UnsignedRightShiftNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinURightShift xe ye)"
inductive_cases IntegerBelowNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinIntegerBelow xe ye)"
inductive_cases IntegerEqualsNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinIntegerEquals xe ye)"
inductive_cases IntegerLessThanNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (BinaryExpr BinIntegerLessThan xe ye)"
inductive_cases NarrowNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (UnaryExpr (UnaryNarrow ib rb) xe)"
inductive_cases SignExtendNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (UnaryExpr (UnarySignExtend ib rb) xe)"
inductive_cases ZeroExtendNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (UnaryExpr (UnaryZeroExtend ib rb) xe)"
inductive_cases LeafNodeE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g \<turnstile> n \<simeq> (LeafExpr n s)"

(* group those forward rules into a named set *)
lemmas RepE\<^marker>\<open>tag invisible\<close> =
  ConstantNodeE
  ParameterNodeE
  ConditionalNodeE
  AbsNodeE
  NotNodeE
  NegateNodeE
  LogicNegationNodeE
  AddNodeE
  MulNodeE
  SubNodeE
  AndNodeE
  OrNodeE
  XorNodeE
  ShortCircuitOrE
  LeftShiftNodeE
  RightShiftNodeE
  UnsignedRightShiftNodeE
  IntegerBelowNodeE
  IntegerEqualsNodeE
  IntegerLessThanNodeE
  NarrowNodeE
  SignExtendNodeE
  ZeroExtendNodeE
  LeafNodeE

subsection \<open>Data-flow Tree to Subgraph\<close>

fun unary_node :: "IRUnaryOp \<Rightarrow> ID \<Rightarrow> IRNode" where
  "unary_node UnaryAbs v = AbsNode v" |
  "unary_node UnaryNot v = NotNode v" |
  "unary_node UnaryNeg v = NegateNode v" |
  "unary_node UnaryLogicNegation v = LogicNegationNode v" |
  "unary_node (UnaryNarrow ib rb) v = NarrowNode ib rb v" |
  "unary_node (UnarySignExtend ib rb) v = SignExtendNode ib rb v" |
  "unary_node (UnaryZeroExtend ib rb) v = ZeroExtendNode ib rb v"

(* Creates the appropriate IRNode for a given binary operator. *)
fun bin_node :: "IRBinaryOp \<Rightarrow> ID \<Rightarrow> ID \<Rightarrow> IRNode" where
  "bin_node BinAdd x y = AddNode x y" |
  "bin_node BinMul x y = MulNode x y" |
  "bin_node BinSub x y = SubNode x y" |
  "bin_node BinAnd x y = AndNode x y" |
  "bin_node BinOr  x y = OrNode x y" |
  "bin_node BinXor x y = XorNode x y" |
  "bin_node BinShortCircuitOr x y = ShortCircuitOrNode x y" |
  "bin_node BinLeftShift x y = LeftShiftNode x y" |
  "bin_node BinRightShift x y = RightShiftNode x y" |
  "bin_node BinURightShift x y = UnsignedRightShiftNode x y" |
  "bin_node BinIntegerEquals x y = IntegerEqualsNode x y" |
  "bin_node BinIntegerLessThan x y = IntegerLessThanNode x y" |
  "bin_node BinIntegerBelow x y = IntegerBelowNode x y"

inductive fresh_id :: "IRGraph \<Rightarrow> ID \<Rightarrow> bool" where
  "n \<notin> ids g \<Longrightarrow> fresh_id g n"

code_pred fresh_id .

(* This generates a specific fresh ID (max+1), in a code-friendly way. *)
fun get_fresh_id :: "IRGraph \<Rightarrow> ID" where
(* Previous attempts - cannot generate code due to nat not Enum.
  "get_fresh_id g = 100"
  "get_fresh_id g = (ffold max (0::nat) (f_ids g))"
  "get_fresh_id g = fst(last(as_list g))"
  "get_fresh_id g = last(sorted_list_of_set (dom (Rep_IRGraph g)))"
*)
  "get_fresh_id g = last(sorted_list_of_set(ids g)) + 1"

export_code get_fresh_id
(* these examples return 6 and 7 respectively *)
value "get_fresh_id eg2_sq"
value "get_fresh_id (add_node 6 (ParameterNode 2, default_stamp) eg2_sq)"

(* Second version of tree insertion into graph:

      g \<triangleleft> expr \<leadsto> (g',n) re-inserts expr into g and returns the new root n.

   This means that we can try to re-use existing nodes by finding node IDs bottom-up.
*)
inductive
  unrep :: "IRGraph \<Rightarrow> IRExpr \<Rightarrow> (IRGraph \<times> ID) \<Rightarrow> bool" ("_ \<oplus> _ \<leadsto> _" 55)
   where

  ConstantNodeSame:
  "\<lbrakk>find_node_and_stamp g (ConstantNode c, constantAsStamp c) = Some n\<rbrakk>
    \<Longrightarrow> g \<oplus> (ConstantExpr c) \<leadsto> (g, n)" |

  ConstantNodeNew:
  "\<lbrakk>find_node_and_stamp g (ConstantNode c, constantAsStamp c) = None;
    n = get_fresh_id g;
    g' = add_node n (ConstantNode c, constantAsStamp c) g \<rbrakk>
    \<Longrightarrow> g \<oplus> (ConstantExpr c) \<leadsto> (g', n)" |

  ParameterNodeSame:
  "\<lbrakk>find_node_and_stamp g (ParameterNode i, s) = Some n\<rbrakk>
    \<Longrightarrow> g \<oplus> (ParameterExpr i s) \<leadsto> (g, n)" |

  ParameterNodeNew:
  "\<lbrakk>find_node_and_stamp g (ParameterNode i, s) = None;
    n = get_fresh_id g;
    g' = add_node n (ParameterNode i, s) g\<rbrakk>
    \<Longrightarrow> g \<oplus> (ParameterExpr i s) \<leadsto> (g', n)" |

  ConditionalNodeSame:
  "\<lbrakk>find_node_and_stamp g4 (ConditionalNode c t f, s') = Some n;
    g \<oplus> ce \<leadsto> (g2, c);
    g2 \<oplus> te \<leadsto> (g3, t);
    g3 \<oplus> fe \<leadsto> (g4, f);
    s' = meet (stamp g4 t) (stamp g4 f)\<rbrakk>
    \<Longrightarrow> g \<oplus> (ConditionalExpr ce te fe) \<leadsto> (g4, n)" |

  ConditionalNodeNew:
  "\<lbrakk>find_node_and_stamp g4 (ConditionalNode c t f, s') = None;
    g \<oplus> ce \<leadsto> (g2, c);
    g2 \<oplus> te \<leadsto> (g3, t);
    g3 \<oplus> fe \<leadsto> (g4, f);
    s' = meet (stamp g4 t) (stamp g4 f);
    n = get_fresh_id g4;
    g' = add_node n (ConditionalNode c t f, s') g4\<rbrakk>
    \<Longrightarrow> g \<oplus> (ConditionalExpr ce te fe) \<leadsto> (g', n)" |

  UnaryNodeSame:
  "\<lbrakk>find_node_and_stamp g2 (unary_node op x, s') = Some n;
    g \<oplus> xe \<leadsto> (g2, x);
    s' = stamp_unary op (stamp g2 x)\<rbrakk>
    \<Longrightarrow> g \<oplus> (UnaryExpr op xe) \<leadsto> (g2, n)" |

  UnaryNodeNew:
  "\<lbrakk>find_node_and_stamp g2 (unary_node op x, s') = None;
    g \<oplus> xe \<leadsto> (g2, x);
    s' = stamp_unary op (stamp g2 x);
    n = get_fresh_id g2;
    g' = add_node n (unary_node op x, s') g2\<rbrakk>
    \<Longrightarrow> g \<oplus> (UnaryExpr op xe) \<leadsto> (g', n)" |

  BinaryNodeSame:
  "\<lbrakk>find_node_and_stamp g3 (bin_node op x y, s') = Some n;
    g \<oplus> xe \<leadsto> (g2, x);
    g2 \<oplus> ye \<leadsto> (g3, y);
    s' = stamp_binary op (stamp g3 x) (stamp g3 y)\<rbrakk>
    \<Longrightarrow> g \<oplus> (BinaryExpr op xe ye) \<leadsto> (g3, n)" |

  BinaryNodeNew:
  "\<lbrakk>find_node_and_stamp g3 (bin_node op x y, s') = None;
    g \<oplus> xe \<leadsto> (g2, x);
    g2 \<oplus> ye \<leadsto> (g3, y);
    s' = stamp_binary op (stamp g3 x) (stamp g3 y);
    n = get_fresh_id g3;
    g' = add_node n (bin_node op x y, s') g3\<rbrakk>
    \<Longrightarrow> g \<oplus> (BinaryExpr op xe ye) \<leadsto> (g', n)" |

  AllLeafNodes:
  "\<lbrakk>stamp g n = s;
    is_preevaluated (kind g n)\<rbrakk>
    \<Longrightarrow> g \<oplus> (LeafExpr n s) \<leadsto> (g, n)"

(*  UnrepNil:
  "g \<triangleleft>\<^sub>L [] \<leadsto> (g, [])" |

(* TODO: this will fail for [xe,ye] where they are not equal.
         Figure out how to generate code for this?
*)
  UnrepCons:
  "\<lbrakk>g \<triangleleft> xe \<leadsto> (g2, x);
    g2 \<triangleleft>\<^sub>L xes \<leadsto> (g3, xs)\<rbrakk>
    \<Longrightarrow> g \<triangleleft>\<^sub>L (xe#xes) \<leadsto> (g3, x#xs)"*)

code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as unrepE)
(*
  [show_steps,show_mode_inference,show_intermediate_results]
*)  unrep .

text_raw \<open>\Snip{unrepRules}%
\begin{center}
@{thm[mode=Rule] unrep.ConstantNodeSame [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.ConstantNodeNew [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.ParameterNodeSame [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.ParameterNodeNew [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.ConditionalNodeSame [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.ConditionalNodeNew [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.BinaryNodeSame [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.BinaryNodeNew [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.UnaryNodeSame [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.UnaryNodeNew [no_vars]}\\[8px]
@{thm[mode=Rule] unrep.AllLeafNodes [no_vars]}\\[8px]
\end{center}
\EndSnip\<close>

(*
instantiation IRGraph :: equal begin

definition "(g1 = g2) \<longleftrightarrow>
              (f_ids g1 = f_ids g2 \<and>
               (\<forall>n. (n \<in> ids g1 \<Longrightarrow> (Rep_IRGraph g1 n = Rep_IRGraph g2 n))))"
instance proof
  fix x y :: IRGraph
  show "x = y \<longleftrightarrow> x \<le> y \<and> \<not> (y \<le> x)" by (simp add: equiv_exprs_def; auto)
  show "x \<le> x" by simp
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z" by simp
qed
end
*)

values "{(n, g) . (eg2_sq \<oplus> sq_param0 \<leadsto> (g, n))}"

subsection \<open>Lift Data-flow Tree Semantics\<close>

definition encodeeval :: "IRGraph \<Rightarrow> MapState \<Rightarrow> Params \<Rightarrow> ID \<Rightarrow> Value \<Rightarrow> bool"
  ("[_,_,_] \<turnstile> _ \<mapsto> _" 50)
  where
  "encodeeval g m p n v = (\<exists> e. (g \<turnstile> n \<simeq> e) \<and> ([m,p] \<turnstile> e \<mapsto> v))"

subsection \<open>Graph Refinement\<close>

definition graph_represents_expression :: "IRGraph \<Rightarrow> ID \<Rightarrow> IRExpr \<Rightarrow> bool"
  ("_ \<turnstile> _ \<unlhd> _" 50)
  where
  "(g \<turnstile> n \<unlhd> e) = (\<exists>e' . (g \<turnstile> n \<simeq> e') \<and> (e' \<le> e))"

definition graph_refinement :: "IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool" where
  "graph_refinement g\<^sub>1 g\<^sub>2 =
        ((ids g\<^sub>1 \<subseteq> ids g\<^sub>2) \<and>
        (\<forall> n . n \<in> ids g\<^sub>1 \<longrightarrow> (\<forall>e. (g\<^sub>1 \<turnstile> n \<simeq> e) \<longrightarrow> (g\<^sub>2 \<turnstile> n \<unlhd> e))))"

lemma graph_refinement:
  "graph_refinement g1 g2 \<Longrightarrow> (\<forall>n m p v. n \<in> ids g1 \<longrightarrow> ([g1, m, p] \<turnstile> n \<mapsto> v) \<longrightarrow> ([g2, m, p] \<turnstile> n \<mapsto> v))"
  by (meson encodeeval_def graph_refinement_def graph_represents_expression_def le_expr_def)

subsection \<open>Maximal Sharing\<close>

definition maximal_sharing:
  "maximal_sharing g = (\<forall> n\<^sub>1 n\<^sub>2 . n\<^sub>1 \<in> true_ids g \<and> n\<^sub>2 \<in> true_ids g \<longrightarrow>
      (\<forall> e. (g \<turnstile> n\<^sub>1 \<simeq> e) \<and> (g \<turnstile> n\<^sub>2 \<simeq> e) \<and> (stamp g n\<^sub>1 = stamp g n\<^sub>2) \<longrightarrow> n\<^sub>1 = n\<^sub>2))"

end