theory RR2_Infinite
  imports RRn_Automata Tree_Automata_Pumping
begin

lemma map_ta_rule_id [simp]: "map_ta_rule f id r = (r_root r) (map f (r_lhs_states r)) \<rightarrow> (f (r_rhs r))" for f r
  by (simp add: ta_rule.expand ta_rule.map_sel(1 - 3))

(* Finitness/Infinitness facts *)

lemma no_upper_bound_infinite:
  assumes "\<forall>(n::nat). \<exists>t \<in> S. n < f t"
  shows "infinite S"
proof (rule ccontr, simp)
  assume "finite S"
  then obtain n where "n = Max (f ` S)" "\<forall> t \<in> S. f t \<le> n" by auto
  then show False using assms linorder_not_le by blast
qed

lemma set_constr_finite:
  assumes "finite F"
  shows "finite {h x | x. x \<in> F \<and> P x}" using assms
  by (induct) auto

lemma bounded_depth_finite:
  assumes fin_F: "finite \<F>" and "\<Union> (funas_term ` S) \<subseteq> \<F>"
    and "\<forall>t \<in> S. depth t \<le> n" and "\<forall>t \<in> S. ground t"
  shows "finite S" using assms(2-)
proof (induction n arbitrary: S)
  case 0
  {fix t assume elem: "t \<in> S"
    from 0 have "depth t = 0" "ground t" "funas_term t \<subseteq> \<F>" using elem by auto
    then have "\<exists> f. (f, 0) \<in> \<F> \<and> t = Fun f []" by (cases t rule: depth.cases) auto}
  then have "S \<subseteq> {Fun f [] |f . (f, 0) \<in> \<F>}" by (auto simp add: image_iff)
  from finite_subset[OF this] show ?case
    using set_constr_finite[OF fin_F, of "\<lambda> (f, n). Fun f []" "\<lambda> x. snd x = 0"]
    by auto
next
  case (Suc n)
  from Suc obtain S' where
    S: "S' = {t :: ('a, 'b) term . ground t \<and> funas_term t \<subseteq> \<F> \<and> depth t \<le> n}" "finite S'"
    by (auto simp add: SUP_le_iff)
  then obtain L F where L: "set L = S'" "set F = \<F>" using fin_F by (meson finite_list)
  let ?Sn = "{Fun f ts | f ts. (f, length ts) \<in> \<F> \<and> set ts \<subseteq> S'}"
  let ?Ln = "concat (map (\<lambda> (f, n). map (\<lambda> ts. Fun f ts) (List.n_lists n L)) F)"
  {fix t assume elem: "t \<in> S"
    from Suc have "depth t \<le> Suc n" "ground t" "funas_term t \<subseteq> \<F>" using elem by auto
    then have "funas_term t \<subseteq> \<F> \<and> (\<forall> x \<in> set (args t). depth x \<le> n) \<and> ground t"
      by (cases t rule: depth.cases) auto
    then have "t \<in> ?Sn \<union> S'"
      using S by (cases t) auto} note sub = this
  {fix t assume elem: "t \<in> ?Sn"
    then obtain f ts where [simp]: "t = Fun f ts" and invar: "(f, length ts) \<in> \<F>" "set ts \<subseteq> S'"
      by blast
    then have "Fun f ts \<in> set (map (\<lambda> ts. Fun f ts) (List.n_lists (length ts) L))" using L(1)
      by (auto simp: image_iff set_n_lists)
    then have "t \<in> set ?Ln" using invar(1) L(2) by auto}
  from this sub have sub: "?Sn \<subseteq> set ?Ln" "S \<subseteq> ?Sn \<union> S'" by blast+
  from finite_subset[OF sub(1)] finite_subset[OF sub(2)] finite_UnI[of ?Sn, OF _ S(2)]
  show ?case by blast
qed

lemma infinite_imageD:
  "infinite (f ` S) \<Longrightarrow> inj_on f S \<Longrightarrow> infinite S"
  by blast

lemma infinite_imageD2:
  "infinite (f ` S) \<Longrightarrow> inj f \<Longrightarrow> infinite S"
  by blast

lemma infinite_inj_image_infinite:
  assumes "infinite S" and "inj_on f S"
  shows "infinite (f ` S)"
  using assms finite_image_iff by blast

(*The following lemma tells us that number of terms greater than a certain depth are infinite*)
lemma infinte_no_depth_limit:
  assumes "infinite S" and "finite \<F>"
    and "\<forall>t \<in> S. funas_term t \<subseteq> \<F>" and "\<forall>t \<in> S. ground t"
  shows "\<forall>(n::nat). \<exists>t \<in> S. n < (depth t)"
proof(rule allI, rule ccontr)
  fix n::nat
  assume "\<not> (\<exists>t \<in> S. (depth t) >  n)"
  hence "\<forall>t \<in> S. depth t \<le> n" by auto
  from bounded_depth_finite[OF assms(2) _ this] show False using assms
    by auto
qed

lemma depth_gterm_conv:
  "depth (term_of_gterm t) = depth (term_of_gterm t)"
  by (metis leD nat_neq_iff poss_gposs_conv poss_length_bounded_by_depth poss_length_depth)

lemma funs_term_ctxt [simp]:
  "funs_term C\<langle>s\<rangle> = funs_ctxt C \<union> funs_term s"
  by (induct C) auto

lemma pigeonhole_ta_infinit_terms:
  fixes t ::"'f gterm" and \<A> :: "('q, 'f) ta"
  defines "t' \<equiv> term_of_gterm t :: ('f, 'q) term"
  assumes "fcard (\<Q> \<A>) < depth t'" and "q |\<in>| gta_der \<A> t" and "P (funas_gterm t)"
  shows "infinite {t . q |\<in>| gta_der \<A> t \<and> P (funas_gterm t)}"
proof -
  from pigeonhole_tree_automata[OF _ assms(3)[unfolded gta_der_def]] assms(2,4)
  obtain C C2 s v p where ctxt: "C2 \<noteq> \<box>" "C\<langle>s\<rangle> = t'" "C2\<langle>v\<rangle> = s" and
    loop: "p |\<in>| ta_der \<A> v" "p |\<in>| ta_der \<A> C2\<langle>Var p\<rangle>" "q |\<in>| ta_der \<A> C\<langle>Var p\<rangle>"
    unfolding assms(1) by auto
  let ?terms = "\<lambda> n. C\<langle>(C2 ^n)\<langle>v\<rangle>\<rangle>" let ?inner = "\<lambda> n. (C2 ^n)\<langle>v\<rangle>"
  have gr: "ground_ctxt C2" "ground_ctxt C" "ground v"
    using arg_cong[OF ctxt(2), of ground] unfolding ctxt(3)[symmetric] assms(1)
    by fastforce+
  moreover have funas: "funas_term (?terms (Suc n)) = funas_term t'" for n
    unfolding ctxt(2, 3)[symmetric] using ctxt_comp_n_pres_funas by auto
  moreover have der: "q |\<in>| ta_der \<A> (?terms (Suc n))" for n using loop
    by (meson ta_der_ctxt ta_der_ctxt_n_loop)
  moreover have "n < depth (?terms (Suc n))" for n
    by (meson ctxt(1) ctxt_comp_n_lower_bound depth_ctxt_less_eq less_le_trans)
  ultimately have "q |\<in>| ta_der \<A> (?terms (Suc n)) \<and> ground (?terms (Suc n)) \<and>
    P (funas_term (?terms (Suc n))) \<and> n < depth (?terms (Suc n))" for n using assms(4)
    by (auto simp: assms(1) funas_term_of_gterm_conv)
  then have inf: "infinite {t. q |\<in>| ta_der \<A> t \<and> ground t \<and> P (funas_term t)}"
    by (intro no_upper_bound_infinite[of _ depth]) blast
  have inj: "inj_on gterm_of_term {t. q |\<in>| ta_der \<A> t \<and> ground t \<and> P (funas_term t)}"
    by (intro gterm_of_term_inj) simp
  show ?thesis
    by (intro infinite_super[OF _ infinite_inj_image_infinite[OF inf inj]])
       (auto simp: image_def gta_der_def funas_gterm_gterm_of_term)
qed

lemma gterm_to_None_Some_funas [simp]:
  "funas_gterm (gterm_to_None_Some t) \<subseteq> (\<lambda> (f, n). ((None, Some f), n)) ` \<F> \<longleftrightarrow> funas_gterm t \<subseteq> \<F>"
  by (induct t) (auto simp: funas_gterm_def, blast)

lemma funas_gterm_bot_some_decomp:
  assumes "funas_gterm s \<subseteq> (\<lambda> (f, n). ((None, Some f), n)) ` \<F>"
  shows "\<exists> t. gterm_to_None_Some t = s \<and> funas_gterm t \<subseteq> \<F>" using assms
proof (induct s)
  case (GFun f ts)
  from GFun(1)[OF nth_mem] obtain ss where l: "length ss = length ts \<and> (\<forall>i<length ts. gterm_to_None_Some (ss ! i) = ts ! i)"
    using Ex_list_of_length_P[of "length ts" "\<lambda> s i. gterm_to_None_Some s = ts ! i"] GFun(2-)
    by (auto simp: funas_gterm_def) (meson UN_subset_iff nth_mem)
  then have "i < length ss \<Longrightarrow> funas_gterm (ss ! i) \<subseteq> \<F>" for i using GFun(2)
    by (auto simp: UN_subset_iff) (smt (z3) gterm_to_None_Some_funas nth_mem subsetD)
  then show ?case using GFun(2-) l
    by (cases f) (force simp: map_nth_eq_conv UN_subset_iff dest!: in_set_idx intro!: exI[of _ "GFun (the (snd f)) ss"])
qed

(* Definition INF, Q_infinity and automata construction *)

definition "Inf_branching_terms \<R> \<F> = {t . infinite {u. (t, u) \<in> \<R> \<and> funas_gterm u \<subseteq> fset \<F>} \<and> funas_gterm t \<subseteq> fset \<F>}"

definition "Q_infty \<A> \<F> = {|q | q. infinite {t | t. funas_gterm t \<subseteq> fset \<F> \<and> q |\<in>| ta_der \<A> (term_of_gterm (gterm_to_None_Some t))}|}"

lemma Q_infty_fmember:
  "q |\<in>| Q_infty \<A> \<F> \<longleftrightarrow> infinite {t | t. funas_gterm t \<subseteq> fset \<F> \<and> q |\<in>| ta_der \<A> (term_of_gterm (gterm_to_None_Some t))}"
proof -
  have "{q | q. infinite {t | t. funas_gterm t \<subseteq> fset \<F> \<and> q |\<in>| ta_der \<A> (term_of_gterm (gterm_to_None_Some t))}} \<subseteq> fset (\<Q> \<A>)"
    using not_finite_existsD notin_fset by fastforce
  from finite_subset[OF this] show ?thesis
    by (auto simp: Q_infty_def)
qed

abbreviation q_inf_dash_intro_rules where
  "q_inf_dash_intro_rules Q r \<equiv> if (r_rhs r) |\<in>| Q \<and> fst (r_root r) = None then {|(r_root r) (map CInl (r_lhs_states r)) \<rightarrow> CInr (r_rhs r)|} else {||}"

abbreviation args :: "'a list \<Rightarrow> nat \<Rightarrow> ('a + 'a) list" where
  "args \<equiv> \<lambda> qs i. map CInl (take i qs) @ CInr (qs ! i) # map CInl (drop (Suc i) qs)"

abbreviation q_inf_dash_closure_rules :: "('q, 'f) ta_rule \<Rightarrow> ('q + 'q, 'f) ta_rule list" where
  "q_inf_dash_closure_rules r \<equiv> (let (f, qs, q) = (r_root r, r_lhs_states r, r_rhs r) in
   (map (\<lambda> i. f (args qs i) \<rightarrow> CInr q) [0 ..< length qs]))"

definition Inf_automata :: "('q, 'f option \<times> 'f option) ta \<Rightarrow> 'q fset \<Rightarrow> ('q + 'q, 'f option \<times> 'f option) ta" where
  "Inf_automata \<A> Q = TA
  (( |\<Union>| (q_inf_dash_intro_rules Q |`| rules \<A>)) |\<union>| ( |\<Union>| ((fset_of_list \<circ> q_inf_dash_closure_rules) |`| rules \<A>)) |\<union>|
   map_ta_rule CInl id |`| rules \<A>) (map_both Inl |`| eps \<A> |\<union>| map_both CInr |`| eps \<A>)"

definition Inf_reg where
  "Inf_reg \<A> Q = Reg (CInr |`| fin \<A>) (Inf_automata (ta \<A>) Q)"

lemma Inr_Inl_rel_comp:
  "map_both CInr |`| S |O| map_both CInl |`| S = {||}" by auto

lemmas eps_split = ftrancl_Un2_separatorE[OF Inr_Inl_rel_comp]

lemma Inf_automata_eps_simp [simp]:
  shows "(map_both Inl |`| eps \<A> |\<union>| map_both CInr |`| eps \<A>)|\<^sup>+| =
      (map_both CInl |`| eps \<A>)|\<^sup>+| |\<union>| (map_both CInr |`| eps \<A>)|\<^sup>+|"
proof -
  {fix x y z assume "(x, y) |\<in>| (map_both CInl |`| eps \<A>)|\<^sup>+|"
    "(y, z) |\<in>| (map_both CInr |`| eps \<A>)|\<^sup>+|"
    then have False
      by (metis Inl_Inr_False eps_statesI(1, 2) eps_states_image fimageE ftranclD ftranclD2)}
  then show ?thesis by (auto simp: Inf_automata_def eps_split)
qed

lemma map_both_CInl_ftrancl_conv:
  "(map_both CInl |`| eps \<A>)|\<^sup>+| = map_both CInl |`| (eps \<A>)|\<^sup>+|"
  by (intro ftrancl_map_both_fsubset) (auto simp: finj_CInl_CInr)

lemma map_both_CInr_ftrancl_conv:
  "(map_both CInr |`| eps \<A>)|\<^sup>+| = map_both CInr |`| (eps \<A>)|\<^sup>+|"
  by (intro ftrancl_map_both_fsubset) (auto simp: finj_CInl_CInr)

lemmas map_both_ftrancl_conv = map_both_CInl_ftrancl_conv map_both_CInr_ftrancl_conv

lemma Inf_automata_Inl_to_eps [simp]:
  "(CInl p, CInl q) |\<in>| (map_both CInl |`| eps \<A>)|\<^sup>+| \<longleftrightarrow> (p, q) |\<in>| (eps \<A>)|\<^sup>+|"
  "(CInr p, CInr q) |\<in>| (map_both CInr |`| eps \<A>)|\<^sup>+| \<longleftrightarrow> (p, q) |\<in>| (eps \<A>)|\<^sup>+|"
  "(CInl q, CInl p) |\<in>| (map_both CInr |`| eps \<A>)|\<^sup>+| \<longleftrightarrow> False"
  "(CInr q, CInr p) |\<in>| (map_both CInl |`| eps \<A>)|\<^sup>+| \<longleftrightarrow> False"
  by (auto simp: map_both_ftrancl_conv dest: fmap_prod_fimageI)

lemma Inl_eps_Inr:
  "(CInl q, CInl p) |\<in>| (eps (Inf_automata \<A> Q))|\<^sup>+| \<longleftrightarrow> (CInr q, CInr p) |\<in>| (eps (Inf_automata \<A> Q))|\<^sup>+|"
  by (auto simp: Inf_automata_def)

lemma Inr_rhs_eps_Inr_lhs:
  assumes "(q, CInr p) |\<in>| (eps (Inf_automata \<A> Q))|\<^sup>+|"
  obtains q' where "q = CInr q'" using assms ftrancl_map_both_fsubset[OF finj_CInl_CInr(1)]
  by (cases q) (auto simp: Inf_automata_def map_both_ftrancl_conv)

lemma Inl_rhs_eps_Inl_lhs:
  assumes "(q, CInl p) |\<in>| (eps (Inf_automata \<A> Q))|\<^sup>+|"
  obtains q' where "q = CInl q'" using assms
  by (cases q) (auto simp: Inf_automata_def map_both_ftrancl_conv)

lemma Inf_automata_eps [simp]:
  "(CInl q, CInr p) |\<in>| (eps (Inf_automata \<A> Q))|\<^sup>+| \<longleftrightarrow> False"
  "(CInr q, CInl p) |\<in>| (eps (Inf_automata \<A> Q))|\<^sup>+| \<longleftrightarrow> False"
  by (auto elim: Inr_rhs_eps_Inr_lhs Inl_rhs_eps_Inl_lhs)

lemma Inl_A_res_Inf_automata:
  "ta_der (fmap_states_ta CInl \<A>) t |\<subseteq>| ta_der (Inf_automata \<A> Q) t"
  by (intro ta_der_mono) (auto simp: Inf_automata_def rev_fimage_eqI fmap_states_ta_def')

lemma Inl_res_A_res_Inf_automata:
  "CInl |`| ta_der \<A> (term_of_gterm t) |\<subseteq>| ta_der (Inf_automata \<A> Q) (term_of_gterm t)"
  by (intro fsubset_trans[OF ta_der_fmap_states_ta_mono[of CInl \<A> t]]) (auto simp: Inl_A_res_Inf_automata)

lemma r_rhs_CInl_args_A_rule:
  assumes "f qs \<rightarrow> CInl q |\<in>| rules (Inf_automata \<A> Q)"
  obtains qs' where "qs = map CInl qs'" "f qs' \<rightarrow> q |\<in>| rules \<A>" using assms
  by (auto simp: Inf_automata_def split!: if_splits)

lemma A_rule_to_dash_closure:
  assumes "f qs \<rightarrow> q |\<in>| rules \<A>" and "i < length qs"
  shows "f (args qs i) \<rightarrow> CInr q |\<in>| rules (Inf_automata \<A> Q)"
  using assms by (auto simp add: Inf_automata_def fimage_iff fBall_def upt_fset intro!: fBexI[OF _ assms(1)])

lemma Inf_automata_reach_to_dash_reach:
  assumes "CInl p |\<in>| ta_der (Inf_automata \<A> Q) C\<langle>Var (CInl q)\<rangle>"
  shows "CInr p |\<in>| ta_der (Inf_automata \<A> Q) C\<langle>Var (CInr q)\<rangle>" (is "_ |\<in>| ta_der ?A _")
  using assms
proof (induct C arbitrary: p)
  case (More f ss C ts)
  from More(2) obtain qs q' where
    rule: "f qs \<rightarrow> q' |\<in>| rules ?A" "length qs = Suc (length ss + length ts)" and
    eps: "q' = CInl p \<or> (q', CInl p) |\<in>| (eps ?A)|\<^sup>+|" and
    reach: "\<forall> i <  Suc (length ss + length ts). qs ! i |\<in>| ta_der ?A ((ss @ C\<langle>Var (CInl q)\<rangle> # ts) ! i)"
    by auto
  from eps obtain q'' where [simp]: "q' = CInl q''"
    by (cases q') (auto simp add: Inf_automata_def eps_split elim: ftranclE converse_ftranclE)
  from rule obtain qs' where args: "qs = map CInl qs'" "f qs' \<rightarrow> q'' |\<in>| rules \<A>"
    using r_rhs_CInl_args_A_rule by (metis \<open>q' = CInl q''\<close>)
  then have "CInl (qs' ! length ss) |\<in>| ta_der (Inf_automata \<A> Q) C\<langle>Var (CInl q)\<rangle>" using reach
    by (auto simp: all_Suc_conv nth_append_Cons) (metis length_map less_add_Suc1 local.rule(2) nth_append_length nth_map reach)
  from More(1)[OF this] More(2) show ?case
    using rule args eps reach A_rule_to_dash_closure[OF args(2), of "length ss" Q]
    by (auto simp: Inl_eps_Inr id_take_nth_drop all_Suc_conv
        intro!: exI[of _ "CInr q''"] exI[of _ "map CInl (take (length ss) qs') @ CInr (qs' ! length ss) # map CInl (drop (Suc (length ss)) qs')"])
      (auto simp: nth_append_Cons min_def)
qed (auto simp: Inf_automata_def)

lemma Inf_automata_dashI:
  assumes "run \<A> r (gterm_to_None_Some t)" and "ex_rule_state r |\<in>| Q"
  shows "CInr (ex_rule_state r) |\<in>| gta_der (Inf_automata \<A> Q) (gterm_to_None_Some t)"
proof (cases t)
  case [simp]: (GFun f ts)
  from run_root_rule[OF assms(1)] run_argsD[OF assms(1)] have
    rule: "TA_rule (None, Some f) (map ex_comp_state (gargs r)) (ex_rule_state r) |\<in>| rules \<A>" "length (gargs r) = length ts" and
    reach: "\<forall> i < length ts. ex_comp_state (gargs r ! i) |\<in>| ta_der \<A> (term_of_gterm (gterm_to_None_Some (ts  ! i)))"
    by (auto intro!: run_to_comp_st_gta_der[unfolded gta_der_def comp_def])
  from rule assms(2) have "(None, Some f) (map (CInl \<circ> ex_comp_state) (gargs r)) \<rightarrow> CInr (ex_rule_state r) |\<in>| rules  (Inf_automata \<A> Q)"
    by (auto simp: Inf_automata_def) force
  then show ?thesis using reach rule Inl_res_A_res_Inf_automata[of \<A> "gterm_to_None_Some (ts ! i)" Q for i]
    by (auto simp: gta_der_def intro!: exI[of _ "CInr (ex_rule_state r)"]  exI[of _ "map (CInl \<circ> ex_comp_state) (gargs r)"])
        blast
qed

lemma Inf_automata_dash_reach_to_reach:
  assumes "p |\<in>| ta_der (Inf_automata \<A> Q) t" (is "_ |\<in>| ta_der ?A _")
  shows "remove_sum p |\<in>| ta_der \<A> (map_vars_term remove_sum t)" using assms
proof (induct t arbitrary: p)
  case (Var x) then show ?case
    by (cases p; cases x) (auto simp: Inf_automata_def ftrancl_map_both map_both_ftrancl_conv)
next
  case (Fun f ss)
  from Fun(2) obtain qs q' where
    rule: "f qs \<rightarrow> q' |\<in>| rules ?A" "length qs = length ss" and
    eps: "q' = p \<or> (q', p) |\<in>| (eps ?A)|\<^sup>+|" and
    reach: "\<forall> i <  length ss. qs ! i |\<in>| ta_der ?A (ss ! i)" by auto
  from rule have r: "f (map (remove_sum) qs) \<rightarrow> (remove_sum q') |\<in>| rules \<A>"
    by (auto simp: comp_def Inf_automata_def min_def id_take_nth_drop[symmetric] upt_fset
             simp flip: drop_map take_map split!: if_splits)
  moreover have "remove_sum q' = remove_sum p \<or> (remove_sum q', remove_sum p) |\<in>| (eps \<A>)|\<^sup>+|" using eps
    by (cases "is_Inl q'"; cases "is_Inl p") (auto elim!: is_InlE is_InrE, auto simp: Inf_automata_def)
  ultimately show ?case using reach rule(2) Fun(1)[OF nth_mem, of i "qs ! i" for i]
    by auto (metis (mono_tags, lifting) length_map map_nth_eq_conv)+
qed

lemma depth_poss_split:
  assumes "Suc (depth (term_of_gterm t) + n) < depth (term_of_gterm u)"
  shows "\<exists> p q. p @ q \<in> gposs u \<and> n < length q \<and> p \<notin> gposs t"
proof -
  from poss_length_depth obtain p m where p: "p \<in> gposs u" "length p = m" "depth (term_of_gterm u) = m"
    using poss_gposs_conv by blast
  then obtain m' where dt: "depth (term_of_gterm t) = m'" by blast
  from assms dt p(2, 3) have "length (take (Suc m') p) = Suc m'"
    by (metis Suc_leI depth_gterm_conv length_take less_add_Suc1 less_imp_le_nat less_le_trans min.absorb2)
  then have nt: "take (Suc m') p \<notin> gposs t" using poss_length_bounded_by_depth dt depth_gterm_conv
    by (metis Suc_n_not_le_n gposs_to_poss)
  moreover have "n < length (drop (Suc m') p)" using assms depth_gterm_conv dt p(2-)
    by (metis add_Suc diff_diff_left length_drop zero_less_diff)
  ultimately show ?thesis by (metis append_take_drop_id p(1))
qed

lemma Inf_to_automata:
  assumes "RR2_spec \<A> \<R>" and "t \<in> Inf_branching_terms \<R> \<F>"
  shows "\<exists> u. gpair t u \<in> \<L> (Inf_reg \<A> (Q_infty (ta \<A>) \<F>))" (is "\<exists> u. gpair t u \<in> \<L> ?B")
proof -
  let ?A = "Inf_automata (ta \<A>) (Q_infty (ta \<A>) \<F>)"
  let ?t_of_g = "\<lambda> t. term_of_gterm t :: ('b, 'a) term"
  obtain n where depth_card: "depth (?t_of_g t) + fcard (\<Q> (ta \<A>)) < n" by auto
  from assms(1, 2) have fin: "infinite {u. gpair t u \<in> \<L> \<A> \<and> funas_gterm u \<subseteq> fset \<F>}"
    by (auto simp: RR2_spec_def Inf_branching_terms_def)
  from infinte_no_depth_limit[of "?t_of_g ` {u. gpair t u \<in> \<L> \<A> \<and> funas_gterm u \<subseteq> fset \<F>}" "fset \<F>"] this
  have "\<forall> n. \<exists>t \<in> ?t_of_g ` {u. gpair t u \<in> \<L> \<A> \<and> funas_gterm u \<subseteq> fset \<F>}. n < depth t"
    by (simp add: infinite_inj_image_infinite[OF fin] funas_term_of_gterm_conv inj_term_of_gterm)
  from this depth_card obtain u where funas: "funas_gterm u \<subseteq> fset \<F>" and
    depth: "Suc n < depth (?t_of_g u)" and lang: "gpair t u \<in> \<L> \<A>" by auto
  have "Suc (depth (term_of_gterm t) + fcard (\<Q> (ta \<A>))) < depth (term_of_gterm u)"
    using depth depth_card by (metis Suc_less_eq2 depth_gterm_conv less_trans)
  from depth_poss_split[OF this] obtain p q where
    pos: "p @ q \<in> gposs u" "p \<notin> gposs t" and card: "fcard (\<Q> (ta \<A>)) < length q" by auto
  then have gp: "gsubt_at (gpair t u) p = gterm_to_None_Some (gsubt_at u p)"
    using subst_at_gpair_nt_poss_None_Some[of p] by force
  from lang obtain r where r: "run (ta \<A>) r (gpair t u)" "ex_comp_state r |\<in>| fin \<A>"
    unfolding \<L>_def gta_lang_def by (fastforce dest: gta_der_to_run)
  from pos have p_gtu: "p \<in> gposs (gpair t u)" and pu: "p \<in> gposs u"
    using not_gposs_append by auto
  have qinf: "ex_rule_state (gsubt_at r p) |\<in>| Q_infty (ta \<A>) \<F>"
    using funas_gterm_gsubt_at_subseteq[OF pu] funas card
    unfolding Q_infty_fmember gta_der_def[symmetric]
    by (intro infinite_super[THEN infinite_imageD2[OF _ inj_gterm_to_None_Some],
     OF _ pigeonhole_ta_infinit_terms[of "ta \<A>" "gsubt_at (gpair t u) p" _
     "\<lambda> t. t \<subseteq> (\<lambda>(f, n). ((None, Some f), n)) ` fset \<F>",
     OF _ run_to_gta_der_gsubt_at(1)[OF r(1) p_gtu]]])
        (auto simp: poss_length_bounded_by_depth[of q] image_iff gp less_le_trans
                   pos(1) poss_gposs_conv pu dest!: funas_gterm_bot_some_decomp)
  from Inf_automata_dashI[OF run_gsubt_cl[OF r(1) p_gtu, unfolded gp] qinf]
  have dashI: "CInr (ex_rule_state (gsubt_at r p)) |\<in>| gta_der (Inf_automata (ta \<A>) (Q_infty (ta \<A>) \<F>)) (gsubt_at (gpair t u) p)"
    unfolding gp[symmetric] .
  have "CInl (ex_comp_state r) |\<in>| ta_der ?A (ctxt_at_pos (term_of_gterm (gpair t u)) p)\<langle>Var (CInl (ex_rule_state (gsubt_at r p)))\<rangle>"
    using ta_der_fmap_states_ta[OF run_ta_der_ctxt_split2[OF r(1) p_gtu], of CInl, THEN fsubsetD[OF Inl_A_res_Inf_automata]]
    unfolding replace_term_at_replace_at_conv[OF gposs_to_poss[OF p_gtu]]
    by (auto simp: gterm.map_ident simp flip: map_term_replace_at_dist[OF gposs_to_poss[OF p_gtu]])
  from ta_der_ctxt[OF dashI[unfolded gta_der_def] Inf_automata_reach_to_dash_reach[OF this]]
  have "CInr (ex_comp_state r) |\<in>| gta_der (Inf_automata (ta \<A>) (Q_infty (ta \<A>) \<F>)) (gpair t u)"
    unfolding replace_term_at_replace_at_conv[OF gposs_to_poss[OF p_gtu]]
    unfolding replace_gterm_conv[OF p_gtu]
    by (auto simp: gta_der_def)
  moreover from r(2) have "CInr (ex_comp_state r) |\<in>| fin (Inf_reg \<A> (Q_infty (ta \<A>) \<F>))"
    by (auto simp: Inf_reg_def)
  ultimately show ?thesis using r(2)
    by (auto simp: \<L>_def gta_der_def Inf_reg_def intro: exI[of _ u])
qed

lemma CInr_Inf_automata_to_q_state:
  assumes "CInr p |\<in>| ta_der (Inf_automata \<A> Q) t" and "ground t"
  shows "\<exists> C s q. C\<langle>s\<rangle> = t \<and> CInr q |\<in>| ta_der (Inf_automata \<A> Q) s \<and> q |\<in>| Q \<and>
    CInr p |\<in>| ta_der (Inf_automata \<A> Q) C\<langle>Var (CInr q)\<rangle> \<and>
    (fst \<circ> fst \<circ> the \<circ> root) s = None" using assms
proof (induct t arbitrary: p)
  case (Fun f ts)
  let ?A = "(Inf_automata \<A> Q)"
  from Fun(2) obtain qs q' where
    rule: "f qs \<rightarrow> CInr q' |\<in>| rules ?A" "length qs = length ts" and
    eps: "q' = p \<or> (CInr q', CInr p) |\<in>| (eps ?A)|\<^sup>+|" and
    reach: "\<forall> i < length ts. qs ! i |\<in>| ta_der ?A (ts ! i)"
    by auto (metis Inr_rhs_eps_Inr_lhs)
  consider (a) "\<And> i. i < length qs \<Longrightarrow> \<exists> q''. qs ! i = CInl q''" | (b) "\<exists> i < length qs. \<exists> q''. qs ! i = CInr q''"
    by (meson remove_sum.cases)
  then show ?case
  proof cases
    case a
    then have "f qs \<rightarrow> CInr q' |\<in>| |\<Union>| (q_inf_dash_intro_rules Q |`| rules \<A>)" using rule
      by (auto simp: Inf_automata_def min_def upt_fset split!: if_splits)
         (metis (no_types, lifting) Inl_Inr_False Suc_pred append_eq_append_conv id_take_nth_drop
               length_Cons length_drop length_greater_0_conv length_map
               less_nat_zero_code list.size(3) nth_append_length rule(2))
   then show ?thesis using reach eps rule
     by (intro exI[of _ Hole] exI[of _ "Fun f ts"] exI[of _ q'])
         (auto split!: if_splits)
  next
    case b
    then obtain i q'' where b: "i < length ts" "qs ! i = CInr q''" using rule(2) by auto
    then have "CInr q'' |\<in>| ta_der ?A (ts ! i)" using rule(2) reach by auto
    from Fun(3) Fun(1)[OF nth_mem, OF b(1) this] b rule(2) obtain C s q''' where
      ctxt: "C\<langle>s\<rangle> = ts ! i" and
      qinf: "CInr q''' |\<in>| ta_der (Inf_automata \<A> Q) s \<and> q''' |\<in>| Q" and
      reach2: "CInr q'' |\<in>| ta_der (Inf_automata \<A> Q) C\<langle>Var (CInr q''')\<rangle>" and
      "(fst \<circ> fst \<circ> the \<circ> root) s = None"
      by auto
    then show ?thesis using rule eps reach ctxt qinf reach2 b(1) b(2)[symmetric]
      by (auto simp: min_def nth_append_Cons simp flip: map_append id_take_nth_drop[OF b(1)]
        intro!: exI[of _ "More f (take i ts) C (drop (Suc i) ts)"] exI[of _ "s"] exI[of _ "q'''"] exI[of _ "CInr q'"] exI[of _ "qs"])
  qed
qed auto

lemma aux_lemma:
  assumes "RR2_spec \<A> \<R>" and "\<R> \<subseteq> \<T>\<^sub>G (fset \<F>) \<times> \<T>\<^sub>G (fset \<F>)"
    and "infinite {u | u. gpair t u \<in> \<L> \<A>}"
  shows "t \<in> Inf_branching_terms \<R> \<F>"
proof -
  from assms have [simp]: "gpair t u \<in> \<L> \<A> \<longleftrightarrow> (t, u) \<in> \<R> \<and> u \<in> \<T>\<^sub>G (fset \<F>)"
    for u by (auto simp: RR2_spec_def)
  from assms have "t \<in> \<T>\<^sub>G (fset \<F>)" unfolding RR2_spec_def
    by (auto dest: not_finite_existsD)
  then show ?thesis using assms unfolding Inf_branching_terms_def
    by (auto simp: \<T>\<^sub>G_equivalent_def)
qed

lemma Inf_automata_to_Inf:
  assumes "RR2_spec \<A> \<R>" and "\<R> \<subseteq> \<T>\<^sub>G (fset \<F>) \<times> \<T>\<^sub>G (fset \<F>)"
    and "gpair t u \<in> \<L> (Inf_reg \<A> (Q_infty (ta \<A>) \<F>))"
  shows "t \<in> Inf_branching_terms \<R> \<F>"
proof -
  let ?con = "\<lambda> t. term_of_gterm (gterm_to_None_Some t)"
  let ?A = "Inf_automata (ta \<A>) (Q_infty (ta \<A>) \<F>)"
  from assms(3) obtain q where fin: "q |\<in>| fin \<A>" and
    reach_fin: "CInr q |\<in>| ta_der ?A (term_of_gterm (gpair t u))"
    by (auto simp: Inf_reg_def \<L>_def Inf_automata_def elim!: gta_langE)
  from CInr_Inf_automata_to_q_state[OF reach_fin] obtain C s p where
    ctxt: "C\<langle>s\<rangle> = term_of_gterm (gpair t u)" and
    q_inf_st: "CInr p |\<in>| ta_der ?A s" "p |\<in>| Q_infty (ta \<A>) \<F>" and
    reach: "CInr q |\<in>| ta_der ?A C\<langle>Var (CInr p)\<rangle>" and
    none: "(fst \<circ> fst \<circ> the \<circ> root) s = None" by auto
  have gr: "ground s" "ground_ctxt C" using arg_cong[OF ctxt, of ground]
    by auto
  have reach: "q |\<in>| ta_der (ta \<A>) (adapt_vars_ctxt C)\<langle>Var p\<rangle>"
    using gr Inf_automata_dash_reach_to_reach[OF reach]
    by (auto simp: map_vars_term_ctxt_apply)
  from q_inf_st(2) have inf: "infinite {v. funas_gterm v \<subseteq> fset \<F> \<and> p |\<in>| ta_der (ta \<A>) (?con v)}"
    by (simp add: Q_infty_fmember)
  have inf: "infinite {v. funas_gterm v \<subseteq> fset \<F> \<and> q |\<in>| gta_der (ta \<A>) (gctxt_of_ctxt C)\<langle>gterm_to_None_Some v\<rangle>\<^sub>G}"
    using reach ground_ctxt_adapt_ground[OF gr(2)] gr
    by (intro infinite_super[OF _ inf], auto simp: gta_der_def)
       (smt (z3) adapt_vars_ctxt adapt_vars_term_of_gterm ground_gctxt_of_ctxt_apply_gterm ta_der_ctxt)
  have *: "gfun_at (gterm_of_term C\<langle>s\<rangle>) (hole_pos C) = gfun_at (gterm_of_term s) []"
    by (induct C) (auto simp: nth_append_Cons)
  from arg_cong[OF ctxt, of "\<lambda> t. gfun_at (gterm_of_term t) (hole_pos C)"] none
  have hp_nt: "ghole_pos (gctxt_of_ctxt C) \<notin> gposs t" unfolding ground_hole_pos_to_ghole[OF gr(2)]
    using gfun_at_gpair[of t u "hole_pos C"] gr *
    by (cases s) (auto simp flip: poss_gposs_mem_conv split: if_splits elim: gfun_at_possE)
  from gpair_ctxt_decomposition[OF hp_nt, of u "gsubt_at u (hole_pos C)"]
  have to_gpair: "gpair t (gctxt_at_pos u (hole_pos C))\<langle>v\<rangle>\<^sub>G = (gctxt_of_ctxt C)\<langle>gterm_to_None_Some v\<rangle>\<^sub>G" for v
    unfolding ground_hole_pos_to_ghole[OF gr(2)] using ctxt gr
    using subst_at_gpair_nt_poss_None_Some[OF _ hp_nt, of u]
    by (metis (no_types, lifting) UnE \<open>ghole_pos (gctxt_of_ctxt C) = hole_pos C\<close>
        gposs_of_gpair gsubt_at_gctxt_apply_ghole hole_pos_in_ctxt_apply hp_nt poss_gposs_conv term_of_gterm_ctxt_apply)
  have inf: "infinite {v. gpair t ((gctxt_at_pos u (hole_pos C))\<langle>v\<rangle>\<^sub>G) \<in> \<L> \<A>}" using fin
    by (intro infinite_super[OF _ inf]) (auto simp: \<L>_def gta_der_def simp flip: to_gpair)
  have "infinite {u |u. gpair t u \<in> \<L> \<A>}"
    by (intro infinite_super[OF _ infinite_inj_image_infinite[OF inf gctxt_apply_inj_on_term[of "gctxt_at_pos u (hole_pos C)"]]])
       (auto simp: image_def intro: infinite_super)
  then show ?thesis using assms(1, 2)
    by (intro aux_lemma[of \<A>]) simp
qed

lemma Inf_automata_subseteq:
  "\<L> (Inf_reg \<A> (Q_infty (ta \<A>) \<F>)) \<subseteq> \<L> \<A>" (is "\<L> ?IA \<subseteq> _")
proof
  fix s assume l: "s \<in> \<L> ?IA"
  then obtain q where w: "q |\<in>| fin ?IA" "q |\<in>| ta_der (ta ?IA) (term_of_gterm s)"
    by (auto simp: \<L>_def elim!: gta_langE)
  from w(1) have "remove_sum q |\<in>| fin \<A>"
    by (auto simp: Inf_reg_def Inf_automata_def)
  then show "s \<in> \<L> \<A>" using Inf_automata_dash_reach_to_reach[of q "ta \<A>"] w(2)
    by (auto simp: gterm.map_ident \<L>_def Inf_reg_def)
       (metis gta_langI map_vars_term_term_of_gterm)
qed

lemma \<L>_Inf_reg:
  assumes "RR2_spec \<A> \<R>" and "\<R> \<subseteq> \<T>\<^sub>G (fset \<F>) \<times> \<T>\<^sub>G (fset \<F>)"
  shows "gfst ` \<L> (Inf_reg \<A> (Q_infty (ta \<A>) \<F>)) = Inf_branching_terms \<R> \<F>"
proof -
  {fix s assume ass: "s \<in> \<L> (Inf_reg \<A> (Q_infty (ta \<A>) \<F>))"
    then have "\<exists> t u. s = gpair t u" using Inf_automata_subseteq[of \<A> \<F>] assms(1)
      by (auto simp: RR2_spec_def)
    then have "gfst s \<in> Inf_branching_terms \<R> \<F>"
      using ass Inf_automata_to_Inf[OF assms]
      by (force simp: gfst_gpair)}
  then show ?thesis using Inf_to_automata[OF assms(1), of _ \<F>]
    by (auto simp: gfst_gpair) (metis gfst_gpair image_iff)
qed
end


theory utp_fault_designs
imports  "../../utp/utp" "../utp_designs" "../../hoare/AlgebraicLaws/Rel&Des/Algebraic_Laws_aux"
begin

subsection {*Sequential C-program alphabet*}

text {*In order to record the interaction of a sequential C program with its execution environment,
       we extend the alphabet of UTP by two additional global state variables:
      \begin{itemize}
       \<^item> abrupt_aux: a variable of type @{typ "'a option"} used to record the reason of the abrupt.
         For example a reason for abrupt in a C program can be: break, continue, return.
       \<^item> abrupt: a boolean variable used to specify if the program is in an abrupt state or not.
     \end{itemize}

*}

alphabet  cp_flt = des_vars +
  fault:: bool

declare cp_flt.splits [alpha_splits]

subsubsection {*Alphabet proofs*}
text {*
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
*}

interpretation cp_flt:
  lens_interp "\<lambda> (ok, r) . (ok, fault\<^sub>v r, more r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation cp_flt_rel: lens_interp
  "\<lambda>(ok, ok', r, r'). (ok, ok', fault\<^sub>v r, fault\<^sub>v r', more r, more r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

subsubsection {*Type lifting*}

type_synonym  ('\<alpha>) cpf = "('\<alpha>) cp_flt_scheme des"
type_synonym ('\<alpha>,'\<beta>) rel_cpf  = "(('\<alpha>) cpf, ('\<beta>) cpf) rel"
type_synonym ('\<alpha>) hrel_cpf  = "(('\<alpha>) cpf) hrel"

subsubsection {*Syntactic type setup*}

translations
  (type) "('\<alpha>) cpf" <= (type) " ('\<alpha>) cp_flt_scheme des"
  (type) "('\<alpha>) cpf" <= (type) " ('\<alpha>) cp_flt_ext des"
  (type) "('\<alpha>,'\<beta>) rel_cpf" <= (type) "(('\<alpha>) cpf, ('\<beta>) cpf) rel"

notation cp_flt_child_lens\<^sub>a ("\<Sigma>\<^sub>f\<^sub>l\<^sub>t")
notation cp_flt_child_lens ("\<Sigma>\<^sub>F\<^sub>L\<^sub>T")

syntax
  "_svid_st_alpha"  :: "svid" ("\<Sigma>\<^sub>F\<^sub>L\<^sub>T")
  "_svid_st_a"  :: "svid" ("\<Sigma>\<^sub>f\<^sub>l\<^sub>t")
translations
  "_svid_st_alpha" => "CONST cp_flt_child_lens"
   "_svid_st_a" => "CONST cp_flt_child_lens\<^sub>a"

abbreviation fault_f::"('\<alpha>, '\<beta>) rel_cpf \<Rightarrow> ('\<alpha>, '\<beta>) rel_cpf"
where "fault_f R \<equiv> R\<lbrakk>false/$fault\<rbrakk>"

abbreviation fault_t::"('\<alpha>, '\<beta>) rel_cpf \<Rightarrow> ('\<alpha>, '\<beta>) rel_cpf"
where "fault_t R \<equiv> R\<lbrakk>true/$fault\<rbrakk>"

syntax
  "_abrupt_f"  :: "logic \<Rightarrow> logic" ("_\<^sub>f\<^sub>f" [1000] 1000)
  "_abrupt_t"  :: "logic \<Rightarrow> logic" ("_\<^sub>f\<^sub>t" [1000] 1000)
  "_top_abr" :: "logic" ("\<top>\<^sub>F\<^sub>L\<^sub>T")
  "_bot_abr" :: "logic" ("\<bottom>\<^sub>F\<^sub>L\<^sub>T")

translations
  "P \<^sub>f\<^sub>f" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST fault) false) P"
  "P \<^sub>f\<^sub>t" \<rightleftharpoons> "CONST usubst (CONST subst_upd CONST id (CONST ivar CONST fault) true) P"
  "\<top>\<^sub>F\<^sub>L\<^sub>T" => "(CONST not_upred (CONST utp_expr.var (CONST ivar CONST ok)))"
  "\<bottom>\<^sub>F\<^sub>L\<^sub>T" => "true"

lemma "\<top>\<^sub>F\<^sub>L\<^sub>T = ((\<not> $ok))"
  by auto

subsection {*Substitution lift and drop*}

abbreviation lift_rel_usubst_cpa ("\<lceil>_\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T")
where "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<equiv> \<sigma> \<oplus>\<^sub>s (\<Sigma>\<^sub>F\<^sub>L\<^sub>T \<times>\<^sub>L \<Sigma>\<^sub>F\<^sub>L\<^sub>T)"

abbreviation lift_usubst_cpa ("\<lceil>_\<rceil>\<^sub>s\<^sub>F\<^sub>L\<^sub>T")
where "\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>F\<^sub>L\<^sub>T \<equiv> \<lceil>\<lceil>\<sigma>\<rceil>\<^sub>s\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T"

abbreviation drop_cpa_rel_usubst ("\<lfloor>_\<rfloor>\<^sub>S\<^sub>F\<^sub>L\<^sub>T")
where "\<lfloor>\<sigma>\<rfloor>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<equiv> \<sigma> \<restriction>\<^sub>s (\<Sigma>\<^sub>F\<^sub>L\<^sub>T \<times>\<^sub>L \<Sigma>\<^sub>F\<^sub>L\<^sub>T)"

abbreviation drop_cpa_usubst ("\<lfloor>_\<rfloor>\<^sub>s\<^sub>F\<^sub>L\<^sub>T")
where "\<lfloor>\<sigma>\<rfloor>\<^sub>s\<^sub>F\<^sub>L\<^sub>T \<equiv> \<lfloor>\<lfloor>\<sigma>\<rfloor>\<^sub>S\<^sub>F\<^sub>L\<^sub>T\<rfloor>\<^sub>s"

subsection {*UTP-Relations lift and drop*}

abbreviation lift_rel_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>F\<^sub>L\<^sub>T")
where "\<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T \<equiv> P \<oplus>\<^sub>p (\<Sigma>\<^sub>F\<^sub>L\<^sub>T \<times>\<^sub>L \<Sigma>\<^sub>F\<^sub>L\<^sub>T)"

abbreviation lift_pre_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub><")
where "\<lceil>p\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub>< \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub><\<rceil>\<^sub>F\<^sub>L\<^sub>T"

abbreviation lift_post_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub>> \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub>>\<rceil>\<^sub>F\<^sub>L\<^sub>T"

abbreviation drop_cpa_rel_uexpr ("\<lfloor>_\<rfloor>\<^sub>F\<^sub>L\<^sub>T")
where "\<lfloor>P\<rfloor>\<^sub>F\<^sub>L\<^sub>T \<equiv> P \<restriction>\<^sub>p (\<Sigma>\<^sub>F\<^sub>L\<^sub>T \<times>\<^sub>L \<Sigma>\<^sub>F\<^sub>L\<^sub>T)"

abbreviation drop_cpa_pre_uexpr ("\<lfloor>_\<rfloor>\<^sub><\<^sub>F\<^sub>L\<^sub>T")
where "\<lfloor>P\<rfloor>\<^sub><\<^sub>F\<^sub>L\<^sub>T \<equiv> \<lfloor>\<lfloor>P\<rfloor>\<^sub>F\<^sub>L\<^sub>T\<rfloor>\<^sub><"

abbreviation drop_cpa_post_uexpr ("\<lfloor>_\<rfloor>\<^sub>>\<^sub>F\<^sub>L\<^sub>T")
where "\<lfloor>P\<rfloor>\<^sub>>\<^sub>F\<^sub>L\<^sub>T \<equiv> \<lfloor>\<lfloor>P\<rfloor>\<^sub>F\<^sub>L\<^sub>T\<rfloor>\<^sub>>"

subsection {* Reactive lemmas *}

subsection{*Healthiness conditions*}

text {*Programs in abrupt state do not progress*}
definition C3_flt_def [upred_defs]:
  "C3_flt(P) = (P \<triangleleft> \<not>$fault \<triangleright> II)"

abbreviation
 "Simpl\<^sub>F\<^sub>L\<^sub>T P \<equiv> C3_flt(\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (P))"

subsection{*Control flow statements*}

text
{*
  We introduce the known control-flow statements for C. Our semantics is restricted
  to @{const C3_flt}. In other words It assumes:
  \begin{itemize}
    \<^item>  If we start the execution of a program ie, @{term "$ok"}, from an initial stable state
       ie, @{term "\<not>($fault)"},
    \<^item>  the program can terminates and has a final state ie,@{term "$ok\<acute>"},
    \<^item>  the final state is a normal state if it terminates and the result of execution is
       @{term "\<not>$fault"},
  \end{itemize}
  Thus it captures Simpl semantics.
*}

definition skip_flt :: "('\<alpha>) hrel_cpf" ("SKIP\<^sub>F\<^sub>L\<^sub>T")
where [urel_defs]: "SKIP\<^sub>F\<^sub>L\<^sub>T = Simpl\<^sub>F\<^sub>L\<^sub>T (\<not>$fault\<acute> \<and> \<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T)"

definition assigns_flt :: " '\<alpha> usubst \<Rightarrow> ('\<alpha>) hrel_cpf" ("\<langle>_\<rangle>\<^sub>F\<^sub>L\<^sub>T")
where [urel_defs]: "\<langle>\<sigma>\<rangle>\<^sub>F\<^sub>L\<^sub>T  = Simpl\<^sub>F\<^sub>L\<^sub>T (\<not>$fault\<acute> \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>F\<^sub>L\<^sub>T)"

subsection{*Conditional*}

abbreviation If_abr ::
  "'\<alpha> cond \<Rightarrow> ('\<alpha>) hrel_cpf \<Rightarrow> ('\<alpha>) hrel_cpf \<Rightarrow> ('\<alpha>) hrel_cpf" ("bif (_)/ then (_) else (_) eif")
where "bif b then P else Q eif \<equiv> (P \<triangleleft> \<lceil>b\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub>< \<triangleright> Q)"

subsection{*assert and assume*}

definition rassume_abr :: "'\<alpha> upred \<Rightarrow> ('\<alpha>) hrel_cpf" ("_\<^sup>\<top>\<^sup>C" [999] 999)
where [urel_defs]: "rassume_abr c = (bif c then SKIP\<^sub>F\<^sub>L\<^sub>T else \<top>\<^sub>F\<^sub>L\<^sub>T eif)"

definition rassert_abr :: "'\<alpha> upred \<Rightarrow> ('\<alpha>) hrel_cpf" ("_\<^sub>\<bottom>\<^sub>C" [999] 999)
where [urel_defs]: "rassert_abr c = (bif c then SKIP\<^sub>F\<^sub>L\<^sub>T else \<bottom>\<^sub>F\<^sub>L\<^sub>T eif)"

subsection{*GUARD*}

abbreviation guard_c :: "'\<alpha> cond \<Rightarrow> ('\<alpha>) hrel_cpf"
where "guard_c b \<equiv>
      (bif b then SKIP\<^sub>F\<^sub>L\<^sub>T else ((\<not>$fault)\<turnstile> ($fault\<acute> \<and> \<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T)) eif)"

subsection{*Scoping*}
text {*The feature block specifies scoping via code blocks in C. The following specification
       do not support cases where the case is in abrupt since abrupt state at this stage is not yet
       specified*}

definition block_flt ("bob INIT (_) BODY /(_) RESTORE /(_) RETURN/(_) eob")
where [urel_defs]:
  "bob INIT init BODY body RESTORE restore RETURN return eob=
    ( Abs_uexpr (\<lambda>(s, s').
             \<lbrakk>init ;; body ;;
             Abs_uexpr (\<lambda>(t, t').\<lbrakk>restore (s, s') (t, t');; return(s, s') (t, t')\<rbrakk>\<^sub>e (t, t'))\<rbrakk>\<^sub>e (s, s')))"

subsection{*Loops*}

purge_notation while ("while\<^sup>\<top> _ do _ od")

definition While :: "'\<alpha> cond \<Rightarrow> ('\<alpha>) hrel_cpf \<Rightarrow> ('\<alpha>) hrel_cpf" ("while\<^sup>\<top> _ do _ od")
where "While b C = (\<nu> X \<bullet> bif b then (C ;; X) else SKIP\<^sub>F\<^sub>L\<^sub>T eif)"

purge_notation while_top ("while _ do _ od")

abbreviation While_top :: "'\<alpha> cond \<Rightarrow> ('\<alpha>) hrel_cpf \<Rightarrow> ('\<alpha>) hrel_cpf" ("while _ do _ od")
where "while b do P od \<equiv> while\<^sup>\<top> b do P od"

purge_notation while_bot ("while\<^sub>\<bottom> _ do _ od")

definition While_bot :: "'\<alpha> cond \<Rightarrow> ('\<alpha>) hrel_cpf \<Rightarrow> ('\<alpha>) hrel_cpf" ("while\<^sub>\<bottom> _ do _ od")
where "while\<^sub>\<bottom> b do P od =  (\<mu> X \<bullet> bif b then (P ;; X) else SKIP\<^sub>F\<^sub>L\<^sub>T eif)"

subsection{*While-loop inv*}
text {*While loops with invariant decoration*}

purge_notation while_inv ("while _ invr _ do _ od" 70)

definition While_inv :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> ('\<alpha>) hrel_cpf \<Rightarrow> ('\<alpha>) hrel_cpf" ("while _ invr _ do _ od" 70)
where "while b invr p do S od = while b do S od"

declare While_def [urel_defs]
declare While_inv_def [urel_defs]
declare While_bot_def [urel_defs]

syntax
  "_assignmentabr" :: "svid_list \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr "\<Midarrow>" 55)

translations
  "_assignmentabr xs vs" => "CONST assigns_flt (_mk_usubst (CONST id) xs vs)"
  "x \<Midarrow> v" <= "CONST assigns_flt (CONST subst_upd (CONST id) (CONST svar x) v)"
  "x \<Midarrow> v" <= "CONST assigns_flt (CONST subst_upd (CONST id) x v)"
  "x,y \<Midarrow> u,v" <= "CONST assigns_flt (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"

end


theory WellTypedExp
  imports WTMiscEnv
begin

    (*
      ####################################
        P1. expression syntax
      ####################################
    *)

    (* expressions *)

datatype p_const =
  UnitConst
  | IConst int
  | BConst bool
  | FixConst
    (* arrays *)
  (*| EmptyArrayConst
  | ExtArrayConst*)
  | NullConst
  | NewArrayConst
  | ReadConst
  | WriteConst
    (* pairs *)
  | UnpackConst
    (* channels *)
  | NewChanConst
  | SendConst
  | RecvConst
  | ForkConst

datatype p_op =
  I2Op "int \<Rightarrow> int \<Rightarrow> int"
  | I1Op "int \<Rightarrow> int"
  | C2Op "int \<Rightarrow> int \<Rightarrow> bool"
  | C1Op "int \<Rightarrow> bool"
  | R2Op "bool \<Rightarrow> bool \<Rightarrow> bool"
  | R1Op "bool \<Rightarrow> bool"

datatype var_type =
  VarType string
  | LocType string

datatype p_exp =
  ConstExp p_const
  | OpExp p_op
  | VarExp var_type
  | PairExp p_exp p_exp
  | IfExp p_exp p_exp p_exp
  | LamExp string p_exp
  | AppExp p_exp p_exp

fun bin_const where
  "bin_const ReadConst = True"
| "bin_const WriteConst = True"
| "bin_const SendConst = True"
| "bin_const c = False"

fun is_value :: "p_exp \<Rightarrow> bool" where
  "is_value (ConstExp c) = True"
| "is_value (OpExp xop) = True"
| "is_value (VarExp (LocType x)) = True"
| "is_value (PairExp v1 v2) = (is_value v1 \<and> is_value v2)"
| "is_value (LamExp x e) = True"
| "is_value (AppExp (ConstExp c) v) = (bin_const c \<and> is_value v)"
| "is_value other = False"

fun is_sexp :: "p_exp \<Rightarrow> bool" where
  "is_sexp (ConstExp c) = True"
| "is_sexp (OpExp xop) = True"
| "is_sexp (VarExp (VarType x)) = False"
| "is_sexp (VarExp (LocType x)) = True"
| "is_sexp (PairExp v1 v2) = (is_value v1 \<and> is_value v2)"
| "is_sexp (LamExp x e) = True"
| "is_sexp (AppExp (ConstExp FixConst) (LamExp x e)) = True"
| "is_sexp (AppExp (ConstExp c) v) = (bin_const c \<and> is_value v)"
| "is_sexp other = False"

fun free_vars :: "p_exp \<Rightarrow> string set" where
  "free_vars (ConstExp c) = {}"
| "free_vars (OpExp xop) = {}"
| "free_vars (VarExp v) = (case v of
  VarType x \<Rightarrow> {x}
  | other \<Rightarrow> {}
)"
| "free_vars (PairExp e1 e2) = free_vars e1 \<union> free_vars e2"
| "free_vars (IfExp e1 e2 e3) = free_vars e1 \<union> free_vars e2 \<union> free_vars e3"
| "free_vars (LamExp x e) = free_vars e - {x}"
| "free_vars (AppExp e1 e2) = free_vars e1 \<union> free_vars e2"

fun ref_vars :: "p_exp \<Rightarrow> string set" where
  "ref_vars (ConstExp c) = {}"
| "ref_vars (OpExp xop) = {}"
| "ref_vars (VarExp v) = (case v of
    VarType x \<Rightarrow> {}
    | LocType x \<Rightarrow> {x}
  )"
| "ref_vars (PairExp e1 e2) = ref_vars e1 \<union> ref_vars e2"
| "ref_vars (IfExp e1 e2 e3) = ref_vars e1 \<union> ref_vars e2 \<union> ref_vars e3"
| "ref_vars (LamExp x e) = ref_vars e"
| "ref_vars (AppExp e1 e2) = ref_vars e1 \<union> ref_vars e2"

type_synonym owner_env = "string \<Rightarrow> string"

fun res_name where
  "res_name (VarType x) = Var x"
| "res_name (LocType x) = Loc x"

fun owner_name where
  "owner_name delta (VarType x) = Var x"
| "owner_name delta (LocType x) = Loc (delta x)"

fun res_vars :: "owner_env \<Rightarrow> p_exp \<Rightarrow> res_id set" where
  "res_vars delta (ConstExp c) = {}"
| "res_vars delta (OpExp xop) = {}"
| "res_vars delta (VarExp v) = {owner_name delta v}"
| "res_vars delta (PairExp e1 e2) = res_vars delta e1 \<union> res_vars delta e2"
| "res_vars delta (IfExp e1 e2 e3) = res_vars delta e1 \<union> res_vars delta e2 \<union> res_vars delta e3"
| "res_vars delta (LamExp x e) = res_vars delta e - {Var x}"
| "res_vars delta (AppExp e1 e2) = res_vars delta e1 \<union> res_vars delta e2"

definition non_prim_vars where
  "non_prim_vars env delta e = { x | x. non_prim_entry env x \<and> x \<in> res_vars delta e }"

definition env_vars :: "(string \<Rightarrow> 'a option) \<Rightarrow> string set" where
  "env_vars env = { x | x. env x \<noteq> None }"

definition use_env_vars where
  "use_env_vars r_s = { x | x. r_s x \<noteq> NoPerm }"

definition own_env_vars where
  "own_env_vars r_s = { x | x. r_s x = OwnPerm }"

    (*
      ####################################
        P4. type system for expressions
      ####################################
    *)

definition pure_fun where
  "pure_fun t1 t2 r = FunTy t1 t2 UsePerm r"

fun aff_leq where
  "aff_leq Prim r = True"
| "aff_leq Ref NoPerm = False"
| "aff_leq Ref r = True"
| "aff_leq Aff OwnPerm = True"
| "aff_leq Aff r = False"

fun is_nullable where
  "is_nullable (FunTy t1 t2 p a) = True"
| "is_nullable (ChanTy tau c_end) = True"
| "is_nullable (ArrayTy tau) = True"
| "is_nullable tau = False"

fun const_type :: "p_const \<Rightarrow> p_type set" where
  "const_type UnitConst = {UnitTy}"
| "const_type (IConst i) = {IntTy}"
| "const_type (BConst b) = {BoolTy}"
| "const_type FixConst = {pure_fun (pure_fun t t (req_type t)) t Prim | t. fun_ty t \<and> unlim t}"
  (* arrays: since t is unlim and arrays are unlim, no functions require ownership.
      pairs are affine because they are only needed once. *)
(*| "const_type EmptyArrayConst = {pure_fun UnitTy (ArrayTy t) Prim | t. unlim t}"
| "const_type ExtArrayConst = {pure_fun (ArrayTy t) (FunTy t (ArrayTy t) OwnPerm Ref) Prim | t. unlim t}"*)
| "const_type NewArrayConst = {pure_fun IntTy (ArrayTy tau) Prim | tau. unlim tau}"
| "const_type NullConst = { tau | tau. True }"
| "const_type ReadConst = {pure_fun (ArrayTy t) (pure_fun IntTy t Ref) Prim | t. unlim t}"
| "const_type WriteConst = {pure_fun (ArrayTy t) (FunTy (PairTy IntTy t OwnPerm) UnitTy OwnPerm Ref) Prim | t. unlim t}"
  (* pairs: a reusable pair must be constructed from unlimited values + requires ownership of both its elements,
    however permissions-wise it is treated like a var.
      - an affine pair can be constructed from anything, and also requires ownership of both its elements
       - for unpacking, the pair is assumed to be owned, whatever is put in *)
| "const_type UnpackConst = {FunTy (PairTy t1 t2 r) (FunTy (FunTy t1 (FunTy t2 tx r (as_aff r')) r (as_aff r')) tx r' (as_aff r)) r Prim | t1 t2 tx r r'. leq_perm r r'}"
  (* channels: all uses of a channel use up ownership *)
| "const_type NewChanConst = {pure_fun UnitTy (PairTy (ChanTy tau SEnd) (ChanTy tau REnd) OwnPerm) Prim | tau. True}"
| "const_type SendConst = {pure_fun (ChanTy t SEnd) (FunTy t UnitTy r Ref) Prim | t r. is_own r}"
| "const_type RecvConst = {pure_fun (ChanTy t REnd) t Prim | t. True }"
| "const_type ForkConst = {FunTy (FunTy UnitTy UnitTy UsePerm a) UnitTy r Prim | a r. is_own r}"

fun op_type :: "p_op \<Rightarrow> p_type" where
  "op_type (I2Op xop) = pure_fun IntTy (pure_fun IntTy IntTy Prim) Prim"
| "op_type (I1Op xop) = pure_fun IntTy IntTy Prim"
| "op_type (C2Op xop) = pure_fun IntTy (pure_fun IntTy BoolTy Prim) Prim"
| "op_type (C1Op xop) = pure_fun IntTy BoolTy Prim"
| "op_type (R2Op xop) = pure_fun BoolTy (pure_fun BoolTy BoolTy Prim) Prim"
| "op_type (R1Op xop) = pure_fun BoolTy BoolTy Prim"

definition app_req where
  "app_req rx1 rx2 r tau r_ex = (if req_type tau = Prim then empty_use_env else
    diff_use_env (comp_use_env rx1 rx2) (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex))"

definition pair_req where
  "pair_req rx r_ex tau = (if req_type tau = Prim then empty_use_env else diff_use_env rx r_ex)"

fun safe_type where
  "safe_type tau OwnPerm = True"
| "safe_type tau UsePerm = unlim tau"
| "safe_type tau NoPerm = False"

fun safe_type_x where
  "safe_type_x tau OwnPerm = True"
| "safe_type_x tau UsePerm = unlim tau"
| "safe_type_x tau NoPerm = (req_type tau = Prim)"

fun safe_pair_aff where
  "safe_pair_aff a NoPerm = False"
| "safe_pair_aff a UsePerm = (a \<noteq> Aff)"
| "safe_pair_aff a OwnPerm = True"

  (*
fun value_req where
  "value_req (VarType x) tau tau_x = True"
| "value_req (LocType x) tau tau_x = (req_type tau = Ref \<and> req_type tau_x = Ref)"
  *)

fun well_typed :: "pt_env \<Rightarrow> owner_env \<Rightarrow> perm_use_env \<Rightarrow> p_exp \<Rightarrow> p_type \<Rightarrow> perm_use_env \<Rightarrow> perm_use_env \<Rightarrow> bool" where
  "well_typed env delta r_s1 (ConstExp c) tau r_s2 rx = (tau \<in> const_type c \<and> leq_use_env r_s2 r_s1 \<and> leq_use_env rx r_s2)"
| "well_typed env delta r_s1 (OpExp xop) tau r_s2 rx = (tau = op_type xop \<and> leq_use_env r_s2 r_s1 \<and> leq_use_env rx r_s2)"
| "well_typed env delta r_s1 (VarExp v) tau r_s2 rx = (\<exists> r_ex tau_x. env (res_name v) = Some tau \<and> env (owner_name delta v) = Some tau_x \<and> (*value_req v tau tau_x \<and>*)
    leq_use_env (ereq_use_env (owner_name delta v) tau_x) r_s1 \<and> leq_use_env r_s2 (diff_use_env r_s1 (comp_use_env (ereq_use_env (owner_name delta v) tau_x) r_ex)) \<and>
    leq_use_env rx r_s2 \<and> leq_use_env r_ex r_s1 \<and> leq_use_env (diff_use_env (ereq_use_env (owner_name delta v) tau_x) (comp_use_env (ereq_use_env (owner_name delta v) tau_x) r_ex)) rx)"
| "well_typed env delta r_s1 (PairExp e1 e2) tau r_sf rf = (\<exists> t1 t2 r r_s2 r_s3 rx1 rx2 r_ex. tau = PairTy t1 t2 r \<and>
    well_typed env delta r_s1 e1 t1 r_s2 rx1 \<and> well_typed env delta r_s2 e2 t2 r_s3 rx2 \<and>
    leq_use_env (lift_use_env rx1 r) r_s3 \<and> leq_use_env (lift_use_env rx2 r) r_s3 \<and> aff_leq (max_aff (req_type t1) (req_type t2)) r \<and>
    disj_use_env (lift_use_env rx1 r) (lift_use_env rx2 r) \<and>
    leq_use_env r_sf (diff_use_env r_s3 r_ex) \<and> leq_use_env rf r_sf \<and> leq_use_env r_ex r_s1 \<and>
    leq_use_env (pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) r_ex tau) rf
  )"
| "well_typed env delta r_s1 (IfExp e1 e2 e3) tau r_s3 rx = (\<exists> rx' r_s2 rx1 rx2.
    well_typed env delta r_s1 e1 BoolTy r_s2 rx' \<and> well_typed env delta r_s2 e2 tau r_s3 rx1 \<and> well_typed env delta r_s2 e3 tau r_s3 rx2 \<and>
    rx = comp_use_env rx1 rx2)"
| "well_typed env delta r_s1 (LamExp x e) tau r_s2 rf = (\<exists> t1 t2 r a rx r_end r_s' r_ex. tau = FunTy t1 t2 r a \<and>
    well_typed (add_env env (Var x) t1) delta (add_use_env rx (Var x) r) e t2 r_s' r_end \<and> aff_use_env rx a \<and>
    leq_use_env rx r_s1 \<and> leq_use_env r_s2 (diff_use_env r_s1 r_ex) \<and> leq_use_env rf r_s2 \<and>
    leq_use_env r_ex r_s1 \<and> leq_use_env (diff_use_env rx r_ex) rf)"
| "well_typed env delta r_s1 (AppExp e1 e2) tau r_sf rx = (\<exists> t1 r a r_s2 rx1 rx2 r_s3 r_ex.
    well_typed env delta r_s1 e1 (FunTy t1 tau r a) r_s2 rx1 \<and> well_typed env delta r_s2 e2 t1 r_s3 rx2 \<and>
    leq_use_env r_sf (diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)) \<and>
    leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s3 \<and>
    disj_use_env rx1 (lift_use_env rx2 r) \<and> leq_use_env rx r_sf \<and>
    leq_use_env r_ex r_s1 \<and> leq_use_env (app_req rx1 rx2 r tau r_ex) rx
  )"

    (* - expression lemmas *)

lemma value_is_sexp: "is_value e \<Longrightarrow> is_sexp e"
  apply (case_tac e)
        apply (auto)
   apply (case_tac x3)
    apply (auto)
  apply (case_tac x71)
        apply (auto)
  apply (case_tac x1)
              apply (auto)
  done

lemma e2_sexp: "\<lbrakk> is_sexp (AppExp e1 e2) \<rbrakk> \<Longrightarrow> is_sexp e2"
  apply (case_tac e1)
       apply (auto)
  apply (case_tac e2)
        apply (auto)
   apply (case_tac x3)
    apply (auto)
  apply (case_tac x71)
        apply (auto)
  apply (case_tac x1a)
              apply (auto)
  done

end


theory DRAT_Misc
imports "Refine_Imperative_HOL.IICF"
begin

  hide_const (open) Word.slice

(** NOT MOVED **)
subsection \<open>Maybe-Head Insertion into Distinct List\<close>
text \<open>
  Insertion into distinct list, where the inserted element is either the head of the list, or
  not contained into the list. Useful to avoid duplicate insertions into the
  literal->clause map.
\<close>

definition "mbhd_invar x l \<equiv> distinct l \<and> x\<notin>set (tl l)"
definition (in -) "mbhd_insert x l \<equiv> if l=[] then [x] else if (x = hd l) then l else x#l"

lemma mbhd_insert_invar: "mbhd_invar x l \<Longrightarrow> mbhd_invar x (mbhd_insert x l)"
  unfolding mbhd_invar_def mbhd_insert_def by (cases l) auto

lemma mbhd_insert_correct: "set (mbhd_insert x l) = insert x (set l)"
  unfolding mbhd_insert_def by auto

lemma mbhd_invar_init: "distinct l \<and> x\<notin>set l \<Longrightarrow> mbhd_invar x l"
  unfolding mbhd_invar_def by (cases l) auto

lemma mbhd_invar_exit: "mbhd_invar x l \<Longrightarrow> distinct l"
  unfolding mbhd_invar_def by (cases l) auto

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Bisim_Subst
  imports Weak_Late_Bisim Strong_Late_Bisim_Subst
begin

consts weakBisimSubst :: "(pi \<times> pi) set"
abbreviation
  weakBisimSubstJudge (infixr "\<approx>\<^sup>s" 65) where "P \<approx>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed weakBisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "P \<approx> Q"
proof -
  from assms substClosedSubset show ?thesis
    by blast
qed

lemma strongBisimWeakBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<approx>\<^sup>s Q"
using assms
by(auto simp add: substClosed_def intro: strongBisimWeakBisim)

lemma eqvt:
  shows "eqvt (substClosed weakBisim)"
by(rule eqvtSubstClosed[OF Weak_Late_Bisim.eqvt])

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<approx>\<^sup>s Q"

  shows "(perm \<bullet> P) \<approx>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule_tac eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<approx>\<^sup>s P"
by(force simp add: substClosed_def intro: Weak_Late_Bisim.reflexive)

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s Q"

  shows "Q \<approx>\<^sup>s P"
using assms
by(force simp add: substClosed_def intro: Weak_Late_Bisim.symmetric)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<approx>\<^sup>s Q"

  shows "P[<s>] \<approx>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: substClosed_def)
  fix s'
  assume "\<forall>s. P[<s>] \<approx> Q[<s>]"
  hence "P[<(s@s')>] \<approx> Q[<(s@s')>]" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "(P[<s>])[<s'>] \<approx> (Q[<s>])[<s'>]"
    by simp
qed

end


theory TelephoneExchange_locales
  imports "Z_Machines.Z_Machine"
begin unbundle Z_Syntax

type_synonym digit = integer
type_synonym subs = "digit list"

definition Digit :: "\<bbbP> digit" where "Digit = integer_of_int ` {0..9}"

consts
  Subs :: "\<bbbP> (digit list)"

definition "Valid = {n \<in> blists 6 Digit. \<exists> s \<in> Subs. n \<le> s}"

definition
  "TelephoneExchange_axioms = (Subs \<in> \<bbbP> (seq Digit))"

enumtype Status = seize | dialling | unobtainable | connecting | ringing | speech | engaged | suspended

definition "Connected = {ringing , speech, suspended}"

definition "Established = Connected \<union> {connecting , engaged}"

type_synonym subrec = "Status \<times> digit list"

definition SubRec :: "Status \<leftrightarrow> digit list" where
"SubRec = {(s, n). (s = seize \<longleftrightarrow> n = [])
                 \<and> (s = dialling \<longleftrightarrow> n \<in> Valid - Subs - {[]})
                 \<and> (s = unobtainable \<longleftrightarrow> n \<notin> Valid)
                 \<and> (s \<in> Established \<longleftrightarrow> n \<in> Subs)}"

definition st :: "subrec \<Zpfun> Status" where [expr_defs]: "st = (\<lambda> x \<bullet> first x)"
definition num :: "subrec \<Zpfun> subs" where [expr_defs]: "num = (\<lambda> x \<bullet> second x)"

no_syntax
  "_kleisli_comp" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixr "\<Zcomp>" 54)

zstore Exchange =
  Free :: "\<bbbP> subs"
  Unavailable :: "\<bbbP> subs"
  Callers :: "\<bbbP> subs"
  cal :: "subs \<Zpfun> subrec"
  connected :: "subs \<Zpfun> subs"
where
  connected_inj: "pfun_inj connected"
  parts: "[Free, Unavailable, dom cal, ran connected] partitions Subs"
  \<comment> \<open> SF: I modified the above invariant; the initiators of calls and those connected to should disjoint \<close>
  Callers: "dom ((cal \<Zcomp> st) \<Zrres> Connected) = Callers"
  connected: "Callers \<Zdres> (cal \<Zcomp> num) = connected"

declare list_partitions_def [simp]

lemma domres_pabs [simp]: "A \<Zdres> pabs B P f = pabs (A \<inter> B) P f"
  by (metis pabs_def pdom_res_twice)

context Exchange
begin

lemma part_props:
  shows
    "Free \<inter> Unavailable = {}" and
    "Free \<inter> dom cal = {}" and
    "Free \<inter> ran connected = {}" and
    "Unavailable \<inter> dom cal = {}" and
    "Unavailable \<inter> ran connected = {}" and
    "dom cal \<inter> ran connected = {}" and
    "Free \<union> (Unavailable \<union> (dom cal \<union> ran connected)) = Subs"
  using parts by auto

lemma dom_connected_Callers: "dom connected = Callers"
  using invariants by (auto simp add: num_def st_def)

lemma dom_connected_subset_cal: "dom connected \<subseteq> dom cal"
  by (metis Domain_rel_domres Int_absorb Int_lower2 UNIV_def connected num_def pdom_UNIV_comp pdom_pabs rel_of_pfun_comp rel_of_pfun_dom)

lemma dom_suspended_connected: "dom ((cal \<Zcomp> st) \<Zrres> {suspended}) \<subseteq> dom connected"
  by (metis Connected_def Domain_mono dom_connected_Callers insert_subset invariants(3) rel_ranres_le subset_insertI)

lemma Free_Subs: "Free \<subseteq> Subs"
  using parts by auto

lemma Unavailable_Subs: "Unavailable \<subseteq> Subs"
  using parts by auto

lemma dom_cal_Subs: "dom cal \<subseteq> Subs"
  using parts by auto

lemma ran_connected_Subs: "ran connected \<subseteq> Subs"
  using parts by auto

lemma Free: "Free = Subs - (Unavailable \<union> dom cal \<union> ran connected)"
  using parts dom_connected_subset_cal by auto

lemma Unavailable: "Unavailable = Subs - (Free \<union> dom cal \<union> ran connected)"
  using parts dom_connected_subset_cal by auto

lemma nself: "dom connected \<inter> ran connected = {}" \<comment> \<open> Added by SF: no self connections \<close>
  using connected Callers parts by (auto)

lemma ncon_call: "dom cal \<inter> ran connected = {}"
  using parts by auto

lemma nself_connected [simp]: "s \<in> dom connected \<Longrightarrow> s \<noteq> connected s"
  by (metis disjoint_iff nself pfun_app_in_ran)

end

lemma seize_nConnected [simp]: "seize \<notin> Connected" by (simp add: Connected_def)
lemma dialling_nConnected [simp]: "dialling \<notin> Connected" by (simp add: Connected_def)
lemma engaged_nConnected [simp]: "engaged \<notin> Connected" by (simp add: Connected_def)
lemma connecting_nConnected [simp]: "connecting \<notin> Connected" by (simp add: Connected_def)

lemma ringing_Connected [simp]: "ringing \<in> Connected" by (simp add: Connected_def)

definition "InitExchange = [Free\<Zprime> = Subs, Unavailable\<Zprime> = {}, Callers\<Zprime> = {}, cal\<Zprime> = {\<mapsto>}, connected\<Zprime> = 0]"

zoperation LiftFree =
  params s \<in> Subs
  pre "s \<in> Free"
  update "[Free\<Zprime> = Free - {s}
          ,cal\<Zprime> = cal \<oplus> {s \<mapsto> (seize, [])}]"

lemma LiftFree_correct: "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}LiftFree s\<^bold>{Exchange_inv\<^bold>}"
proof zpog
  fix Free :: \<open>\<bbbP> integer list\<close> and Unavailable :: \<open>\<bbbP> integer list\<close>
    and Callers :: \<open>\<bbbP> integer list\<close> and cal :: \<open>integer list \<Zpfun> Status \<times> integer list\<close>
    and connected :: \<open>integer list \<Zpfun> integer list\<close>
  assume
    pres: \<open>s \<in> Subs\<close> \<open>s \<in> Free\<close> and
    inv: \<open>Exchange Free Unavailable Callers cal connected\<close>
  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  show \<open>Exchange (Free - {s}) Unavailable Callers (cal(s \<mapsto> (seize, []))\<^sub>p) connected\<close>
  proof
    from pres P.invariants show \<open>[Free - {s}, Unavailable, dom (cal(s \<mapsto> (seize, []))\<^sub>p), ran connected] partitions Subs\<close>
      by auto
  next
    from pres P.invariants show \<open>dom (([cal(s \<mapsto> (seize, []))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>) \<Zrres> Connected) = Callers\<close>
      by (auto simp add: st_def Connected_def simp add: disjoint_iff)
  next
    from pres P.invariants show \<open>Callers \<Zdres> ([cal(s \<mapsto> (seize, []))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [connected]\<^sub>\<Zpfun>\<close>
      by (auto)
         (metis Un_iff disjoint_iff pdom_pranres pdom_res_upd_out pranres_pdom subsetD)
  next
    show "pfun_inj connected"
      by (simp add: P.connected_inj)
  qed
qed

zoperation LiftSuspended =
  params s \<in> Subs
  pre "(s, suspended) \<in> connected\<^sup>\<sim> \<Zcomp> cal \<Zcomp> st"
  update "[cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (speech, s)}]"

text \<open> I think we need an invariant that those who have suspended a call did not initiate that call. \<close>

lemma "st \<Zrres> {suspended} \<le> st \<Zrres> Connected"

  oops

lemma dom_num [simp]: "dom num = UNIV"
  by (metis Int_absorb UNIV_def num_def pdom_pabs)

lemma dom_st [simp]: "dom st = UNIV"
  by (simp add: st_def)

lemma suspended_Connected [simp]: "suspended \<in> Connected"
  by (simp add: Connected_def)

lemma suspended_le_Connected [simp]: "{suspended} \<subseteq> Connected"
  by (simp add: Connected_def)

syntax
  "_image_syn" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("(_\<^sup>\<rightarrow> _)" 999)
  "_preimage_syn" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("(_\<^sup>\<leftarrow> _)" 999)

translations
  "_image_syn f A" == "CONST ran (CONST dom_res A f)"
  "_preimage_syn f A" == "CONST dom (CONST ran_res f A)"

lemma "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}LiftSuspended s\<^bold>{Exchange_inv\<^bold>}"
proof zpog
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list" and y :: "integer list"
  assume
    pres: "connected(y)\<^sub>p \<in> Subs" "y \<in> dom cal" "fst (cal(y)\<^sub>p) = suspended" "y \<in> dom connected" "s = connected(y)\<^sub>p" and
    inv:  "Exchange Free Unavailable Callers cal connected"
  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp
  show "Exchange Free Unavailable Callers (cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p) connected"
  proof
    show "[Free, Unavailable, dom (cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p), ran connected] partitions Subs"
      using pres P.parts P.connected_inj by (auto simp add: num_def st_def pfun_inv_f_f_apply)
  next
    show "[cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers"
      using pres P.parts P.connected_inj P.Callers by (auto simp add: num_def st_def pfun_inv_f_f_apply Connected_def)
  next
    show "Callers \<Zdres> ([cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [connected]\<^sub>\<Zpfun>"
      using pres P.connected P.connected_inj by (auto simp add: pfun_inv_f_f_apply pfun_eq_iff num_def)
  next
    show "pfun_inj connected"
      by (simp add: P.connected_inj)
  qed
qed

zoperation Answer =
  params s \<in> Subs
  pre "(s, ringing) \<in> connected\<^sup>\<sim> \<Zcomp> cal \<Zcomp> st"
  update "[ Free\<Zprime> = Free - {s}
          , cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (speech, s)}]"

lemma Answer_correct: "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}Answer s\<^bold>{Exchange_inv\<^bold>}"
proof zpog
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list" and y :: "integer list"
  assume
    invs: "Exchange Free Unavailable Callers cal connected" and
    pres: "connected(y)\<^sub>p \<in> Subs" "y \<in> dom cal" "fst (cal(y)\<^sub>p) = ringing" "y \<in> dom connected" "s = connected(y)\<^sub>p"
  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp
  show "Exchange (Free - {connected(y)\<^sub>p}) Unavailable Callers (cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p) connected"
  proof
    from pres P.parts P.connected_inj show "[Free - {connected(y)\<^sub>p}, Unavailable, dom (cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p), ran connected] partitions Subs"
      by (auto simp add: f_pfun_inv_f_apply pfun_inv_f_f_apply)
  next
    from pres P.connected_inj P.dom_connected_subset_cal P.dom_connected_Callers P.Callers show "[cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers"
      by (simp add: pfun_inv_f_f_apply P.connected_inj st_def insert_absorb)
  next
    from pres P.connected_inj P.dom_connected_subset_cal P.dom_connected_Callers P.connected show "Callers \<Zdres> ([cal([connected]\<^sub>\<Zpfun>\<^sup>\<sim>(connected(y)\<^sub>p)\<^sub>r \<mapsto> (speech, connected(y)\<^sub>p))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [connected]\<^sub>\<Zpfun>"
      by (auto simp add: f_pfun_inv_f_apply num_def pfun_eq_iff)
  next
    show "pfun_inj connected"
      by (simp add: P.connected_inj)
  qed
qed

definition "nextstate n =
  (if n \<in> Subs then connecting
   else if n \<in> Valid - Subs then dialling
   else unobtainable)"

lemma nextstate_nConnected [simp]: "nextstate n \<notin> Connected"
  by (auto simp add: nextstate_def Connected_def)

zoperation Dial =
  params s \<in> Subs d \<in> Digit
  pre "(s, seize) \<in> cal \<Zcomp> st \<or> (s, dialling) \<in> cal \<Zcomp> st"
  update "[cal\<Zprime> = (let newnum = (cal \<Zcomp> num) s @ [d] in cal \<oplus> {s \<mapsto> (nextstate newnum, newnum)})]"

lemma Dial_correct: "\<lbrakk> s \<in> Subs; d \<in> Digit \<rbrakk> \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}Dial (s, d)\<^bold>{Exchange_inv\<^bold>}"
proof zpog
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list"
  assume
    pres: "s \<in> Subs" "d \<in> Digit" "s \<in> dom cal" "fst (cal(s)\<^sub>p) = seize" and
    invs: "Exchange Free Unavailable Callers cal connected"

  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  show "Exchange Free Unavailable Callers (let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p) connected"
  proof
    show "pfun_inj connected" by (simp add: P.connected_inj)
  next
    from pres P.parts show "[Free, Unavailable, dom (let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p), ran connected] partitions Subs"
      by (auto simp add: Let_unfold)
  next
    from pres P.Callers show "[let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers"
      by (auto simp add: Let_unfold st_def)
         (metis Compl_iff empty_iff fst_conv insert_iff pdom_res_apply seize_nConnected)
  next
    from pres P.Callers P.connected  show "Callers \<Zdres> ([let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [connected]\<^sub>\<Zpfun>"
      by (auto simp add: Let_unfold pfun_eq_iff num_def st_def)
         (metis P.dom_connected_Callers fst_conv mem_Collect_eq ppreimageI snd_conv)
  qed
next
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list"
  assume
    pres: "s \<in> Subs" "d \<in> Digit" "s \<in> dom cal" "fst (cal(s)\<^sub>p) = dialling" and
    invs: "Exchange Free Unavailable Callers cal connected"

  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  show "Exchange Free Unavailable Callers (let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p) connected"
  proof
    show "pfun_inj connected" by (simp add: P.connected_inj)
  next
    from pres P.parts show "[Free, Unavailable, dom (let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p), ran connected] partitions Subs"
      by (auto simp add: Let_unfold)
  next
    from pres P.Callers show "[let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers"
      by (auto simp add: Let_unfold st_def)
         (metis Compl_iff dialling_nConnected empty_iff fst_conv insert_iff pdom_res_apply)
  next
    from pres P.Callers P.connected  show "Callers \<Zdres> ([let newnum = snd (cal(s)\<^sub>p) @ [d] in cal(s \<mapsto> (nextstate newnum, newnum))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [connected]\<^sub>\<Zpfun>"
      by (auto simp add: Let_unfold pfun_eq_iff num_def st_def)
         (metis P.dom_connected_Callers fst_conv mem_Collect_eq ppreimageI snd_conv)
  qed
qed

lemma nConnected: "- Connected = {seize, dialling, connecting, engaged, unobtainable}"
  by (auto simp add: Connected_def, meson Status.exhaust_disc)

zoperation ClearAttempt =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<notin> Connected"
  update "[Free\<Zprime> = Free \<union> {s}, cal\<Zprime> = {s} \<Zndres> cal]"

lemma ClearAttempt_correct: "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}ClearAttempt s\<^bold>{Exchange_inv\<^bold>}"
  apply (zpog_full; auto)
  apply (metis Compl_iff empty_iff fst_conv insert_iff pdom_res_apply)
  apply (metis (no_types, lifting) Int_commute inf_bot_right mem_Collect_eq pdom_antires_insert_notin pdom_nres_disjoint pdom_res_twice ppreimageD pranres_pdom)
  done

zoperation ClearLine =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {ringing , suspended}"
  update "[ Free\<Zprime> = Free \<union> {s, connected s}, cal\<Zprime> = {s} \<Zndres> cal
          , Callers\<Zprime> = Callers - {s, connected s}
          , connected\<Zprime> = {s} \<Zndres> connected]"

thm disjE

lemma ClearLine_correct: "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}ClearLine s\<^bold>{Exchange_inv\<^bold>}"
proof zpog
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list"
  assume
    pres: "s \<in> Subs" "s \<in> dom cal""fst (cal(s)\<^sub>p) = ringing" and
    invs: "Exchange Free Unavailable Callers cal connected"

  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  from pres P.connected P.Callers have scon: "s \<in> dom connected"
    by (auto simp add: st_def)

  with P.parts have ncon: "connected s \<notin> dom cal"
    by (auto)

  show "Exchange (insert s (insert (connected(s)\<^sub>p) Free)) Unavailable (Callers - {s, connected(s)\<^sub>p}) ({s} \<Zndres> cal) ({s} \<Zndres> connected)"
  proof
    show "pfun_inj ({s} \<Zndres> connected)"
      by (simp add: P.connected_inj pfun_inj_dres)
  next
    from pres P.connected_inj scon ncon show "[insert s (insert (connected(s)\<^sub>p) Free), Unavailable, dom ({s} \<Zndres> cal), ran ({s} \<Zndres> connected)] partitions Subs"
      apply (auto)
      using P.Unavailable apply force
      using P.Unavailable apply force
      using P.Free apply blast
      using P.Free apply force
      apply (metis P.nself disjoint_iff pdom_pfun_inv pfun_inv_dres ppreimageE)
      apply (metis pfun_inv_f_f_apply pdom_pfun_inv pfun_inv_dres ppreimageD subsetI subset_Compl_singleton)
      apply (metis DiffD2 P.Free UnI2 pdom_pfun_inv pfun_inv_dres ppreimageE)
      using P.Unavailable apply force
      apply (metis DiffD2 P.Unavailable UnI2 pdom_pfun_inv pfun_inv_dres ppreimageE)
      apply (metis P.ncon_call disjoint_iff pdom_pfun_inv pfun_inv_dres ppreimageE)
      apply (meson P.ran_connected_Subs pfun_app_in_ran subset_iff)
      apply (meson P.Free_Subs subsetD)
      using P.Unavailable apply force
      apply (meson P.dom_cal_Subs in_mono)
      apply (metis P.ran_connected_Subs pdom_pfun_inv pfun_inv_dres ppreimageE subset_eq)
      apply (metis DiffI P.Unavailable Un_iff insert_iff pfun_upd_ext pran_upd)
      done

  next
    from ncon P.Callers show "[{s} \<Zndres> cal]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers - {s, connected(s)\<^sub>p}"
      by (auto)
  next
    from ncon P.Callers P.connected show "(Callers - {s, connected(s)\<^sub>p}) \<Zdres> ([{s} \<Zndres> cal]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [{s} \<Zndres> connected]\<^sub>\<Zpfun>"
      by (auto simp add: pfun_eq_iff num_def st_def)
  qed
next
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list"
  assume
    pres: "s \<in> Subs" "s \<in> dom cal" "fst (cal(s)\<^sub>p) = suspended" and
    invs: "Exchange Free Unavailable Callers cal connected"

  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  from pres P.connected P.Callers have scon: "s \<in> dom connected"
    by (auto simp add: st_def)

  with P.parts have ncon: "connected s \<notin> dom cal"
    by (auto)

  show "Exchange (insert s (insert (connected(s)\<^sub>p) Free)) Unavailable (Callers - {s, connected(s)\<^sub>p}) ({s} \<Zndres> cal) ({s} \<Zndres> connected)"
  proof
    show "pfun_inj ({s} \<Zndres> connected)"
      by (simp add: P.connected_inj pfun_inj_dres)
  next
    from pres P.connected_inj scon ncon show "[insert s (insert (connected(s)\<^sub>p) Free), Unavailable, dom ({s} \<Zndres> cal), ran ({s} \<Zndres> connected)] partitions Subs"
      apply (auto)
      using P.Unavailable apply force
      using P.Unavailable apply force
      using P.Free apply blast
      using P.Free apply force
      apply (metis P.nself disjoint_iff pdom_pfun_inv pfun_inv_dres ppreimageE)
      apply (metis pfun_inv_f_f_apply pdom_pfun_inv pfun_inv_dres ppreimageD subsetI subset_Compl_singleton)
      apply (metis DiffD2 P.Free UnI2 pdom_pfun_inv pfun_inv_dres ppreimageE)
      using P.Unavailable apply force
      apply (metis DiffD2 P.Unavailable UnI2 pdom_pfun_inv pfun_inv_dres ppreimageE)
      apply (metis P.ncon_call disjoint_iff pdom_pfun_inv pfun_inv_dres ppreimageE)
      apply (meson P.ran_connected_Subs pfun_app_in_ran subset_iff)
      apply (meson P.Free_Subs subsetD)
      using P.Unavailable apply force
      apply (meson P.dom_cal_Subs in_mono)
      apply (metis P.ran_connected_Subs pdom_pfun_inv pfun_inv_dres ppreimageE subset_eq)
      apply (metis DiffI P.Unavailable Un_iff insert_iff pfun_upd_ext pran_upd)
      done
  next
    from ncon P.Callers show "[{s} \<Zndres> cal]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers - {s, connected(s)\<^sub>p}"
      by (auto)
  next
    from ncon P.Callers P.connected show "(Callers - {s, connected(s)\<^sub>p}) \<Zdres> ([{s} \<Zndres> cal]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [{s} \<Zndres> connected]\<^sub>\<Zpfun>"
      by (auto simp add: pfun_eq_iff num_def st_def)
  qed
qed

zoperation ClearConnect =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = speech"
  update "[ Free\<Zprime> = Free \<union> {s}
          , cal\<Zprime> = ({s} \<Zndres> cal) \<oplus> {connected s \<mapsto> (seize, [])}
          , Callers\<Zprime> = Callers - {s}
          , connected\<Zprime> = {s} \<Zndres> connected]"

(*
lemma ClearConnect_correct: "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}ClearConnect s\<^bold>{Exchange_inv\<^bold>}"
  unfolding ClearConnect_def
proof (hoare_wlp_auto)
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list"
  assume
    pres: "s \<in> Subs" "s \<in> dom cal" "fst (cal(s)\<^sub>p) = speech" and
    invs: "Exchange Free Unavailable Callers cal connected"

  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  from pres P.connected P.Callers have scon: "s \<in> dom connected"
    by (auto simp add: st_def)

  with P.parts have ncon: "connected s \<notin> dom cal"
    by (auto)

  show "Exchange (insert s Free) Unavailable (Callers - {s}) (({s} \<Zndres> cal)(connected(s)\<^sub>p \<mapsto> (seize, []))\<^sub>p) ({s} \<Zndres> connected)"
  proof
    show "pfun_inj ({s} \<Zndres> connected)"
      by (simp add: P.connected_inj pfun_inj_dres)
  next
    from pres P.part_props show "[insert s Free, Unavailable, dom (({s} \<Zndres> cal)(connected(s)\<^sub>p \<mapsto> (seize, []))\<^sub>p), ran ({s} \<Zndres> connected)] partitions Subs"
      apply (simp add: disjoint_iff)
  next
    show "[({s} \<Zndres> cal)(connected(s)\<^sub>p \<mapsto> (seize, []))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers - {s}" sorry
  next
    show "(Callers - {s}) \<Zdres> ([({s} \<Zndres> cal)(connected(s)\<^sub>p \<mapsto> (seize, []))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [{s} \<Zndres> connected]\<^sub>\<Zpfun>" sorry
  qed
qed

  oops
*)

zoperation ClearSuspend =
  params s \<in> Subs
  pre "s \<in> ran connected"
  update "[cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (suspended, s)}]"

zoperation ClearUnavail =
  params s \<in> Subs
  pre "s \<in> Unavailable"
  update "[Free\<Zprime> = Free \<union> {s}, Unavailable\<Zprime> = Unavailable - {s}]"

zoperation MakeUnavail =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {seize, dialling}"
  update "[Unavailable\<Zprime> = Unavailable \<union> {s}, cal\<Zprime> = {s} \<Zndres> cal]"

context Exchange
begin

lemma dom_cal_nFree: "s \<in> dom cal \<Longrightarrow> s \<notin> Free"
  using parts by (auto)

end

zoperation Connect2Ringing =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = connecting \<and> s \<notin> dom connected \<and> (cal \<Zcomp> num) s \<in> Free \<and> (cal \<Zcomp> num) s \<notin> ran connected"
  update "[ Free\<Zprime> = Free - {(cal \<Zcomp> num) s}
          \<comment> \<open> SF: Make subscriber being connected to nonfree. We don't need to remove @{term s} as it cannot be in @{term Free}: @{thm Exchange.dom_cal_nFree} \<close>
          , cal\<Zprime> = cal \<oplus> {s \<mapsto> (ringing, (cal \<Zcomp> num) s)}
          , Callers\<Zprime> = Callers \<union> {s}
          , connected\<Zprime> = connected \<oplus> {s \<mapsto> (cal \<Zcomp> num) s}]"

lemma Connect2Ringing_correct: "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}Connect2Ringing s\<^bold>{Exchange_inv\<^bold>}"
proof zpog
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list"
  assume
    pres: "s \<in> Subs" "s \<in> dom cal" "fst (cal(s)\<^sub>p) = connecting" "s \<notin> dom connected" "snd (cal(s)\<^sub>p) \<in> Free" "snd (cal(s)\<^sub>p) \<notin> ran connected" and
    invs: "Exchange Free Unavailable Callers cal connected"

  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  show "Exchange (Free - {snd (cal(s)\<^sub>p)}) Unavailable (insert s Callers) (cal(s \<mapsto> (ringing, snd (cal(s)\<^sub>p)))\<^sub>p) (connected(s \<mapsto> snd (cal(s)\<^sub>p))\<^sub>p)"
  proof
    from pres P.parts show "[Free - {snd (cal(s)\<^sub>p)}, Unavailable, dom (cal(s \<mapsto> (ringing, snd (cal(s)\<^sub>p)))\<^sub>p), ran (connected(s \<mapsto> snd (cal(s)\<^sub>p))\<^sub>p)] partitions Subs"
      by (auto simp add: Connected_def st_def num_def)
  next
    from P.Callers show "[cal(s \<mapsto> (ringing, snd (cal(s)\<^sub>p)))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = insert s Callers"
      by (simp add: st_def Connected_def)
  next
    from pres P.Callers P.connected P.dom_connected_Callers show "insert s Callers \<Zdres> ([cal(s \<mapsto> (ringing, snd (cal(s)\<^sub>p)))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [connected(s \<mapsto> snd (cal(s)\<^sub>p))\<^sub>p]\<^sub>\<Zpfun>"
      by (auto simp add: num_def st_def Connected_def pfun_eq_iff)
  next
    show "pfun_inj (connected(s \<mapsto> snd (cal(s)\<^sub>p))\<^sub>p)"
      by (simp add: P.connected_inj pfun_inj_upd pres(6))
  qed
qed

zoperation Connect2Engaged =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = connecting \<and> s \<notin> dom connected \<and> (cal \<Zcomp> num) s \<notin> Free"
  update "[ cal\<Zprime> = cal \<oplus> {s \<mapsto> (engaged, (cal \<Zcomp> num) s)} ]"

lemma Connect2Engaged_correct: "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}Connect2Engaged s\<^bold>{Exchange_inv\<^bold>}"
proof zpog
  fix Free :: "\<bbbP> integer list" and Unavailable :: "\<bbbP> integer list" and Callers :: "\<bbbP> integer list" and cal :: "integer list \<Zpfun>
                        Status \<times> integer list" and connected :: "integer list \<Zpfun> integer list"
  assume
    pres: "s \<in> Subs" "s \<in> dom cal" "fst (cal(s)\<^sub>p) = connecting" "s \<notin> dom connected" "snd (cal(s)\<^sub>p) \<notin> Free" and
    invs: "Exchange Free Unavailable Callers cal connected"
  then interpret P: Exchange Free Unavailable Callers cal connected
    by simp

  show "Exchange Free Unavailable Callers (cal(s \<mapsto> (engaged, snd (cal(s)\<^sub>p)))\<^sub>p) connected"
  proof
    show "pfun_inj connected"
      by (simp add: P.connected_inj)
  next
    show "[Free, Unavailable, dom (cal(s \<mapsto> (engaged, snd (cal(s)\<^sub>p)))\<^sub>p), ran connected] partitions Subs"
      using pres P.parts by auto
  next
    from pres P.Callers  show "[cal(s \<mapsto> (engaged, snd (cal(s)\<^sub>p)))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [st]\<^sub>\<Zpfun>\<^sup>\<leftarrow> Connected = Callers"
      by (auto simp add: st_def)
         (metis Compl_iff connecting_nConnected empty_iff fst_conv insert_iff pdom_res_apply)
  next
    from pres P.connected P.Callers P.dom_connected_Callers show "Callers \<Zdres> ([cal(s \<mapsto> (engaged, snd (cal(s)\<^sub>p)))\<^sub>p]\<^sub>\<Zpfun> \<Zcomp> [num]\<^sub>\<Zpfun>) = [connected]\<^sub>\<Zpfun>"
      by (auto simp add: num_def pfun_eq_iff)
  qed
qed

zmachine TelephoneExchange =
  over Exchange
  init "InitExchange"
  operations
    LiftFree LiftSuspended Answer Dial
    ClearAttempt ClearLine ClearConnect ClearSuspend ClearUnavail
    MakeUnavail
    Connect2Ringing Connect2Engaged

def_consts Subs = "{[1,2,3], [3,4,5], [6,7,8]}"

animate TelephoneExchange

end