(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Up_To_Technique
imports WHATWHERE_Security
begin

context WHATWHERE
begin

abbreviation SdlHPPB where "SdlHPPB \<equiv> Strong_dlHPP_Bisimulation"

\<comment> \<open>define the 'reflexive part' of a relation (sets of elements which are related with themselves by the given relation)\<close>
definition Arefl :: "('a \<times> 'a) set \<Rightarrow> 'a set"
where
"Arefl R = {e. (e,e) \<in> R}"

lemma commonArefl_subset_commonDomain:
"(Arefl R1 \<inter> Arefl R2) \<subseteq> (Domain R1 \<inter> Domain R2)"
  by (simp add: Arefl_def, auto)

\<comment> \<open>define disjoint strong (d,lH,PP)-bisimulation up-to-R' for a relation R\<close>
definition disj_dlHPP_Bisimulation_Up_To_R' ::
  "'d \<Rightarrow> nat set \<Rightarrow> 'com Bisimulation_type
  \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"disj_dlHPP_Bisimulation_Up_To_R' d PP R' R \<equiv>
  SdlHPPB d PP R' \<and> (sym R) \<and> (trans R)
  \<and> (\<forall>(V,V') \<in> R. length V = length V') \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V.
    ((NDC d (V!i)) \<or>
     (IDC d (V!i) (htchLoc (pp (V!i)))))) \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V. \<forall>m1 m1' m2 \<alpha> p.
    (\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle> \<and> m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1')
    \<longrightarrow> (\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        (stepResultsinR p p' (R \<union> R')) \<and> (\<alpha>,\<alpha>') \<in> (R \<union> R') \<and>
        (dhequality_alternative d PP (pp (V!i)) m2 m2')))"

\<comment> \<open>lemma about the transitivity of the union of symmetric and transitive relations under certain circumstances\<close>
lemma trans_RuR':
  assumes transR: "trans R"
  assumes symR: "sym R"
  assumes transR': "trans R'"
  assumes symR': "sym R'"
  assumes eqlenR: "\<forall>(V,V') \<in> R. length V = length V'"
  assumes eqlenR': "\<forall>(V,V') \<in> R'. length V = length V'"
  assumes Areflassump: "(Arefl R \<inter> Arefl R') \<subseteq> {[]}"
  shows "trans (R \<union> R')"
proof -
 {
   fix V V' V''
   assume p1: "(V,V') \<in> (R \<union> R')"
   assume p2: "(V',V'') \<in> (R \<union> R')"

   from p1 p2 have "(V,V'') \<in> (R \<union> R')"
     proof (auto)
         assume inR1: "(V,V') \<in> R"
         assume inR2: "(V',V'') \<in> R"
         from inR1 inR2 transR show "(V,V'') \<in> R"
           unfolding trans_def
           by blast
       next
         assume inR'1: "(V,V') \<in> R'"
         assume inR'2: "(V',V'') \<in> R'"
         assume notinR': "(V,V'') \<notin> R'"
         from inR'1 inR'2 transR' have inR': "(V,V'') \<in> R'"
           unfolding trans_def
           by blast
         from notinR' inR' have "False"
           by auto
         thus "(V,V'') \<in> R" ..
       next
         assume inR1: "(V,V') \<in> R"
         assume inR'2: "(V',V'') \<in> R'"
         from inR1 symR transR have "(V,V) \<in> R \<and> (V',V') \<in> R"
           unfolding sym_def trans_def
           by blast
         hence AreflR: "{V,V'} \<subseteq> Arefl R" by (simp add: Arefl_def)
         from inR'2 symR' transR' have "(V',V') \<in> R' \<and> (V'',V'') \<in> R'"
           unfolding sym_def trans_def
           by blast
         hence AreflR': "{V',V''} \<subseteq> Arefl R'" by (simp add: Arefl_def)

         from AreflR AreflR' Areflassump have V'empt: "V' = []"
           by (simp add: Arefl_def, blast)
         with inR'2 eqlenR' have "V' = V''" by auto
         with inR1 show "(V, V'') \<in> R" by auto
       next
         assume inR'1: "(V,V') \<in> R'"
         assume inR2: "(V',V'') \<in> R"
         from inR'1 symR' transR' have "(V,V) \<in> R' \<and> (V',V') \<in> R'"
           unfolding sym_def trans_def
           by blast
         hence AreflR': "{V,V'} \<subseteq> Arefl R'" by (simp add: Arefl_def)
         from inR2 symR transR have "(V',V') \<in> R \<and> (V'',V'') \<in> R"
           unfolding sym_def trans_def
           by blast
         hence AreflR: "{V',V''} \<subseteq> Arefl R" by (simp add: Arefl_def)

         from AreflR AreflR' Areflassump have V'empt: "V' = []"
           by (simp add: Arefl_def, blast)
         with inR'1 eqlenR' have "V' = V" by auto
         with inR2 show "(V, V'') \<in> R" by auto
       qed
 }
 thus ?thesis unfolding trans_def by force

qed

lemma Up_To_Technique:
"\<lbrakk> disj_dlHPP_Bisimulation_Up_To_R' d PP R' R;
  Arefl R \<inter> Arefl R' \<subseteq> {[]} \<rbrakk>
  \<Longrightarrow> SdlHPPB d PP (R \<union> R')"
proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def
    Strong_dlHPP_Bisimulation_def, auto)
  assume symR': "sym R'"
  assume symR: "sym R"
  with symR' show "sym (R \<union> R')"
    by (simp add: sym_def)
next
  assume symR': "sym R'"
  assume symR: "sym R"
  assume transR': "trans R'"
  assume transR: "trans R"
  assume eqlenR': "\<forall>(V, V')\<in>R'. length V = length V'"
  assume eqlenR: "\<forall>(V, V')\<in>R. length V = length V'"
  assume areflassump: "Arefl R \<inter> Arefl R' \<subseteq> {[]}"
  from symR' symR transR' transR eqlenR' eqlenR areflassump trans_RuR'
  show "trans (R \<union> R')"
    by blast
  \<comment> \<open>condition about IDC and NDC and equal length already proven above by auto tactic!\<close>
next
  fix V V' i m1 m1' m2 \<alpha> p
  assume inR': "(V,V') \<in> R'"
  assume irange: "i < length V"
  assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
  assume dhequal: "m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1'"
  assume disjBisimUpTo: "\<forall>(V,V')\<in>R'. \<forall>i < length V. \<forall>m1 m1' m2 \<alpha> p.
    \<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle> \<and> m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1' \<longrightarrow>
    (\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
    stepResultsinR p p' R' \<and> (\<alpha>, \<alpha>') \<in> R' \<and>
    dhequality_alternative d PP (pp (V!i)) m2 m2')"
  from inR' irange step dhequal disjBisimUpTo show "\<exists>p' \<alpha>' m2'.
    \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and> stepResultsinR p p' (R \<union> R') \<and>
    ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> R') \<and>
    dhequality_alternative d PP (pp (V!i)) m2 m2'"
    by (simp add: stepResultsinR_def,fastforce)
qed

lemma Union_Strong_dlHPP_Bisim:
"\<lbrakk> SdlHPPB d PP R; SdlHPPB d PP R';
  Arefl R \<inter> Arefl R' \<subseteq> {[]} \<rbrakk>
  \<Longrightarrow> SdlHPPB d PP (R \<union> R')"
by (rule Up_To_Technique, simp_all add:
  disj_dlHPP_Bisimulation_Up_To_R'_def
  Strong_dlHPP_Bisimulation_def stepResultsinR_def, fastforce)

lemma adding_emptypair_keeps_SdlHPPB:
  assumes SdlHPP: "SdlHPPB d PP R"
  shows "SdlHPPB d PP (R \<union> {([],[])})"
proof -
  have SdlHPPemp: "SdlHPPB d PP {([],[])}"
    by (simp add: Strong_dlHPP_Bisimulation_def sym_def trans_def)

  have commonDom: "Domain R \<inter> Domain {([],[])} \<subseteq> {[]}"
    by auto

  with commonArefl_subset_commonDomain have Areflassump:
    "Arefl R \<inter> Arefl {([],[])} \<subseteq> {[]}"
    by force

  with SdlHPP SdlHPPemp Union_Strong_dlHPP_Bisim show
    "SdlHPPB d PP (R \<union> {([],[])})"
    by force
qed

end

end


theory SINVAR_ACLnotCommunicateWith
imports "../TopoS_Helper" SINVAR_ACLcommunicateWith
begin

subsection \<open>SecurityInvariant ACLnotCommunicateWith\<close>
text\<open>An access control list strategy that says that hosts must not transitively access each other.\<close>

text\<open>node properties: a set of hosts this host must not access\<close>

definition default_node_properties :: "'v set"
  where  "default_node_properties \<equiv> UNIV"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v set) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> v \<in> nodes G. \<forall> a \<in> (succ_tran G v). a \<notin> (nP v))"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

text\<open>It is the inverse of @{const SINVAR_ACLcommunicateWith.sinvar}\<close>
lemma ACLcommunicateNotWith_inverse_ACLcommunicateWith:
  "\<forall>v. UNIV - nP' v = set (nP v) \<Longrightarrow> SINVAR_ACLcommunicateWith.sinvar G nP \<longleftrightarrow> sinvar G nP'"
  by auto

    from a3 have "\<And>v a. v \<in> N \<Longrightarrow>  a \<in> (succ_tran \<lparr>nodes = N, edges = E\<rparr> v) \<Longrightarrow> a \<notin> (nP v)" by fastforce
    from this a2 have g1: "\<And>v a. v \<in> N \<Longrightarrow> a \<in> (succ_tran \<lparr>nodes = N, edges = E'\<rparr> v) \<Longrightarrow> a \<notin> (nP v)"
      using succ_tran_mono[OF a1] by blast

    thus "sinvar \<lparr>nodes = N, edges = E'\<rparr> nP"
      by(clarsimp)
qed

lemma succ_tran_empty: "(succ_tran \<lparr>nodes = nodes G, edges = {}\<rparr> v) = {}"
  by(simp add: succ_tran_def)

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
    apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops succ_tran_empty)[1]
   apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma unique_default_example: "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_2 = {}"
apply (simp add: succ_tran_def)
by (metis Domain.DomainI Domain_empty Domain_insert distinct_vertices12 singleton_iff trancl_domain)

interpretation ACLnotCommunicateWith: SecurityInvariant_ACS
where default_node_properties = SINVAR_ACLnotCommunicateWith.default_node_properties
and sinvar = SINVAR_ACLnotCommunicateWith.sinvar
  unfolding SINVAR_ACLnotCommunicateWith.default_node_properties_def
  apply unfold_locales

   apply simp
   apply(subst(asm) SecurityInvariant_withOffendingFlows.set_offending_flows_simp, simp)
   apply(clarsimp)
   apply (metis)

  apply(erule default_uniqueness_by_counterexample_ACS)
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split)
  apply(case_tac "otherbot = {}")

   apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(rule_tac x="(\<lambda> x. UNIV)(vertex_1 := {vertex_2}, vertex_2 := {})" in exI, simp)
   apply(simp add: example_simps)
   apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
   apply(simp add: example_simps)

  apply(subgoal_tac "\<exists>canAccess. canAccess \<in> UNIV \<and> canAccess \<notin> otherbot")
   prefer 2
   apply blast
  apply(erule exE)
  apply(rename_tac canAccessThis)
  apply(case_tac "vertex_1 \<noteq> canAccessThis")

   apply(rule_tac x="\<lparr> nodes={vertex_1,canAccessThis}, edges = {(vertex_1,canAccessThis)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(rule_tac x="(\<lambda> x. UNIV)(vertex_1 := UNIV, canAccessThis := {})" in exI, simp)
   apply(simp add: example_simps)
   apply(rule_tac x="{(vertex_1,canAccessThis)}" in exI, simp)
   apply(simp add: example_simps)

  apply(rule_tac x="\<lparr> nodes={canAccessThis,vertex_2}, edges = {(vertex_2,canAccessThis)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. UNIV)(vertex_2 := UNIV, canAccessThis := {})" in exI, simp)
  apply(simp add: example_simps)
  apply(rule_tac x="{(vertex_2,canAccessThis)}" in exI, simp)
  apply(simp add: example_simps)
 done

  lemma TopoS_ACLnotCommunicateWith: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar receiver_violation default_node_properties

end


(* Author: Tobias Nipkow *)

theory Abs_Int2
imports Abs_Int1
begin

instantiation prod :: (order,order) order
begin

definition "less_eq_prod p1 p2 = (fst p1 \<le> fst p2 \<and> snd p1 \<le> snd p2)"
definition "less_prod p1 p2 = (p1 \<le> p2 \<and> \<not> p2 \<le> (p1::'a*'b))"

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_prod_def)
next
  case 2 show ?case by(simp add: less_eq_prod_def)
next
  case 3 thus ?case unfolding less_eq_prod_def by(metis order_trans)
next
  case 4 thus ?case by(simp add: less_eq_prod_def)(metis eq_iff surjective_pairing)
qed

end

subsection "Backward Analysis of Expressions"

subclass (in bounded_lattice) semilattice_sup_top ..

locale Val_lattice_gamma = Gamma_semilattice where \<gamma> = \<gamma>
  for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set" +
assumes inter_gamma_subset_gamma_inf:
  "\<gamma> a1 \<inter> \<gamma> a2 \<subseteq> \<gamma>(a1 \<sqinter> a2)"
and gamma_bot[simp]: "\<gamma> \<bottom> = {}"
begin

lemma in_gamma_inf: "x : \<gamma> a1 \<Longrightarrow> x : \<gamma> a2 \<Longrightarrow> x : \<gamma>(a1 \<sqinter> a2)"
by (metis IntI inter_gamma_subset_gamma_inf set_mp)

lemma gamma_inf: "\<gamma>(a1 \<sqinter> a2) = \<gamma> a1 \<inter> \<gamma> a2"
by(rule equalityI[OF _ inter_gamma_subset_gamma_inf])
  (metis inf_le1 inf_le2 le_inf_iff mono_gamma)

end

locale Val_inv = Val_lattice_gamma where \<gamma> = \<gamma>
   for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set" +
fixes test_num' :: "val \<Rightarrow> 'av \<Rightarrow> bool"
and inv_plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av \<Rightarrow> 'av * 'av"
and inv_less' :: "bool \<Rightarrow> 'av \<Rightarrow> 'av \<Rightarrow> 'av * 'av"
assumes test_num': "test_num' i a = (i : \<gamma> a)"
and inv_plus': "inv_plus' a a1 a2 = (a\<^sub>1',a\<^sub>2') \<Longrightarrow>
  i1 : \<gamma> a1 \<Longrightarrow> i2 : \<gamma> a2 \<Longrightarrow> i1+i2 : \<gamma> a \<Longrightarrow> i1 : \<gamma> a\<^sub>1' \<and> i2 : \<gamma> a\<^sub>2'"
and inv_less': "inv_less' (i1<i2) a1 a2 = (a\<^sub>1',a\<^sub>2') \<Longrightarrow>
  i1 : \<gamma> a1 \<Longrightarrow> i2 : \<gamma> a2 \<Longrightarrow> i1 : \<gamma> a\<^sub>1' \<and> i2 : \<gamma> a\<^sub>2'"

locale Abs_Int_inv = Val_inv where \<gamma> = \<gamma>
  for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set"
begin

lemma in_gamma_sup_UpI:
  "s : \<gamma>\<^sub>o S1 \<or> s : \<gamma>\<^sub>o S2 \<Longrightarrow> s : \<gamma>\<^sub>o(S1 \<squnion> S2)"
by (metis (hide_lams, no_types) sup_ge1 sup_ge2 mono_gamma_o subsetD)

fun aval'' :: "aexp \<Rightarrow> 'av st option \<Rightarrow> 'av" where
"aval'' e None = \<bottom>" |
"aval'' e (Some S) = aval' e S"

lemma aval''_correct: "s : \<gamma>\<^sub>o S \<Longrightarrow> aval a s : \<gamma>(aval'' a S)"
by(cases S)(auto simp add: aval'_correct split: option.splits)

subsubsection "Backward analysis"

fun inv_aval' :: "aexp \<Rightarrow> 'av \<Rightarrow> 'av st option \<Rightarrow> 'av st option" where
"inv_aval' (N n) a S = (if test_num' n a then S else None)" |
"inv_aval' (V x) a S = (case S of None \<Rightarrow> None | Some S \<Rightarrow>
  let a' = fun S x \<sqinter> a in
  if a' = \<bottom> then None else Some(update S x a'))" |
"inv_aval' (Plus e1 e2) a S =
 (let (a1,a2) = inv_plus' a (aval'' e1 S) (aval'' e2 S)
  in inv_aval' e1 a1 (inv_aval' e2 a2 S))"

text{* The test for @{const bot} in the @{const V}-case is important: @{const
bot} indicates that a variable has no possible values, i.e.\ that the current
program point is unreachable. But then the abstract state should collapse to
@{const None}. Put differently, we maintain the invariant that in an abstract
state of the form @{term"Some s"}, all variables are mapped to non-@{const
bot} values. Otherwise the (pointwise) sup of two abstract states, one of
which contains @{const bot} values, may produce too large a result, thus
making the analysis less precise. *}

fun inv_bval' :: "bexp \<Rightarrow> bool \<Rightarrow> 'av st option \<Rightarrow> 'av st option" where
"inv_bval' (Bc v) res S = (if v=res then S else None)" |
"inv_bval' (Not b) res S = inv_bval' b (\<not> res) S" |
"inv_bval' (And b1 b2) res S =
  (if res then inv_bval' b1 True (inv_bval' b2 True S)
   else inv_bval' b1 False S \<squnion> inv_bval' b2 False S)" |
"inv_bval' (Less e1 e2) res S =
  (let (a1,a2) = inv_less' res (aval'' e1 S) (aval'' e2 S)
   in inv_aval' e1 a1 (inv_aval' e2 a2 S))"

lemma inv_aval'_correct: "s : \<gamma>\<^sub>o S \<Longrightarrow> aval e s : \<gamma> a \<Longrightarrow> s : \<gamma>\<^sub>o (inv_aval' e a S)"
proof(induction e arbitrary: a S)
  case N thus ?case by simp (metis test_num')
next
  case (V x)
  obtain S' where "S = Some S'" and "s : \<gamma>\<^sub>s S'" using `s : \<gamma>\<^sub>o S`
    by(auto simp: in_gamma_option_iff)
  moreover hence "s x : \<gamma> (fun S' x)"
    by(simp add: \<gamma>_st_def)
  moreover have "s x : \<gamma> a" using V(2) by simp
  ultimately show ?case
    by(simp add: Let_def \<gamma>_st_def)
      (metis mono_gamma emptyE in_gamma_inf gamma_bot subset_empty)
next
  case (Plus e1 e2) thus ?case
    using inv_plus'[OF _ aval''_correct aval''_correct]
    by (auto split: prod.split)
qed

lemma inv_bval'_correct: "s : \<gamma>\<^sub>o S \<Longrightarrow> bv = bval b s \<Longrightarrow> s : \<gamma>\<^sub>o(inv_bval' b bv S)"
proof(induction b arbitrary: S bv)
  case Bc thus ?case by simp
next
  case (Not b) thus ?case by simp
next
  case (And b1 b2) thus ?case
    by simp (metis And(1) And(2) in_gamma_sup_UpI)
next
  case (Less e1 e2) thus ?case
    apply hypsubst_thin
    apply (auto split: prod.split)
    apply (metis (lifting) inv_aval'_correct aval''_correct inv_less')
    done
qed

definition "step' = Step
  (\<lambda>x e S. case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(update S x (aval' e S)))
  (\<lambda>b S. inv_bval' b True S)"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

lemma strip_step'[simp]: "strip(step' S c) = strip c"
by(simp add: step'_def)

lemma top_on_inv_aval': "\<lbrakk> top_on_opt S X;  vars e \<subseteq> -X \<rbrakk> \<Longrightarrow> top_on_opt (inv_aval' e a S) X"
by(induction e arbitrary: a S) (auto simp: Let_def split: option.splits prod.split)

lemma top_on_inv_bval': "\<lbrakk>top_on_opt S X; vars b \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (inv_bval' b r S) X"
by(induction b arbitrary: r S) (auto simp: top_on_inv_aval' top_on_sup split: prod.split)

lemma top_on_step': "top_on_acom C (- vars C) \<Longrightarrow> top_on_acom (step' \<top> C) (- vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_on_top top_on_inv_bval' split: option.split)

subsubsection "Correctness"

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: intro!: aval'_correct inv_bval'_correct in_gamma_update split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  --"transfer the pfp'"
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_inv_mono = Abs_Int_inv +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
and mono_inv_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> r \<le> r' \<Longrightarrow>
  inv_plus' r a1 a2 \<le> inv_plus' r' b1 b2"
and mono_inv_less': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow>
  inv_less' bv a1 a2 \<le> inv_less' bv b1 b2"
begin

lemma mono_aval':
  "S1 \<le> S2 \<Longrightarrow> aval' e S1 \<le> aval' e S2"
by(induction e) (auto simp: mono_plus' mono_fun)

lemma mono_aval'':
  "S1 \<le> S2 \<Longrightarrow> aval'' e S1 \<le> aval'' e S2"
apply(cases S1)
 apply simp
apply(cases S2)
 apply simp
by (simp add: mono_aval')

lemma mono_inv_aval': "r1 \<le> r2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> inv_aval' e r1 S1 \<le> inv_aval' e r2 S2"
apply(induction e arbitrary: r1 r2 S1 S2)
   apply(auto simp: test_num' Let_def inf_mono split: option.splits prod.splits)
   apply (metis mono_gamma subsetD)
  apply (metis le_bot inf_mono le_st_iff)
 apply (metis inf_mono mono_update le_st_iff)
apply(metis mono_aval'' mono_inv_plus'[simplified less_eq_prod_def] fst_conv snd_conv)
done

lemma mono_inv_bval': "S1 \<le> S2 \<Longrightarrow> inv_bval' b bv S1 \<le> inv_bval' b bv S2"
apply(induction b arbitrary: bv S1 S2)
   apply(simp)
  apply(simp)
 apply simp
 apply(metis order_trans[OF _ sup_ge1] order_trans[OF _ sup_ge2])
apply (simp split: prod.splits)
apply(metis mono_aval'' mono_inv_aval' mono_inv_less'[simplified less_eq_prod_def] fst_conv snd_conv)
done

theorem mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step) (auto simp: mono_aval' mono_inv_bval' split: option.split)

lemma mono_step'_top: "C1 \<le> C2 \<Longrightarrow> step' \<top> C1 \<le> step' \<top> C2"
by (metis mono_step' order_refl)

end

end


(* Author: Joshua Schneider, ETH Zurich *)

subsection \<open>Combined beta and eta reduction of lambda terms\<close>

theory Beta_Eta
imports "HOL-Proofs-Lambda.Eta" Joinable
begin

subsubsection \<open>Auxiliary lemmas\<close>

lemma liftn_lift_swap: "liftn n (lift t k) k = lift (liftn n t k) k"
by (induction n) simp_all

lemma subst_liftn:
  "i \<le> n + k \<and> k \<le> i \<Longrightarrow> (liftn (Suc n) s k)[t/i] = liftn n s k"
by (induction s arbitrary: i k t) auto

lemma subst_lift2[simp]: "(lift (lift t 0) 0)[x/Suc 0] = lift t 0"
proof -
  have "lift (lift t 0) 0 = lift (lift t 0) (Suc 0)" using lift_lift by simp
  thus ?thesis by simp
qed

lemma free_liftn:
  "free (liftn n t k) i = (i < k \<and> free t i \<or> k + n \<le> i \<and> free t (i - n))"
by (induction t arbitrary: k i) (auto simp add: Suc_diff_le)

subsubsection \<open>Reduction\<close>

abbreviation beta_eta :: "dB \<Rightarrow> dB \<Rightarrow> bool" (infixl "\<rightarrow>\<^sub>\<beta>\<^sub>\<eta>" 50)
where "beta_eta \<equiv> sup beta eta"

abbreviation beta_eta_reds :: "dB \<Rightarrow> dB \<Rightarrow> bool" (infixl "\<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>*" 50)
where "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t \<equiv> (beta_eta)\<^sup>*\<^sup>* s t"

lemma beta_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by auto

lemma eta_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by auto

lemma beta_reds_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<beta>\<^sup>* t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by (auto intro: rtranclp_mono[THEN predicate2D])

lemma eta_reds_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by (auto intro: rtranclp_mono[THEN predicate2D])

lemma beta_eta_appL[intro]: "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* s' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* s' \<degree> t"
by (induction set: rtranclp) (auto intro: rtranclp.rtrancl_into_rtrancl)

lemma beta_eta_appR[intro]: "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* s \<degree> t'"
by (induction set: rtranclp) (auto intro: rtranclp.rtrancl_into_rtrancl)

lemma beta_eta_abs[intro]: "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t' \<Longrightarrow> Abs t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* Abs t'"
by (induction set: rtranclp) (auto intro: rtranclp.rtrancl_into_rtrancl)

lemma beta_eta_lift: "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> lift s k \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* lift t k"
proof (induction pred: rtranclp)
  case base show ?case ..
next
  case (step y z)
  hence "lift y k \<rightarrow>\<^sub>\<beta>\<^sub>\<eta> lift z k" using lift_preserves_beta eta_lift by blast
  with step.IH show "lift s k \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* lift z k" by iprover
qed

lemma confluent_beta_eta_reds: "Joinable.confluent {(s, t). s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t}"
using confluent_beta_eta
unfolding diamond_def commute_def square_def
by (blast intro!: confluentI)

subsubsection \<open>Equivalence\<close>

text \<open>Terms are equivalent iff they can be reduced to a common term.\<close>

definition term_equiv :: "dB \<Rightarrow> dB \<Rightarrow> bool" (infixl "\<leftrightarrow>" 50)
where "term_equiv = joinablep beta_eta_reds"

lemma term_equivI:
  assumes "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u" and "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u"
  shows "s \<leftrightarrow> t"
using assms unfolding term_equiv_def by (rule joinableI[to_pred])

lemma term_equivE:
  assumes "s \<leftrightarrow> t"
  obtains u where "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u" and "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u"
using assms unfolding term_equiv_def by (rule joinableE[to_pred])

lemma reds_into_equiv[elim]: "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> s \<leftrightarrow> t"
by (blast intro: term_equivI)

lemma beta_into_equiv[elim]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule beta_into_beta_eta_reds)

lemma eta_into_equiv[elim]: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule eta_into_beta_eta_reds)

lemma beta_reds_into_equiv[elim]: "s \<rightarrow>\<^sub>\<beta>\<^sup>* t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule beta_reds_into_beta_eta_reds)

lemma eta_reds_into_equiv[elim]: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule eta_reds_into_beta_eta_reds)

lemma term_refl[iff]: "t \<leftrightarrow> t"
unfolding term_equiv_def by (blast intro: joinablep_refl reflpI)

lemma term_sym[sym]: "(s \<leftrightarrow> t) \<Longrightarrow> (t \<leftrightarrow> s)"
unfolding term_equiv_def by (rule joinable_sym[to_pred])

lemma conversep_term [simp]: "conversep (\<leftrightarrow>) = (\<leftrightarrow>)"
by (auto simp add: fun_eq_iff intro: term_sym)

lemma term_trans[trans]: "s \<leftrightarrow> t \<Longrightarrow> t \<leftrightarrow> u \<Longrightarrow> s \<leftrightarrow> u"
unfolding term_equiv_def
using trans_joinable[to_pred] trans_rtrancl[to_pred] confluent_beta_eta_reds
by (blast elim: transpE)

lemma term_beta_trans[trans]: "s \<leftrightarrow> t \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> u \<Longrightarrow> s \<leftrightarrow> u"
by (fast dest!: beta_into_beta_eta_reds intro: term_trans)

lemma term_eta_trans[trans]: "s \<leftrightarrow> t \<Longrightarrow> t \<rightarrow>\<^sub>\<eta> u \<Longrightarrow> s \<leftrightarrow> u"
by (fast dest!: eta_into_beta_eta_reds intro: term_trans)

lemma equiv_appL[intro]: "s \<leftrightarrow> s' \<Longrightarrow> s \<degree> t \<leftrightarrow> s' \<degree> t"
unfolding term_equiv_def using beta_eta_appL
by (iprover intro: joinable_subst[to_pred])

lemma equiv_appR[intro]: "t \<leftrightarrow> t' \<Longrightarrow> s \<degree> t \<leftrightarrow> s \<degree> t'"
unfolding term_equiv_def using beta_eta_appR
by (iprover intro: joinable_subst[to_pred])

lemma equiv_app: "s \<leftrightarrow> s' \<Longrightarrow> t \<leftrightarrow> t' \<Longrightarrow> s \<degree> t \<leftrightarrow> s' \<degree> t'"
by (blast intro: term_trans)

lemma equiv_abs[intro]: "t \<leftrightarrow> t' \<Longrightarrow> Abs t \<leftrightarrow> Abs t'"
unfolding term_equiv_def using beta_eta_abs
by (iprover intro: joinable_subst[to_pred])

lemma equiv_lift: "s \<leftrightarrow> t \<Longrightarrow> lift s k \<leftrightarrow> lift t k"
by (auto intro: term_equivI beta_eta_lift elim: term_equivE)

lemma equiv_liftn: "s \<leftrightarrow> t \<Longrightarrow> liftn n s k \<leftrightarrow> liftn n t k"
by (induction n) (auto intro: equiv_lift)

text \<open>Our definition is equivalent to the the symmetric and transitive closure of
  the reduction relation.\<close>

lemma equiv_eq_rtscl_reds: "term_equiv = (sup beta_eta beta_eta\<inverse>\<inverse>)\<^sup>*\<^sup>*"
unfolding term_equiv_def
using confluent_beta_eta_reds
by (rule joinable_eq_rtscl[to_pred])

end


section \<open> Executable Universe for Interaction Trees \<close>

theory Executable_Universe
  imports Code_Target_Rational "Z_Toolkit.Z_Toolkit"
begin

text \<open> Aim: To support a flexible animator that can display information about the type of data that
  channels being offered accept. \<close>

type_synonym uname = String.literal

text \<open> The following universe contains types that have direct equivalents in Haskell. \<close>

datatype utyp =
  UnitT | BoolT | IntT | RatT | StringT | EnumT "uname set" | PairT "utyp \<times> utyp" | ListT utyp

datatype uval =
  UnitV |
  BoolV (ofBoolV: bool) |
  IntV (ofIntV: integer)|
  RatV (ofRatV: rational) |
  StringV (ofStringV: String.literal) |
  EnumV (ofEnums: "uname set") (ofEnumV: "uname")  |
  PairV (ofPairV: "uval \<times> uval") |
  ListV utyp (ofListV: "uval list")

instantiation utyp :: "show"
begin

fun show_utyp :: "utyp \<Rightarrow> String.literal" where
  "show_utyp IntT = STR ''integer''"

instance ..

end

text \<open> Infer the type of a valid @{typ uval}. It's best to stick to a monomorphic type system,
  to make animation easier (i.e. each value maps to one type). \<close>

fun utyp_of :: "uval \<Rightarrow> utyp option" where
"utyp_of UnitV = Some UnitT" |
"utyp_of (BoolV _) = Some BoolT" |
"utyp_of (IntV _) = Some IntT" |
"utyp_of (RatV _) = Some RatT" |
"utyp_of (StringV _) = Some StringT" |
"utyp_of (EnumV A _) = Some (EnumT A)" |
"utyp_of (PairV p) = do { a \<leftarrow> utyp_of (fst p); b \<leftarrow> utyp_of (snd p); Some (PairT (a, b)) }" |
"utyp_of (ListV a xs) = do { as \<leftarrow> those (map utyp_of xs);
                             if (as = [] \<or> (\<forall> a'\<in> set as. a' = a)) then Some (ListT a) else None }"

abbreviation utyp_rel :: "uval \<Rightarrow> utyp \<Rightarrow> bool" (infix ":\<^sub>u" 50) where
"x :\<^sub>u t \<equiv> utyp_of x = Some t"

lemma utyp_UnitT_is_UnitV [elim]: "\<lbrakk> x :\<^sub>u UnitT; x = UnitV \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (induct x, auto)

lemma utyp_BoolT_is_BoolV [elim]: "\<lbrakk> x :\<^sub>u BoolT; \<And> n. x = BoolV n \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (induct x, auto)

lemma utyp_IntT_is_IntV [elim]: "\<lbrakk> x :\<^sub>u IntT; \<And> n. x = IntV n \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (induct x, auto)

lemma utyp_RatT_is_RatV [elim]: "\<lbrakk> x :\<^sub>u RatT; \<And> n. x = RatV n \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (induct x, auto)

lemma utyp_StringT_is_StringV [elim]: "\<lbrakk> x :\<^sub>u StringT; \<And> n. x = StringV n \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (induct x, auto)

lemma utyp_EnumT_is_EnumV [elim]: "\<lbrakk> x :\<^sub>u EnumT A; \<And> n. x = EnumV A n \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (induct x, auto)

lemma utyp_PairT_is_PairV [elim]: "\<lbrakk> x :\<^sub>u PairT (a, b); \<And> y z. \<lbrakk> x = PairV (y, z); y :\<^sub>u a; z :\<^sub>u b \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (induct x, auto)

lemma those_Some_iff: "those xs = Some ys \<longleftrightarrow> xs = map Some ys"
  by (induct xs arbitrary: ys, auto simp add: option.case_eq_if)

lemma utyp_ListT_ListV_ex: "x :\<^sub>u ListT a \<Longrightarrow> \<exists> xs. x = ListV a xs \<and> (\<forall> y\<in>set xs. y :\<^sub>u a)"
  by (induct x, auto simp add: those_Some_iff, metis (mono_tags, opaque_lifting) image_iff list.set_map)

lemma utyp_ListT_is_ListV [elim]: "\<lbrakk> x :\<^sub>u ListT a; \<And> xs. \<lbrakk> x = ListV a xs; (\<forall> y\<in>set xs. y :\<^sub>u a) \<rbrakk>  \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using utyp_ListT_ListV_ex by blast

definition uvals :: "utyp \<Rightarrow> uval set" where
"uvals a = {x. utyp_of x = Some a}"

fun default_uval :: "utyp \<Rightarrow> uval" where
"default_uval UnitT = UnitV" |
"default_uval BoolT = (BoolV False)" |
"default_uval IntT = (IntV 0)" |
"default_uval RatT = (RatV 0)" |
"default_uval StringT = (StringV STR '''')" |
"default_uval (EnumT A) = (EnumV A STR '''')" |
"default_uval (PairT (a, b)) = (PairV (default_uval a, default_uval b))" |
"default_uval (ListT a) = (ListV a [])"

lemma utyp_of_default_uval: "utyp_of (default_uval t) = Some t"
  by (induct t rule:default_uval.induct, simp_all)

text \<open> A class to declare injections between HOL types and parts of the universe. \<close>

class uvals =
  fixes to_uval :: "'a \<Rightarrow> uval" \<comment> \<open> Inject into the universe \<close>
  and from_uval :: "uval \<Rightarrow> 'a" \<comment> \<open> Project from the universe \<close>
  and utyp :: "'a itself \<Rightarrow> utyp" \<comment> \<open> Give the equivalent universe type for the HOL type \<close>
  assumes to_uval_typ [simp]: "to_uval x :\<^sub>u utyp TYPE('a)"
  and to_uval_inv [simp]: "from_uval (to_uval x) = x"
  and from_uval_inv: "\<lbrakk> v :\<^sub>u utyp TYPE('a) \<rbrakk> \<Longrightarrow> to_uval (from_uval v) = v"

lemma utyp_of_comp_to_uval: "(utyp_of \<circ> (to_uval :: 'a \<Rightarrow> uval)) = (\<lambda> _. Some (utyp TYPE('a::uvals)))"
  by (simp add: comp_def fun_eq_iff)

lemma from_after_to_uval [simp]: "from_uval \<circ> to_uval = id"
  by (simp add: comp_def fun_eq_iff)

syntax "_utyp" :: "type \<Rightarrow> logic" ("UTYPE'(_')")
translations "UTYPE('a)" == "CONST utyp TYPE('a)"

instantiation unit :: uvals
begin

definition to_uval_unit :: "unit \<Rightarrow> uval" where
  "to_uval_unit x = UnitV"

fun from_uval_unit :: "uval \<Rightarrow> unit" where
  "from_uval_unit x = ()"

definition utyp_unit :: "unit itself \<Rightarrow> utyp" where
  "utyp_unit a = UnitT"

instance
  by (intro_classes; auto simp add: to_uval_unit_def utyp_unit_def)

end

instantiation int :: uvals
begin

definition to_uval_int :: "int \<Rightarrow> uval" where
  "to_uval_int x = IntV (integer_of_int x)"

fun from_uval_int :: "uval \<Rightarrow> int" where
  "from_uval_int (IntV x) = int_of_integer x" | "from_uval_int _ = 0"

definition utyp_int :: "int itself \<Rightarrow> utyp" where
  "utyp_int a = IntT"

instance
  by (intro_classes; auto simp add: to_uval_int_def utyp_int_def)

end

instantiation integer :: uvals
begin

definition to_uval_integer :: "integer \<Rightarrow> uval" where
  "to_uval_integer x = IntV x"

fun from_uval_integer :: "uval \<Rightarrow> integer" where
  "from_uval_integer (IntV x) = x" | "from_uval_integer _ = 0"

definition utyp_integer :: "integer itself \<Rightarrow> utyp" where
  "utyp_integer a = IntT"

instance
  by (intro_classes; auto simp add: to_uval_integer_def utyp_integer_def)

end

instantiation prod :: (uvals, uvals) uvals
begin

definition to_uval_prod :: "'a \<times> 'b \<Rightarrow> uval" where
  "to_uval_prod = (\<lambda> (x, y). PairV (to_uval x, to_uval y))"

definition from_uval_prod :: "uval \<Rightarrow> 'a \<times> 'b" where
  "from_uval_prod p = map_prod from_uval from_uval (ofPairV p)"

definition utyp_prod :: "('a \<times> 'b) itself \<Rightarrow> utyp" where
  "utyp_prod a = PairT (UTYPE('a), UTYPE('b))"

instance
  by (intro_classes; auto simp add: to_uval_prod_def from_uval_prod_def utyp_prod_def prod.case_eq_if from_uval_inv)

end

lemma those_replicate_Some [simp]: "those (replicate n (Some v)) = Some (replicate n v)"
  by (induct n, simp_all)

instantiation list :: (uvals) uvals
begin

definition to_uval_list :: "'a list \<Rightarrow> uval" where
  "to_uval_list = (\<lambda> xs. ListV UTYPE('a) (map to_uval xs))"

definition from_uval_list :: "uval \<Rightarrow> 'a list" where
  "from_uval_list xs = map from_uval (ofListV xs)"

definition utyp_list :: "'a list itself \<Rightarrow> utyp" where
  "utyp_list a = ListT UTYPE('a)"

instance
  by (intro_classes, auto simp add: to_uval_list_def from_uval_list_def utyp_list_def utyp_of_comp_to_uval map_replicate_const from_uval_inv map_idI)

end

end


theory RhoCalc
imports Main
begin

section\<open>Introduction\<close>
text\<open>This is a formalization of a reflective, higher order process calculus known as the
rho-calculus and its associated logic, namespace logic.
The calculus is described by Greg Meredith in detail in the following resources:\\
\begin{itemize}
\item \href{http://www.lshift.net/downloads/ex_nihilo_logic.pdf}{Namespace Logic}
\item \href{https://arxiv.org/pdf/1307.7766v2.pdf}{Policy as Types}
\end{itemize}
The main differentiating feature of the rho-calculus is that names have structure: they are built
up out of quoted processes. Along with the ability to unquote or "drop" a name back to a process,
this gives the calulus its higher order nature.
\<close>
(*The mutually recursive datatypes of processes and names*)
datatype P = Null             ("\<^bold>0")
           | Input n n P      ("_\<leftarrow>_._." 80) (*x \<leftarrow> y. P Listen on y, write to x and then run P*)
           | Lift n P         ("_\<triangleleft>_\<triangleright>" 80) (*Outputs a process within the triangles to the name before it*)
           | Drop n           ("\<acute>_`" 80) (*Unquote/run the process*)
           | Par P P          (infixl "\<parallel>" 75)
     and n = Quote P          ("`_\<acute>")

(*Syntactic sugar for output on a channel*)
abbreviation Output :: "n \<Rightarrow> n \<Rightarrow> P" ("_[[_]]")
  where "Output x y \<equiv> x\<triangleleft>\<acute>y`\<triangleright>"

abbreviation zero :: n
  where "zero \<equiv> `\<^bold>0\<acute>"

(*Some examples*)
value "a[[b]]"
value "zero \<leftarrow> zero.\<^bold>0."
value "\<^bold>0\<parallel>\<^bold>0"
value "\<acute>zero`"
value "zero\<triangleleft>\<^bold>0\<triangleright>"
value "(c\<leftarrow>d.(e).)"

(*Creating new names by recursion over the output process*)
fun newName :: "nat \<Rightarrow> n"
  where "newName 0 = `\<^bold>0\<acute>"
       |"newName (Suc n) = `(Output (newName n) (newName n))\<acute>"

(*We use begin names with lower case and processes with upper case*)

abbreviation one :: n
  where "one \<equiv> newName 1"
abbreviation two :: n
  where "two \<equiv> newName 2"
abbreviation three :: n
  where "three \<equiv> newName 3"
abbreviation four :: n
  where "four \<equiv> newName 4"

abbreviation Zero :: P
  where "Zero \<equiv> Null"
abbreviation One :: P
  where "One \<equiv> \<acute>one`"
abbreviation Two :: P
  where "Two \<equiv> \<acute>two`"
abbreviation Three :: P
  where "Three \<equiv> \<acute>three`"
abbreviation Four :: P
  where "Four \<equiv> \<acute>four`"

section\<open>Structural congruence\<close>
text\<open>The smallest congruence we require is structural congruence, which expresses the fact that
parallelisation is commutative and associative, and running a process parallell with the Null
process is the same as running that process on its own. In Meredith's paper, this is captured by
the equations:

\begin{equation}
P | Null \equiv_C P \equiv_C Null | P
\end{equation}
\begin{equation}
P | Q & \equiv_C Q | P
\end{equation}
\begin{equation}
(P | Q) | R \equiv_C P (Q | R)
\end{equation}
While this seems fairly straight forward, trying to formalise this notion turns out to be quite
verbose. In order to do this, we create a list of processes running in parallel and then create
the structural congruence relation as a mutually recursive function comparing lists and "atomic"
processes.
\<close>
fun getList :: "P \<Rightarrow> P list"
where
  "getList \<^bold>0 = []"
 |"getList (a\<parallel>b) = ((getList a)@(getList b))"
 |"getList a = [a]"

function congru :: "P \<Rightarrow> P \<Rightarrow> bool" (infixl "=C" 42)
     and eq2 :: "P list \<Rightarrow> P list \<Rightarrow> P list \<Rightarrow> bool"
where
   "congru (a\<parallel>b) (c\<parallel>d)       = (eq2 (getList (a\<parallel>b)) (getList (c\<parallel>d)) [])"
  |"congru (x\<leftarrow>y.(a).) (xx\<leftarrow>yy.(b).) = ((a =C b) \<and> (x=xx) \<and> (y = yy))"
  |"congru (x\<triangleleft>a\<triangleright>) (y\<triangleleft>b\<triangleright>)     = ((a =C b) \<and> (x = y))"
  |"congru (\<acute>a`) (\<acute>b`)       = (a = b)"
  |"congru Null Null         = True"
  |"congru (a\<parallel>b) Null        = ((a =C Null)\<and>(b =C Null))"
  |"congru Null (a\<parallel>b)        = ((a =C Null)\<and>(b =C Null))"
  |"congru (a\<parallel>b) (c\<leftarrow>d.(e).)  = (eq2 (getList (a\<parallel>b)) ((c\<leftarrow>d.(e).)#[]) [])"
  |"congru (c\<leftarrow>d.(e).) (a\<parallel>b)  = (eq2 (getList (a\<parallel>b)) ((c\<leftarrow>d.(e).)#[]) [])"
  |"congru (a\<parallel>b) (c\<triangleleft>d\<triangleright>)      = (eq2 (getList (a\<parallel>b)) ((c\<triangleleft>d\<triangleright>)#[]) [])"
  |"congru (c\<triangleleft>d\<triangleright>) (a\<parallel>b)      = (eq2 (getList (a\<parallel>b)) ((c\<triangleleft>d\<triangleright>)#[]) [])"
  |"congru (a\<parallel>b) (\<acute>c`)       = (eq2 (getList (a\<parallel>b)) ((\<acute>c`)#[]) [])"
  |"congru (\<acute>c`) (a\<parallel>b)       = (eq2 (getList (a\<parallel>b)) ((\<acute>c`)#[]) [])"

  (* Uninteresting remaining cases *)
  |"congru (\<acute>a`) Null        = False"
  |"congru Null (\<acute>b`)        = False"
  |"congru (\<acute>a`) (_\<leftarrow>_._.)    = False"
  |"congru (_\<leftarrow>_._.) (\<acute>b`)    = False"
  |"congru (\<acute>a`) (_\<triangleleft>_\<triangleright>)      = False"
  |"congru (_\<triangleleft>_\<triangleright>) (\<acute>b`)      = False"
  |"congru (_\<triangleleft>_\<triangleright>) Null       = False"
  |"congru Null (_\<triangleleft>_\<triangleright>)       = False"
  |"congru (_\<triangleleft>_\<triangleright>) (_\<leftarrow>_._.)   = False"
  |"congru (_\<leftarrow>_._.) (_\<triangleleft>_\<triangleright>)   = False"
  |"congru (_\<leftarrow>_._.) Null     = False"
  |"congru Null (_\<leftarrow>_._.)     = False"

  |"eq2 [] [] [] = True"
  |"eq2 (x#xs) [] [] = False"
  |"eq2 [] [] (a#as) = False"
  |"eq2 (x#xs) [] (b#bs) = False"
  |"eq2 [] (b#bs) _ = False"
  |"eq2 (x#xs) (y#ys) zs = (if (x =C y) then (eq2 xs (zs@ys) []) else (eq2 (x#xs) ys (y#zs)))"
by (auto, pat_completeness)

(*
  In order to proof the termination we need to find a measure function,
  but then the problem is to prove the termination of this counting function as well.
 *)

subsection\<open>Attempts to prove termination\<close>
text\<open>We spent quite a lot of time trying to prove the termination of the above function.
What follows are some of our efforts. Although termination is ultimately not proven,
the function computes and by looking at some non-trivial examples we find that it
does what it is supposed to.
\<close>
abbreviation maxl where "maxl \<equiv> \<lambda>l. foldl (\<lambda>a.\<lambda>b. (max a b)) 0 l"

fun sdepth :: "P \<Rightarrow> nat" where
  "sdepth Null = 0"
  | "sdepth (x \<leftarrow> y . P.) = 1 + sdepth P"
  | "sdepth (x \<triangleleft> P \<triangleright>) = 1 + sdepth P"
  | "sdepth (P \<parallel> Q) = 1 + (max (sdepth P) (sdepth Q))"
  | "sdepth (\<acute>x`) = 0"

fun di::"nat \<Rightarrow> nat" where
  "di 0 = 0"
| "di (Suc(Suc v)) = (Suc (di v))"

abbreviation llength where "llength \<equiv> \<lambda>x::P list. (di ((length x)*(length x + 1)))"

function
  depth :: "P \<Rightarrow> nat"
where
  "depth \<^bold>0 = 0"
  | "depth (x \<leftarrow> y . P.) = 1 + depth P"
  | "depth (x \<triangleleft> P \<triangleright>) = 1 + depth P"
  | "depth (P \<parallel> Q) = 1 + (maxl (map depth (getList (P\<parallel>Q)))) + llength (getList (P\<parallel>Q))"
  | "depth (\<acute>x`) = 0"
apply auto
apply pat_completeness
done
termination
apply (relation "measure (\<lambda>x.(sdepth x))")
apply auto
(*proof -
  fix P Q x
  assume "x\<in> set (getList P)"
  show "sdepth x < Suc (max (sdepth P) (sdepth Q))"
  (* so close! *)*)
sorry

termination congru
apply (relation "measure (
\<lambda>x. case x of
  Inl (a,b)
    \<Rightarrow> (Max({depth a, depth b}))
| Inr (a,b,c)
    \<Rightarrow> max (maxl (map depth (a))) (maxl (map depth (b@c))) )")
apply auto
sorry

subsection\<open>Examples of structural congruence\<close>
value "((One\<parallel>Two)\<parallel>(Three\<parallel>Four))\<parallel>Null =C ((One\<parallel>Three)\<parallel>(Two\<parallel>Four))"
value "(((zero\<leftarrow>zero.\<^bold>0.) \<parallel> \<^bold>0) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) =C (((zero\<leftarrow>zero.\<^bold>0.) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) \<parallel> \<^bold>0)"
value "(( \<^bold>0 \<parallel> (n\<^sub>1\<triangleleft>\<^bold>0 \<parallel> \<^bold>0\<triangleright>)) =C (n\<^sub>1\<triangleleft>\<^bold>0\<triangleright>))"

theorem example:
shows "(((zero\<leftarrow>zero.\<^bold>0.) \<parallel> \<^bold>0) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) =C (((zero\<leftarrow>zero.\<^bold>0.) \<parallel> (zero\<leftarrow>zero.\<^bold>0.)) \<parallel> \<^bold>0)"
by simp

value "getList ((a \<parallel> b) \<parallel> c)"

declare [[ smt_timeout = 20 ]]

subsection\<open>Structural congruence is an equivalence relation\<close>
text\<open>Proofs unfortunately not completeted\<close>
abbreviation reflexive
  where "reflexive \<equiv> \<lambda> R. \<forall> r. R r r"
abbreviation transitive
  where "transitive \<equiv> \<lambda> R. \<forall> x. \<forall> y. \<forall> z. R x y \<and> R y z \<longrightarrow> R x z"
abbreviation symmetric
  where "symmetric \<equiv> \<lambda> R. \<forall> x. \<forall> y. R x y \<longrightarrow> R y x"

theorem congruReflexive:
  shows "reflexive congru"
sorry

theorem congruTransitive:
  shows "transitive congru"
sorry

theorem congruSymmetric:
  shows "symmetric congru"
sorry

theorem eqReflexive:
  shows "(eq2 a a [])"
sorry

theorem eqSymmetric:
  shows "\<forall> a b. (eq2 a b [] \<longrightarrow> eq2 b a [])"
sorry

theorem eqTransitive:
  shows "\<forall> a b c. (((eq2 a b []) \<and> (eq2 b c [])) \<longrightarrow> (eq2 a c []))"
sorry

theorem parAssoc:
  shows "((a\<parallel>b)\<parallel>c) =C (a\<parallel>(b\<parallel>c))"
using congruReflexive eqReflexive by (induction a, auto)

theorem parCommutative:
  shows "a\<parallel>b =C b\<parallel>a"
using congruReflexive eqReflexive  apply (induction a rule: P.induct)
apply simp
apply (induction b rule: P.induct, auto)
using congruSymmetric apply blast
sorry

theorem zeroLeft:
  shows "(Null \<parallel> a) =C a"
using congruReflexive apply (induction a rule: P.induct, auto)
apply (simp add: congruReflexive)
by (simp add: eqReflexive)

theorem zeroRight:
  shows "(a \<parallel> Null) =C a"
apply (induction a rule: P.induct, auto)
apply (simp add: congruReflexive)
apply (simp add: congruReflexive)
by (simp add: eqReflexive)

end