(* trans_sim.thy *)
(* William Mansky *)
(* The basics of simulation relations on tCFGs. *)

theory trans_sim
imports trans_semantics "$AFP/JinjaThreads/Framework/Bisimulation"
begin

lemmas zero_enat_def [simp del] option.splits [split del]

definition trsys_of_tCFG where
"trsys_of_tCFG       CFGs     step_rel      obs       get_mem C l C' \<equiv>
step_rel CFGs C C' \<and> l = get_mem C' |` obs"
(* This needs to reflect the actual changes made! *)

abbreviation "trsys_of_tCFG_full CFGs step_rel \<equiv> trsys_of_tCFG CFGs step_rel UNIV"
lemma dom_UNIV [simp]: "dom l = UNIV \<Longrightarrow> m ++ l = l"
by (rule ext, case_tac "l x", auto)

(* One-directional simulation, modified from the bisimulation theory of JinjaThreads *)
locale simulation = bisimulation_base +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
assumes simulation: "\<lbrakk>sa \<approx> sb; sa -1-tl1\<rightarrow> sa'\<rbrakk> \<Longrightarrow> \<exists>sb' tl2. sb -2-tl2\<rightarrow> sb' \<and> sa' \<approx> sb' \<and> tl1 \<sim> tl2"
begin

lemma simulation_rtrancl:
  "[|s1 -1-tls1\<rightarrow>* s1'; s1 \<approx> s2|]
  ==> \<exists>s2' tls2. s2 -2-tls2\<rightarrow>* s2' \<and> s1' \<approx> s2' \<and> tls1 [\<sim>] tls2"
proof(induct rule: rtrancl3p.induct)
  case rtrancl3p_refl thus ?case by(auto intro: rtrancl3p.rtrancl3p_refl)
next
  case (rtrancl3p_step s1 tls1 s1' tl1 s1'')
  from `s1 \<approx> s2 ==> \<exists>s2' tls2. s2 -2-tls2\<rightarrow>* s2' \<and> s1' \<approx> s2' \<and> tls1 [\<sim>] tls2` `s1 \<approx> s2`
  obtain s2' tls2 where "s2 -2-tls2\<rightarrow>* s2'" "s1' \<approx> s2'" "tls1 [\<sim>] tls2" by blast
  moreover from `s1' -1-tl1\<rightarrow> s1''` `s1' \<approx> s2'`
  obtain s2'' tl2 where "s2' -2-tl2\<rightarrow> s2''" "s1'' \<approx> s2''" "tl1 \<sim> tl2" by(auto dest: simulation)
  ultimately have "s2 -2-tls2 @ [tl2]\<rightarrow>* s2''" "tls1 @ [tl1] [\<sim>] tls2 @ [tl2]"
    by(auto intro: rtrancl3p.rtrancl3p_step list_all2_appendI)
  with `s1'' \<approx> s2''` show ?case by(blast)
qed

definition tl1_to_tl2 where
"tl1_to_tl2 = (\<lambda>(s2 :: 's2) (stls1 :: ('s1 \<times> 'tl1 \<times> 's1) llist). unfold_llist
     (\<lambda>(s2, stls1). lnull stls1)
     (\<lambda>(s2, stls1). let (s1, tl1, s1') = lhd stls1;
                        (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2
                    in (s2, tl2, s2'))
     (\<lambda>(s2, stls1). let (s1, tl1, s1') = lhd stls1;
                        (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2
                    in (s2', ltl stls1))
     (s2, stls1))"

lemma simulation_inf_step:
  assumes red1: "s1 -1-tls1\<rightarrow>* \<infinity>" and bisim: "s1 \<approx> s2"
  shows "\<exists>tls2. s2 -2-tls2\<rightarrow>* \<infinity> \<and> tls1 [[\<sim>]] tls2"
proof -
  from r1.inf_step_imp_inf_step_table[OF red1]
  obtain stls1 where red1': "s1 -1-stls1\<rightarrow>*t \<infinity>"
    and tls1: "tls1 = lmap (fst \<circ> snd) stls1" by blast
  have tl1_to_tl2_simps [simp]:
    "\<And>s2 stls1. lnull (tl1_to_tl2 s2 stls1) \<longleftrightarrow> lnull stls1"
    "\<And>s2 stls1. \<not> lnull stls1 \<Longrightarrow> lhd (tl1_to_tl2 s2 stls1) =
    (let (s1, tl1, s1') = lhd stls1;
         (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2
     in (s2, tl2, s2'))"
    "\<And>s2 stls1. \<not> lnull stls1 \<Longrightarrow> ltl (tl1_to_tl2 s2 stls1) =
    (let (s1, tl1, s1') = lhd stls1;
         (tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2
     in tl1_to_tl2 s2' (ltl stls1))"
    "\<And>s2. tl1_to_tl2 s2 LNil = LNil"
    "\<And>s2 s1 tl1 s1' stls1'. tl1_to_tl2 s2 (LCons (s1, tl1, s1') stls1') =
        LCons (s2, SOME (tl2, s2'). trsys2 s2 tl2 s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2)
              (tl1_to_tl2 (snd (SOME (tl2, s2'). trsys2 s2 tl2 s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2)) stls1')"
    by(simp_all add: tl1_to_tl2_def split_beta)

  have [simp]: "llength (tl1_to_tl2 s2 stls1) = llength stls1"
    by(coinduction arbitrary: s2 stls1 rule: enat_coinduct)(auto simp add: epred_llength split_beta)

  from red1' bisim have "s2 -2-tl1_to_tl2 s2 stls1\<rightarrow>*t \<infinity>"
  proof(coinduction arbitrary: s2 s1 stls1)
    case (inf_step_table s2 s1 stls1)
    note red1' = `s1 -1-stls1\<rightarrow>*t \<infinity>` and bisim = `s1 \<approx> s2`
    from red1' show ?case
    proof(cases)
      case (inf_step_tableI s1' stls1' tl1)
      hence stls1: "stls1 = LCons (s1, tl1, s1') stls1'"
        and r: "s1 -1-tl1\<rightarrow> s1'" and reds1: "s1' -1-stls1'\<rightarrow>*t \<infinity>" by simp_all
      let ?tl2s2' = "SOME (tl2, s2'). s2 -2-tl2\<rightarrow> s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2"
      let ?tl2 = "fst ?tl2s2'" let ?s2' = "snd ?tl2s2'"
      from simulation[OF bisim r] obtain s2' tl2
        where "s2 -2-tl2\<rightarrow> s2'" "s1' \<approx> s2'" "tl1 \<sim> tl2" by blast
      hence "(\<lambda>(tl2, s2'). s2 -2-tl2\<rightarrow> s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2) (tl2, s2')" by simp
      hence "(\<lambda>(tl2, s2'). s2 -2-tl2\<rightarrow> s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2) ?tl2s2'" by(rule someI)
      hence "s2 -2-?tl2\<rightarrow> ?s2'" "s1' \<approx> ?s2'" "tl1 \<sim> ?tl2" by(simp_all add: split_beta)
      then show ?thesis using reds1 stls1 by(fastforce intro: prod_eqI)
    qed
  qed
  hence "s2 -2-lmap (fst \<circ> snd) (tl1_to_tl2 s2 stls1)\<rightarrow>* \<infinity>"
    by(rule r2.inf_step_table_imp_inf_step)
  moreover have "tls1 [[\<sim>]] lmap (fst \<circ> snd) (tl1_to_tl2 s2 stls1)"
  proof(rule llist_all2_all_lnthI)
    show "llength tls1 = llength (lmap (fst \<circ> snd) (tl1_to_tl2 s2 stls1))"
      using tls1 by simp
  next
    fix n
    assume "enat n < llength tls1"
    thus "lnth tls1 n \<sim> lnth (lmap (fst \<circ> snd) (tl1_to_tl2 s2 stls1)) n"
      using red1' bisim unfolding tls1
    proof(induct n arbitrary: s1 s2 stls1 rule: nat_less_induct)
      case (1 n)
      hence IH: "\<And>m s1 s2 stls1. \<lbrakk> m < n; enat m < llength (lmap (fst \<circ> snd) stls1);
                                   s1 -1-stls1\<rightarrow>*t \<infinity>; s1 \<approx> s2 \<rbrakk>
                 \<Longrightarrow> lnth (lmap (fst \<circ> snd) stls1) m \<sim> lnth (lmap (fst \<circ> snd) (tl1_to_tl2 s2 stls1)) m"
        by blast
      from `s1 -1-stls1\<rightarrow>*t \<infinity>` show ?case
      proof cases
        case (inf_step_tableI s1' stls1' tl1)
        hence  stls1: "stls1 = LCons (s1, tl1, s1') stls1'"
          and r: "s1 -1-tl1\<rightarrow> s1'" and reds: "s1' -1-stls1'\<rightarrow>*t \<infinity>" by simp_all
        let ?tl2s2' = "SOME (tl2, s2').  s2 -2-tl2\<rightarrow> s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2"
        let ?tl2 = "fst ?tl2s2'" let ?s2' = "snd ?tl2s2'"
        from simulation[OF `s1 \<approx> s2` r] obtain s2' tl2
          where "s2 -2-tl2\<rightarrow> s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2" by blast
        hence "(\<lambda>(tl2, s2'). s2 -2-tl2\<rightarrow> s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2) (tl2, s2')" by simp
        hence "(\<lambda>(tl2, s2'). s2 -2-tl2\<rightarrow> s2' \<and> s1' \<approx> s2' \<and> tl1 \<sim> tl2) ?tl2s2'" by(rule someI)
        hence bisim': "s1' \<approx> ?s2'" and tlsim: "tl1 \<sim> ?tl2" by(simp_all add: split_beta)
        show ?thesis
        proof(cases n)
          case 0
          with stls1 tlsim show ?thesis by simp
        next
          case (Suc m)
          hence "m < n" by simp
          moreover have "enat m < llength (lmap (fst \<circ> snd) stls1')"
            using stls1 `enat n < llength (lmap (fst \<circ> snd) stls1)` Suc by(simp add: Suc_ile_eq)
          ultimately have "lnth (lmap (fst \<circ> snd) stls1') m \<sim> lnth (lmap (fst \<circ> snd) (tl1_to_tl2 ?s2' stls1')) m"
            using reds bisim' by(rule IH)
          with Suc stls1 show ?thesis by(simp del: o_apply)
        qed
      qed
    qed
  qed
  ultimately show ?thesis by blast
qed

end

sublocale bisimulation \<subseteq> simulation
by (unfold_locales, simp add: simulation1)

locale tCFG_bisim = bisimulation where trsys1 = "trsys_of_tCFG CFGs step_rel obs get_mem"
 and trsys2 = "trsys_of_tCFG CFGs' step_rel obs get_mem" for CFGs CFGs' step_rel obs get_mem

locale tCFG_sim = simulation where
 trsys1 = "trsys_of_tCFG CFGs step_rel obs get_mem" and
 trsys2 = "trsys_of_tCFG CFGs' step_rel obs get_mem"
 for CFGs CFGs' step_rel obs get_mem

definition (in TRANS_basics) "opt_sim T sim tlsim step_rel obs get_mem \<equiv>
  \<forall>\<tau> CFGs. tCFG CFGs instr_edges Seq \<longrightarrow> (\<forall>CFGs' \<in> trans_sf T \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and>
    tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem)"

(* composition *)
lemma sim_comp: "\<lbrakk>tCFG_sim sim tlsim CFGs CFGs' step_rel obs get_mem;
  tCFG_sim sim' tlsim' CFGs' CFGs'' step_rel obs get_mem\<rbrakk> \<Longrightarrow>
tCFG_sim (sim \<circ>\<^sub>B sim') (tlsim \<circ>\<^sub>B tlsim') CFGs CFGs'' step_rel obs get_mem"
apply (clarsimp simp add: tCFG_sim_def simulation_def bisim_compose_def trsys_of_tCFG_def)
by (metis (hide_lams, mono_tags))

context TRANS_basics begin

lemma then_sim [intro]: "\<lbrakk>opt_sim T1 sim1 tlsim1 step_rel obs get_mem; opt_sim T2 sim2 tlsim2 step_rel obs get_mem\<rbrakk> \<Longrightarrow>
  opt_sim (TThen T1 T2) (sim2 \<circ>\<^sub>B sim1) (tlsim2 \<circ>\<^sub>B tlsim1) step_rel obs get_mem"
unfolding opt_sim_def
apply clarify
apply (erule_tac x=\<tau> in allE, erule_tac x=CFGs in allE, erule impE, simp, clarsimp)
apply (erule_tac x=CFGs'a in ballE, simp_all)
apply (erule_tac x=\<tau> in allE, erule_tac x=CFGs'a in allE, erule impE, simp,
  erule_tac x=CFGs' in ballE, simp_all, clarsimp)
apply (rule sim_comp, simp_all)
done

lemma applysome_sim: "\<lbrakk>opt_sim T sim tlsim step_rel obs get_mem; apply_some (trans_sf T) \<tau> CFGs CFGs';
  tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  tCFG CFGs' instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_sim sim' tlsim' CFGs' CFGs step_rel obs get_mem)"
apply (clarsimp simp add: opt_sim_def, drule_tac P="\<lambda>t \<tau> G G'. t = trans_sf T \<and> tCFG G instr_edges Seq \<longrightarrow>
  (tCFG G' instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_sim sim' tlsim' G' G step_rel obs get_mem))"
  in apply_some.induct, auto)
apply (rule_tac x="(=)" in exI, rule_tac x="(=)" in exI, unfold_locales, force)
apply (erule_tac x=\<tau> in allE, erule_tac x=G in allE, simp, erule_tac x=G' in ballE, simp_all, clarsimp)
apply (rule exI, rule exI, rule sim_comp, simp+)
done

(* is this sufficient? *)
definition "trans_sim T step_rel obs get_mem \<equiv>
  \<forall>\<tau> CFGs. tCFG CFGs instr_edges Seq \<longrightarrow> (\<forall>CFGs' \<in> trans_sf T \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and>
    (\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem))"

lemma opt_sim_trans [intro]: "opt_sim T sim tlsim step_rel obs get_mem \<Longrightarrow> trans_sim T step_rel obs get_mem"
by (force simp add: opt_sim_def trans_sim_def)

definition "cond_sim P T step_rel obs get_mem \<equiv> \<forall>\<tau> CFGs. P \<tau> CFGs \<and> tCFG CFGs instr_edges Seq \<longrightarrow>
  (\<forall>CFGs' \<in> trans_sf T \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and>
    (\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem))"

lemma cond_simI [intro]: "(\<And>\<tau> CFGs CFGs'. \<lbrakk>P \<tau> CFGs; tCFG CFGs instr_edges Seq; CFGs' \<in> trans_sf T \<tau> CFGs\<rbrakk> \<Longrightarrow>
  tCFG CFGs' instr_edges Seq \<and> (\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem))
  \<Longrightarrow> cond_sim P T step_rel obs get_mem"
by (force simp add: cond_sim_def)

lemma applyall_sim [intro]: "opt_sim T sim tlsim step_rel obs get_mem \<Longrightarrow> trans_sim (TApplyAll T) step_rel obs get_mem"
apply (clarsimp simp add: trans_sim_def)
by (metis applysome_sim)

lemma match_cond_sim [intro]: "cond_sim (\<lambda>\<tau> CFGs. \<exists>\<sigma> \<tau>'. side_cond_sf \<phi> \<sigma> CFGs \<and> part_matches \<sigma> \<tau>' \<and>
  \<tau> = part_extend \<tau>' (cond_fv pred_fv \<phi>) \<sigma>) T step_rel obs get_mem \<Longrightarrow>
  trans_sim (TMatch \<phi> T) step_rel obs get_mem"
apply (clarsimp simp add: trans_sim_def cond_sim_def)
by metis

lemma then_cond_sim [intro]: "\<lbrakk>cond_sim P T1 step_rel obs get_mem; cond_sim P T2 step_rel obs get_mem;
  \<forall>\<tau> CFGs CFGs'. P \<tau> CFGs \<and> CFGs' \<in> trans_sf T1 \<tau> CFGs \<longrightarrow> P \<tau> CFGs'\<rbrakk> \<Longrightarrow>
  cond_sim P (TThen T1 T2) step_rel obs get_mem"
unfolding cond_sim_def proof clarify
  fix CFGs \<tau> CFGs' assume "CFGs' \<in> trans_sf (TThen T1 T2) \<tau> CFGs"
  hence "\<exists>CFGs''. CFGs'' \<in> trans_sf T1 \<tau> CFGs \<and> CFGs' \<in> trans_sf T2 \<tau> CFGs''" by simp
  then obtain CFGs'' where A: "CFGs'' \<in> trans_sf T1 \<tau> CFGs \<and> CFGs' \<in> trans_sf T2 \<tau> CFGs''" ..
  assume P: "P \<tau> CFGs" "tCFG CFGs instr_edges Seq" "\<forall>\<tau> CFGs. P \<tau> CFGs \<and> tCFG CFGs instr_edges Seq \<longrightarrow>
  (\<forall>CFGs'\<in>trans_sf T1 \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and> (\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem))"
  from this A have tCFG'': "tCFG CFGs'' instr_edges Seq" "\<exists>sim tlsim. tCFG_sim sim tlsim CFGs'' CFGs step_rel obs get_mem" by auto
  then obtain sim tlsim where sim: "tCFG_sim sim tlsim CFGs'' CFGs step_rel obs get_mem" by auto
  assume "\<forall>\<tau> CFGs CFGs'. P \<tau> CFGs \<and> CFGs' \<in> trans_sf T1 \<tau> CFGs \<longrightarrow> P \<tau> CFGs'"
  from this P A have P'': "P \<tau> CFGs''" by metis
  assume "\<forall>\<tau> CFGs. P \<tau> CFGs \<and> tCFG CFGs instr_edges Seq \<longrightarrow> (\<forall>CFGs'\<in>trans_sf T2 \<tau> CFGs. tCFG CFGs'
  instr_edges Seq \<and> (\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem))"
  from this P'' tCFG'' A have tCFG': "tCFG CFGs' instr_edges Seq"
    "\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs'' step_rel obs get_mem" by auto
  then obtain sim' tlsim' where sim': "tCFG_sim sim' tlsim' CFGs' CFGs'' step_rel obs get_mem" by auto
  show "tCFG CFGs' instr_edges Seq \<and> (\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem)"
  proof
    from tCFG' show "tCFG CFGs' instr_edges Seq" by simp
    next show "\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem"
    proof ((rule exI)+, rule sim_comp)
      from sim show "tCFG_sim sim tlsim CFGs'' CFGs step_rel obs get_mem" .
      from sim' show "tCFG_sim sim' tlsim' CFGs' CFGs'' step_rel obs get_mem" .
    qed
  qed
qed

(* Why is this so slow in apply-style? *)

lemma applysome_cond_sim: "\<lbrakk>apply_some (trans_sf T) \<tau> CFGs CFGs'; cond_sim P T step_rel obs get_mem;
  \<forall>\<tau> CFGs CFGs'. (P \<tau> CFGs \<and> CFGs' \<in> trans_sf T \<tau> CFGs) \<longrightarrow> P \<tau> CFGs'; P \<tau> CFGs; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  tCFG CFGs' instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_sim sim' tlsim' CFGs' CFGs step_rel obs get_mem)"
unfolding cond_sim_def proof (induct rule: apply_some.induct)
  fix G::"'thread \<Rightarrow> ('node, 'edge_type, 'instr) flowgraph option" assume "tCFG G instr_edges Seq"
  thus "tCFG G instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_sim sim' tlsim' G G step_rel obs get_mem)"
  proof
    have "tCFG_sim (=) (=) G G step_rel obs get_mem" by (unfold_locales, simp)
    thus "\<exists>sim' tlsim'. tCFG_sim sim' tlsim' G G step_rel obs get_mem" by force
  qed
next
  case (apply_more G' T \<tau> G G'') hence G'': "tCFG G'' instr_edges Seq \<and>
  (\<exists>sim' tlsim'. tCFG_sim sim' tlsim' G'' G' step_rel obs get_mem)" by metis
  then obtain sim' tlsim' where sim': "tCFG_sim sim' tlsim' G'' G' step_rel obs get_mem" by force
  moreover assume "G' \<in> T \<tau> G" "P \<tau> G" "tCFG G instr_edges Seq"
  "\<forall>\<tau> CFGs. P \<tau> CFGs \<and> tCFG CFGs instr_edges Seq \<longrightarrow> (\<forall>CFGs'\<in>T \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and>
  (\<exists>sim tlsim. tCFG_sim sim tlsim CFGs' CFGs step_rel obs get_mem))"
  then obtain sim tlsim where sim: "tCFG_sim sim tlsim G' G step_rel obs get_mem" by force
  have "\<exists>sim' tlsim'. tCFG_sim sim' tlsim' G'' G step_rel obs get_mem"
    proof ((rule exI)+, rule sim_comp)
      show "tCFG_sim sim' tlsim' G'' G' step_rel obs get_mem" by (rule sim')
      next show "tCFG_sim sim tlsim G' G step_rel obs get_mem" by (rule sim)
    qed
  from this G'' show ?case by simp
qed

lemma applyall_cond_sim [intro]: "\<lbrakk>cond_sim P T step_rel obs get_mem;
  \<forall>\<tau> CFGs CFGs'. P \<tau> CFGs \<and> CFGs' \<in> trans_sf T \<tau> CFGs \<longrightarrow> P \<tau> CFGs'\<rbrakk> \<Longrightarrow>
  cond_sim P (TApplyAll T) step_rel obs get_mem"
by (clarsimp intro!: cond_simI simp add: applysome_cond_sim)

end

(* stuttering bisimulation *)
locale delay_bisimulation_base =
  bisimulation_base +
  trsys1: \<tau>trsys trsys1 \<tau>move1 +
  trsys2: \<tau>trsys trsys2 \<tau>move2
  for \<tau>move1 \<tau>move2 +
  constrains trsys1 :: "('s1, 'tl1) trsys"
  and trsys2 :: "('s2, 'tl2) trsys"
  and bisim :: "('s1, 's2) bisim"
  and tlsim :: "('tl1, 'tl2) bisim"
  and \<tau>move1 :: "('s1, 'tl1) trsys"
  and \<tau>move2 :: "('s2, 'tl2) trsys"
begin

notation
  trsys1.silent_move ("_/ -\<tau>1\<rightarrow> _" [50, 50] 60) and
  trsys2.silent_move ("_/ -\<tau>2\<rightarrow> _" [50, 50] 60)

notation
  trsys1.silent_moves ("_/ -\<tau>1\<rightarrow>* _" [50, 50] 60) and
  trsys2.silent_moves ("_/ -\<tau>2\<rightarrow>* _" [50, 50] 60)

notation
  trsys1.silent_movet ("_/ -\<tau>1\<rightarrow>+ _" [50, 50] 60) and
  trsys2.silent_movet ("_/ -\<tau>2\<rightarrow>+ _" [50, 50] 60)

notation
  trsys1.\<tau>rtrancl3p ("_ -\<tau>1-_\<rightarrow>* _" [50, 0, 50] 60) and
  trsys2.\<tau>rtrancl3p ("_ -\<tau>2-_\<rightarrow>* _" [50, 0, 50] 60)

notation
  trsys1.\<tau>inf_step ("_ -\<tau>1-_\<rightarrow>* \<infinity>" [50, 0] 80) and
  trsys2.\<tau>inf_step ("_ -\<tau>2-_\<rightarrow>* \<infinity>" [50, 0] 80)

notation
  trsys1.\<tau>diverge ("_ -\<tau>1\<rightarrow> \<infinity>" [50] 80) and
  trsys2.\<tau>diverge ("_ -\<tau>2\<rightarrow> \<infinity>" [50] 80)

notation
  trsys1.\<tau>inf_step_table ("_ -\<tau>1-_\<rightarrow>*t \<infinity>" [50, 0] 80) and
  trsys2.\<tau>inf_step_table ("_ -\<tau>2-_\<rightarrow>*t \<infinity>" [50, 0] 80)

notation
  trsys1.\<tau>Runs ("_ \<Down>1 _" [50, 50] 51) and
  trsys2.\<tau>Runs ("_ \<Down>2 _" [50, 50] 51)

lemma simulation_silent1I':
  assumes "\<exists>s2'. (if \<mu>1 s1' s1 then trsys2.silent_moves else trsys2.silent_movet) s2 s2' \<and> s1' \<approx> s2'"
  shows "s1' \<approx> s2 \<and> \<mu>1^++ s1' s1 \<or> (\<exists>s2'. s2 -\<tau>2\<rightarrow>+ s2' \<and> s1' \<approx> s2')"
proof -
  from assms obtain s2' where red: "(if \<mu>1 s1' s1 then trsys2.silent_moves else trsys2.silent_movet) s2 s2'"
    and bisim: "s1' \<approx> s2'" by blast
  show ?thesis
  proof(cases "\<mu>1 s1' s1")
    case True
    with red have "s2 -\<tau>2\<rightarrow>* s2'" by simp
    thus ?thesis using bisim True by cases(blast intro: rtranclp_into_tranclp1)+
  next
    case False
    with red bisim show ?thesis by auto
  qed
qed

lemma simulation_silent2I':
  assumes "\<exists>s1'. (if \<mu>2 s2' s2 then trsys1.silent_moves else trsys1.silent_movet) s1 s1' \<and> s1' \<approx> s2'"
  shows "s1 \<approx> s2' \<and> \<mu>2^++ s2' s2 \<or> (\<exists>s1'. s1 -\<tau>1\<rightarrow>+ s1' \<and> s1' \<approx> s2')"
using assms
by(rule delay_bisimulation_base.simulation_silent1I')

end

locale delay_simulation_obs = delay_bisimulation_base _ _ _ _ \<tau>move1 \<tau>move2
  for \<tau>move1 :: "'s1 => 'tl1 => 's1 => bool"
  and \<tau>move2 :: "'s2 => 'tl2 => 's2 => bool" +
  assumes simulation:
  "\<lbrakk> s1 \<approx> s2; s1 -1-tl1\<rightarrow> s1'; \<not> \<tau>move1 s1 tl1 s1' \<rbrakk>
  \<Longrightarrow> \<exists>s2' s2'' tl2. s2 -\<tau>2\<rightarrow>* s2' \<and> s2' -2-tl2\<rightarrow> s2'' \<and> \<not> \<tau>move2 s2' tl2 s2'' \<and> s1' \<approx> s2'' \<and> tl1 \<sim> tl2"

locale delay_simulation_diverge = delay_simulation_obs _ _ _ _ \<tau>move1 \<tau>move2
  for \<tau>move1 :: "'s1 => 'tl1 => 's1 => bool"
  and \<tau>move2 :: "'s2 => 'tl2 => 's2 => bool" +
  assumes simulation_silent:
  "[| s1 \<approx> s2; s1 -\<tau>1\<rightarrow> s1' |] ==> \<exists>s2'. s2 -\<tau>2\<rightarrow>* s2' \<and> s1' \<approx> s2'"
  and \<tau>diverge_sim_inv: "s1 \<approx> s2 ==> s1 -\<tau>1\<rightarrow> \<infinity> ==> s2 -\<tau>2\<rightarrow> \<infinity>"
begin

lemma simulation_silents:
  assumes bisim: "s1 \<approx> s2" and moves: "s1 -\<tau>1\<rightarrow>* s1'"
  shows "\<exists>s2'. s2 -\<tau>2\<rightarrow>* s2' \<and> s1' \<approx> s2'"
using moves bisim
proof induct
  case base thus ?case by(blast)
next
  case (step s1' s1'')
  from `s1 \<approx> s2 ==> \<exists>s2'. s2 -\<tau>2\<rightarrow>* s2' \<and> s1' \<approx> s2'` `s1 \<approx> s2`
  obtain s2' where "s2 -\<tau>2\<rightarrow>* s2'" "s1' \<approx> s2'" by blast
  from simulation_silent[OF `s1' \<approx> s2'` `s1' -\<tau>1\<rightarrow> s1''`]
  obtain s2'' where "s2' -\<tau>2\<rightarrow>* s2''" "s1'' \<approx> s2''" by blast
  from `s2 -\<tau>2\<rightarrow>* s2'` `s2' -\<tau>2\<rightarrow>* s2''` have "s2 -\<tau>2\<rightarrow>* s2''" by(rule rtranclp_trans)
  with `s1'' \<approx> s2''` show ?case by blast
qed

lemma simulation_\<tau>rtrancl3p:
  "[| s1 -\<tau>1-tls1\<rightarrow>* s1'; s1 \<approx> s2 |]
  ==> \<exists>tls2 s2'. s2 -\<tau>2-tls2\<rightarrow>* s2' \<and> s1' \<approx> s2' \<and> tls1 [\<sim>] tls2"
proof(induct arbitrary: s2 rule: trsys1.\<tau>rtrancl3p.induct)
  case (\<tau>rtrancl3p_refl s)
  thus ?case by(auto intro: \<tau>trsys.\<tau>rtrancl3p.intros)
next
  case (\<tau>rtrancl3p_step s1 s1' tls1 s1'' tl1)
  from simulation[OF `s1 \<approx> s2` `s1 -1-tl1\<rightarrow> s1'` `\<not> \<tau>move1 s1 tl1 s1'`]
  obtain s2' s2'' tl2 where \<tau>red: "s2 -\<tau>2\<rightarrow>* s2'"
    and red: "s2' -2-tl2\<rightarrow> s2''" and n\<tau>: "\<not> \<tau>move2 s2' tl2 s2''"
    and bisim': "s1' \<approx> s2''" and tlsim: "tl1 \<sim> tl2" by blast
  from bisim' `s1' \<approx> s2'' ==> \<exists>tls2 s2'. s2'' -\<tau>2-tls2\<rightarrow>* s2' \<and> s1'' \<approx> s2' \<and> tls1 [\<sim>] tls2`
  obtain tls2 s2''' where IH: "s2'' -\<tau>2-tls2\<rightarrow>* s2'''" "s1'' \<approx> s2'''" "tls1 [\<sim>] tls2" by blast
  from \<tau>red have "s2 -\<tau>2-[]\<rightarrow>* s2'" by(rule trsys2.silent_moves_into_\<tau>rtrancl3p)
  also from red n\<tau> IH(1) have "s2' -\<tau>2-tl2 # tls2\<rightarrow>* s2'''"
    using trsys2.\<tau>rtrancl3p_step by auto
  finally show ?case using IH tlsim by fastforce
next
  case (\<tau>rtrancl3p_\<tau>step s1 s1' tls1 s1'' tl1)
  from `s1 -1-tl1\<rightarrow> s1'` `\<tau>move1 s1 tl1 s1'` have "s1 -\<tau>1\<rightarrow> s1'" ..
  from simulation_silent[OF `s1 \<approx> s2` this]
  obtain s2' where \<tau>red: "s2 -\<tau>2\<rightarrow>* s2'" and bisim': "s1' \<approx> s2'" by blast
  from \<tau>red have "s2 -\<tau>2-[]\<rightarrow>* s2'" by(rule trsys2.silent_moves_into_\<tau>rtrancl3p)
  also from bisim' `s1' \<approx> s2' ==> \<exists>tls2 s2''. s2' -\<tau>2-tls2\<rightarrow>* s2'' \<and> s1'' \<approx> s2'' \<and> tls1 [\<sim>] tls2`
  obtain tls2 s2'' where IH: "s2' -\<tau>2-tls2\<rightarrow>* s2''" "s1'' \<approx> s2''" "tls1 [\<sim>] tls2" by blast
  note `s2' -\<tau>2-tls2\<rightarrow>* s2''`
  finally show ?case using IH by auto
qed

definition tl1_to_tl2 where
"tl1_to_tl2 = (\<lambda>(s2 :: 's2) (sstls1 :: ('s1 \<times> 's1 \<times> 'tl1 \<times> 's1) llist). unfold_llist
     (\<lambda>(s2, sstls1). lnull sstls1)
     (\<lambda>(s2, sstls1).
        let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and>
                                     \<not> \<tau>move2 s2' tl2 s2'' \<and>  s1'' \<approx> s2'' \<and> tl1 \<sim> tl2
        in (s2, s2', tl2, s2''))
     (\<lambda>(s2, sstls1).
        let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and>
                                     \<not> \<tau>move2 s2' tl2 s2'' \<and>  s1'' \<approx> s2'' \<and> tl1 \<sim> tl2
        in (s2'', ltl sstls1))
     (s2, sstls1))"

lemma simulation_\<tau>inf_step:
  assumes \<tau>inf1: "s1 -\<tau>1-tls1\<rightarrow>* \<infinity>" and bisim: "s1 \<approx> s2"
  shows "\<exists>tls2. s2 -\<tau>2-tls2\<rightarrow>* \<infinity> \<and> tls1 [[\<sim>]] tls2"
proof -
  from trsys1.\<tau>inf_step_imp_\<tau>inf_step_table[OF \<tau>inf1]
  obtain sstls1 where \<tau>inf1': "s1 -\<tau>1-sstls1\<rightarrow>*t \<infinity>"
    and tls1: "tls1 = lmap (fst \<circ> snd \<circ> snd) sstls1" by blast
  have [simp]:
    "\<And>s2 sstls1. lnull (tl1_to_tl2 s2 sstls1) \<longleftrightarrow> lnull sstls1"
    "\<And>s2 sstls1. \<not> lnull sstls1 \<Longrightarrow> lhd (tl1_to_tl2 s2 sstls1) =
        (let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and>
                                     \<not> \<tau>move2 s2' tl2 s2'' \<and>  s1'' \<approx> s2'' \<and> tl1 \<sim> tl2
        in (s2, s2', tl2, s2''))"
    "\<And>s2 sstls1. \<not> lnull sstls1 \<Longrightarrow> ltl (tl1_to_tl2 s2 sstls1) =
        (let (s1, s1', tl1, s1'') = lhd sstls1;
            (s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and>
                                     \<not> \<tau>move2 s2' tl2 s2'' \<and>  s1'' \<approx> s2'' \<and> tl1 \<sim> tl2
        in tl1_to_tl2 s2'' (ltl sstls1))"
    "\<And>s2. tl1_to_tl2 s2 LNil = LNil"
    "\<And>s2 s1 s1' tl1 s1'' stls1'. tl1_to_tl2 s2 (LCons (s1, s1', tl1, s1'') stls1') =
        LCons (s2, SOME (s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and>
                                          \<not> \<tau>move2 s2' tl2 s2'' \<and> s1'' \<approx> s2'' \<and> tl1 \<sim> tl2)
              (tl1_to_tl2 (snd (snd (SOME (s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and>
                                                            \<not> \<tau>move2 s2' tl2 s2'' \<and> s1'' \<approx> s2'' \<and> tl1 \<sim> tl2)))
                           stls1')"
    by(simp_all add: tl1_to_tl2_def split_beta)

  have [simp]: "llength (tl1_to_tl2 s2 sstls1) = llength sstls1"
    by(coinduction arbitrary: s2 sstls1 rule: enat_coinduct)(auto simp add: epred_llength split_beta)
  define sstls2 where "sstls2 = tl1_to_tl2 s2 sstls1"
  with \<tau>inf1' bisim have "\<exists>s1 sstls1. s1 -\<tau>1-sstls1\<rightarrow>*t \<infinity> \<and> sstls2 = tl1_to_tl2 s2 sstls1 \<and> s1 \<approx> s2" by blast
  from \<tau>inf1' bisim have "s2 -\<tau>2-tl1_to_tl2 s2 sstls1\<rightarrow>*t \<infinity>"
  proof(coinduction arbitrary: s2 s1 sstls1)
    case (\<tau>inf_step_table s2 s1 sstls1)
    note \<tau>inf' = `s1 -\<tau>1-sstls1\<rightarrow>*t \<infinity>` and bisim = `s1 \<approx> s2`
    from \<tau>inf' show ?case
    proof(cases)
      case (\<tau>inf_step_table_Cons s1' s1'' sstls1' tl1)
      hence sstls1: "sstls1 = LCons (s1, s1', tl1, s1'') sstls1'"
        and \<tau>s: "s1 -\<tau>1\<rightarrow>* s1'" and r: "s1' -1-tl1\<rightarrow> s1''" and n\<tau>: "\<not> \<tau>move1 s1' tl1 s1''"
        and reds1: "s1'' -\<tau>1-sstls1'\<rightarrow>*t \<infinity>" by simp_all
      let ?P = "\<lambda>(s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and> \<not> \<tau>move2 s2' tl2 s2'' \<and>  s1'' \<approx> s2'' \<and> tl1 \<sim> tl2"
      let ?s2tl2s2' = "Eps ?P"
      let ?s2'' = "snd (snd ?s2tl2s2')"
      from simulation_silents[OF `s1 \<approx> s2` \<tau>s]
      obtain s2' where "s2 -\<tau>2\<rightarrow>* s2'" "s1' \<approx> s2'" by blast
      from simulation[OF `s1' \<approx> s2'` r n\<tau>] obtain s2'' s2''' tl2
        where "s2' -\<tau>2\<rightarrow>* s2''"
        and rest: "s2'' -2-tl2\<rightarrow> s2'''" "\<not> \<tau>move2 s2'' tl2 s2'''" "s1'' \<approx> s2'''" "tl1 \<sim> tl2" by blast
      from `s2 -\<tau>2\<rightarrow>* s2'` `s2' -\<tau>2\<rightarrow>* s2''` have "s2 -\<tau>2\<rightarrow>* s2''" by(rule rtranclp_trans)
      with rest have "?P (s2'', tl2, s2''')" by simp
      hence "?P ?s2tl2s2'" by(rule someI)
      then show ?thesis using reds1 sstls1 by fastforce
    next
      case \<tau>inf_step_table_Nil
      hence [simp]: "sstls1 = LNil" and "s1 -\<tau>1\<rightarrow> \<infinity>" by simp_all
      from `s1 -\<tau>1\<rightarrow> \<infinity>` `s1 \<approx> s2` have "s2 -\<tau>2\<rightarrow> \<infinity>" by(simp add: \<tau>diverge_sim_inv)
      thus ?thesis by simp
    qed
  qed
  hence "s2 -\<tau>2-lmap (fst \<circ> snd \<circ> snd) (tl1_to_tl2 s2 sstls1)\<rightarrow>* \<infinity>"
    by(rule trsys2.\<tau>inf_step_table_into_\<tau>inf_step)
  moreover have "tls1 [[\<sim>]] lmap (fst \<circ> snd \<circ> snd) (tl1_to_tl2 s2 sstls1)"
  proof(rule llist_all2_all_lnthI)
    show "llength tls1 = llength (lmap (fst \<circ> snd \<circ> snd) (tl1_to_tl2 s2 sstls1))"
      using tls1 by simp
  next
    fix n
    assume "enat n < llength tls1"
    thus "lnth tls1 n \<sim> lnth (lmap (fst \<circ> snd \<circ> snd) (tl1_to_tl2 s2 sstls1)) n"
      using \<tau>inf1' bisim unfolding tls1
    proof(induct n arbitrary: s1 s2 sstls1 rule: less_induct)
      case (less n)
      note IH = `\<And>m s1 s2 sstls1. \<lbrakk> m < n; enat m < llength (lmap (fst \<circ> snd \<circ> snd) sstls1);
                                   s1 -\<tau>1-sstls1\<rightarrow>*t \<infinity>; s1 \<approx> s2 \<rbrakk>
                 \<Longrightarrow> lnth (lmap (fst \<circ> snd \<circ> snd) sstls1) m \<sim> lnth (lmap (fst \<circ> snd \<circ> snd) (tl1_to_tl2 s2 sstls1)) m`
      from `s1 -\<tau>1-sstls1\<rightarrow>*t \<infinity>` show ?case
      proof cases
        case (\<tau>inf_step_table_Cons s1' s1'' sstls1' tl1)
        hence sstls1: "sstls1 = LCons (s1, s1', tl1, s1'') sstls1'"
          and \<tau>s: "s1 -\<tau>1\<rightarrow>* s1'" and r: "s1' -1-tl1\<rightarrow> s1''"
          and n\<tau>: "\<not> \<tau>move1 s1' tl1 s1''" and reds: "s1'' -\<tau>1-sstls1'\<rightarrow>*t \<infinity>" by simp_all
        let ?P = "\<lambda>(s2', tl2, s2''). s2 -\<tau>2\<rightarrow>* s2' \<and> trsys2 s2' tl2 s2'' \<and> \<not> \<tau>move2 s2' tl2 s2'' \<and>  s1'' \<approx> s2'' \<and> tl1 \<sim> tl2"
        let ?s2tl2s2' = "Eps ?P" let ?tl2 = "fst (snd ?s2tl2s2')" let ?s2'' = "snd (snd ?s2tl2s2')"
        from simulation_silents[OF `s1 \<approx> s2` \<tau>s] obtain s2'
          where "s2 -\<tau>2\<rightarrow>* s2'" "s1' \<approx> s2'" by blast
        from simulation[OF `s1' \<approx> s2'` r n\<tau>] obtain s2'' s2''' tl2
          where "s2' -\<tau>2\<rightarrow>* s2''"
          and rest: "s2'' -2-tl2\<rightarrow> s2'''" "\<not> \<tau>move2 s2'' tl2 s2'''" "s1'' \<approx> s2'''" "tl1 \<sim> tl2" by blast
        from `s2 -\<tau>2\<rightarrow>* s2'` `s2' -\<tau>2\<rightarrow>* s2''` have "s2 -\<tau>2\<rightarrow>* s2''" by(rule rtranclp_trans)
        with rest have "?P (s2'', tl2, s2''')" by auto
        hence "?P ?s2tl2s2'" by(rule someI)
        hence "s1'' \<approx> ?s2''" "tl1 \<sim> ?tl2" by(simp_all add: split_beta)
        show ?thesis
        proof(cases n)
          case 0
          with sstls1 `tl1 \<sim> ?tl2` show ?thesis by simp
        next
          case (Suc m)
          hence "m < n" by simp
          moreover have "enat m < llength (lmap (fst \<circ> snd \<circ> snd) sstls1')"
            using sstls1 `enat n < llength (lmap (fst \<circ> snd \<circ> snd) sstls1)` Suc by(simp add: Suc_ile_eq)
          ultimately have "lnth (lmap (fst \<circ> snd \<circ> snd) sstls1') m \<sim> lnth (lmap (fst \<circ> snd \<circ> snd) (tl1_to_tl2 ?s2'' sstls1')) m"
            using reds `s1'' \<approx> ?s2''` by(rule IH)
          with Suc sstls1 show ?thesis by(simp del: o_apply)
        qed
      next
        case \<tau>inf_step_table_Nil
        with `enat n < llength (lmap (fst \<circ> snd \<circ> snd) sstls1)` have False by simp
        thus ?thesis ..
      qed
    qed
  qed
  ultimately show ?thesis by blast
qed

(* is this enough? *)
end

sublocale delay_bisimulation_diverge \<subseteq> delay_simulation_diverge
by (unfold_locales, rule simulation1, auto simp add: simulation1 simulation_silent1 \<tau>diverge_bisim_inv)

definition \<tau>moves_of_tCFG where
"\<tau>moves_of_tCFG CFGs step_rel obs get_mem C l C' \<equiv> step_rel CFGs C C' \<and> get_mem C' |` obs = l
  \<and> get_mem C |` obs = l"

locale tCFG_delay_bisim = delay_bisimulation_diverge where trsys1 = "trsys_of_tCFG CFGs step_rel obs get_mem"
 and trsys2 = "trsys_of_tCFG CFGs' step_rel obs get_mem"
 and \<tau>move1 = "\<tau>moves_of_tCFG CFGs step_rel obs get_mem"
 and \<tau>move2 = "\<tau>moves_of_tCFG CFGs' step_rel obs get_mem" for CFGs CFGs' step_rel obs get_mem

locale tCFG_delay_sim = delay_simulation_diverge where trsys1 = "trsys_of_tCFG CFGs step_rel obs get_mem"
 and trsys2 = "trsys_of_tCFG CFGs' step_rel obs get_mem"
 and \<tau>move1 = "\<tau>moves_of_tCFG CFGs step_rel obs get_mem"
 and \<tau>move2 = "\<tau>moves_of_tCFG CFGs' step_rel obs get_mem" for CFGs CFGs' step_rel obs get_mem

lemma delay_sim_comp: "\<lbrakk>tCFG_delay_sim sim tlsim CFGs CFGs' step_rel obs get_mem;
  tCFG_delay_sim sim' tlsim' CFGs' CFGs'' step_rel obs get_mem\<rbrakk> \<Longrightarrow>
tCFG_delay_sim (sim \<circ>\<^sub>B sim') (tlsim \<circ>\<^sub>B tlsim') CFGs CFGs'' step_rel obs get_mem"
apply (clarsimp simp add: tCFG_delay_sim_def, unfold_locales)
apply (clarsimp simp add: bisim_compose_def)
apply (drule delay_simulation_diverge.simulation_\<tau>rtrancl3p)
apply (rule \<tau>trsys.\<tau>rtrancl3p_step, simp+)
apply (rule \<tau>trsys.\<tau>rtrancl3p_refl, simp+)
apply clarsimp
apply (drule delay_simulation_diverge.simulation_\<tau>rtrancl3p, simp+, clarsimp)
(* overshot? *)
oops

lemma delay_bisim_comp: "\<lbrakk>tCFG_delay_bisim sim tlsim CFGs CFGs' step_rel obs get_mem;
  tCFG_delay_bisim sim' tlsim' CFGs' CFGs'' step_rel obs get_mem\<rbrakk> \<Longrightarrow>
tCFG_delay_bisim (sim \<circ>\<^sub>B sim') (tlsim \<circ>\<^sub>B tlsim') CFGs CFGs'' step_rel obs get_mem"
by (simp add: tCFG_delay_bisim_def delay_bisimulation_diverge_compose)

context TRANS_basics begin

definition (in TRANS_basics) "opt_delay_bisim T sim tlsim step_rel obs get_mem \<equiv>
  \<forall>\<tau> CFGs. tCFG CFGs instr_edges Seq \<longrightarrow> (\<forall>CFGs'\<in>trans_sf T \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and>
  tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem)"

lemma opt_delay_bisimI [intro]: "(\<And>\<tau> CFGs CFGs'. \<lbrakk>tCFG CFGs instr_edges Seq; CFGs' \<in> trans_sf T \<tau> CFGs\<rbrakk> \<Longrightarrow>
  tCFG CFGs' instr_edges Seq \<and> tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem) \<Longrightarrow>
  opt_delay_bisim T sim tlsim step_rel obs get_mem"
by (simp add: opt_delay_bisim_def)

lemma opt_delay_bisimD [dest]: "\<lbrakk>opt_delay_bisim T sim tlsim step_rel obs get_mem;
  tCFG CFGs instr_edges Seq; CFGs' \<in> trans_sf T \<tau> CFGs\<rbrakk> \<Longrightarrow> tCFG CFGs' instr_edges Seq \<and>
  tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem"
by (simp add: opt_delay_bisim_def)

lemma then_delay_bisim [intro]: "\<lbrakk>opt_delay_bisim T1 sim1 tlsim1 step_rel obs get_mem;
  opt_delay_bisim T2 sim2 tlsim2 step_rel obs get_mem\<rbrakk> \<Longrightarrow>
  opt_delay_bisim (TThen T1 T2) (sim2 \<circ>\<^sub>B sim1) (tlsim2 \<circ>\<^sub>B tlsim1) step_rel obs get_mem"
apply (clarsimp intro!: opt_delay_bisimI)
apply (drule opt_delay_bisimD, simp+, clarsimp)+
apply (rule delay_bisim_comp, simp_all)
done
(* These work much better than just unfolding the definition. *)

lemma applysome_delay_bisim: "\<lbrakk>opt_delay_bisim T sim tlsim step_rel obs get_mem;
  tCFG CFGs instr_edges Seq; apply_some (trans_sf T) \<tau> CFGs CFGs'\<rbrakk> \<Longrightarrow>
  tCFG CFGs' instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_delay_bisim sim' tlsim' CFGs' CFGs step_rel obs get_mem)"
apply (drule_tac P="\<lambda>t \<tau> G G'. t = trans_sf T \<and> tCFG G instr_edges Seq \<longrightarrow>
  (tCFG G' instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_delay_bisim sim' tlsim' G' G step_rel obs get_mem))"
  in apply_some.induct, auto)
apply (rule_tac x="(=)" in exI, rule_tac x="(=)" in exI, unfold_locales, force+)
apply (drule opt_delay_bisimD, simp+, clarsimp)
apply (rule exI, rule exI, rule delay_bisim_comp, simp+)
done

definition "trans_delay_bisim T step_rel obs get_mem \<equiv>
  \<forall>\<tau> CFGs. tCFG CFGs instr_edges Seq \<longrightarrow> (\<forall>CFGs' \<in> trans_sf T \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and>
  (\<exists>sim tlsim. tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem))"

lemma trans_delay_bisimI [intro]: "(\<And>\<tau> CFGs CFGs'. \<lbrakk>tCFG CFGs instr_edges Seq; CFGs' \<in> trans_sf T \<tau> CFGs\<rbrakk> \<Longrightarrow>
  tCFG CFGs' instr_edges Seq \<and> (\<exists>sim tlsim. tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem)) \<Longrightarrow>
  trans_delay_bisim T step_rel obs get_mem"
by (simp add: trans_delay_bisim_def)

lemma trans_delay_bisimD [dest]: "\<lbrakk>trans_delay_bisim T step_rel obs get_mem;
  tCFG CFGs instr_edges Seq; CFGs' \<in> trans_sf T \<tau> CFGs\<rbrakk> \<Longrightarrow> tCFG CFGs' instr_edges Seq \<and>
  (\<exists>sim tlsim. tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem)"
by (simp add: trans_delay_bisim_def)

lemma opt_delay_bisim_trans [intro]: "opt_delay_bisim T sim tlsim step_rel obs get_mem \<Longrightarrow>
  trans_delay_bisim T step_rel obs get_mem"
by (force simp add: opt_delay_bisim_def trans_delay_bisim_def)

definition "cond_delay_bisim P T step_rel obs get_mem \<equiv> \<forall>\<tau> CFGs. P \<tau> CFGs \<and> tCFG CFGs instr_edges Seq \<longrightarrow>
  (\<forall>CFGs' \<in> trans_sf T \<tau> CFGs. tCFG CFGs' instr_edges Seq \<and>
  (\<exists>sim tlsim. tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem))"

lemma cond_delay_bisimI [intro]: "(\<And>\<tau> CFGs CFGs'. \<lbrakk>P \<tau> CFGs; tCFG CFGs instr_edges Seq;
  CFGs' \<in> trans_sf T \<tau> CFGs\<rbrakk> \<Longrightarrow> tCFG CFGs' instr_edges Seq \<and>
  (\<exists>sim tlsim. tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem)) \<Longrightarrow>
  cond_delay_bisim P T step_rel obs get_mem"
by (force simp add: cond_delay_bisim_def)

lemma cond_delay_bisimD [dest]: "\<lbrakk>cond_delay_bisim P T step_rel obs get_mem; P \<tau> CFGs;
  tCFG CFGs instr_edges Seq; CFGs' \<in> trans_sf T \<tau> CFGs\<rbrakk> \<Longrightarrow> tCFG CFGs' instr_edges Seq \<and>
  (\<exists>sim tlsim. tCFG_delay_bisim sim tlsim CFGs' CFGs step_rel obs get_mem)"
by (force simp add: cond_delay_bisim_def)

lemma applyall_delay_bisim [intro]: "opt_delay_bisim T sim tlsim step_rel obs get_mem \<Longrightarrow>
  trans_delay_bisim (TApplyAll T) step_rel obs get_mem"
apply (clarsimp simp add: trans_delay_bisim_def)
by (metis applysome_delay_bisim)

lemma match_cond_delay_bisim [intro]: "cond_delay_bisim (\<lambda>\<tau> CFGs. \<exists>\<sigma> \<tau>'. side_cond_sf \<phi> \<sigma> CFGs \<and>
  part_matches \<sigma> \<tau>' \<and> \<tau> = part_extend \<tau>' (cond_fv pred_fv \<phi>) \<sigma>) T step_rel obs get_mem \<Longrightarrow>
  trans_delay_bisim (TMatch \<phi> T) step_rel obs get_mem"
apply (clarsimp simp add: trans_delay_bisim_def cond_delay_bisim_def)
by metis

lemma then_cond_delay_bisim [intro]: "\<lbrakk>cond_delay_bisim P T1 step_rel obs get_mem;
  cond_delay_bisim P T2 step_rel obs get_mem;
  \<forall>\<tau> CFGs CFGs'. P \<tau> CFGs \<and> CFGs' \<in> trans_sf T1 \<tau> CFGs \<longrightarrow> P \<tau> CFGs'\<rbrakk> \<Longrightarrow>
  cond_delay_bisim P (TThen T1 T2) step_rel obs get_mem"
apply (clarsimp intro!: cond_delay_bisimI)
apply (drule cond_delay_bisimD, simp+, clarsimp)
apply (erule_tac x=\<tau> in allE, erule_tac x=CFGs in allE, erule_tac x=CFGs'a in allE, simp)
apply (drule cond_delay_bisimD, simp+, clarsimp)
apply (rule exI, rule exI, rule delay_bisim_comp, simp+)
done

lemma applysome_cond_delay_bisim: "\<lbrakk>apply_some (trans_sf T) \<tau> CFGs CFGs';
  tCFG CFGs instr_edges Seq; cond_delay_bisim P T step_rel obs get_mem;
  \<forall>\<tau> CFGs CFGs'. P \<tau> CFGs \<and> CFGs' \<in> trans_sf T \<tau> CFGs \<longrightarrow> P \<tau> CFGs'; P \<tau> CFGs\<rbrakk> \<Longrightarrow>
  tCFG CFGs' instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_delay_bisim sim' tlsim' CFGs' CFGs step_rel obs get_mem)"
apply (drule_tac P="\<lambda>t \<tau> G G'. t = trans_sf T \<and> P \<tau> G \<and> tCFG G instr_edges Seq \<longrightarrow>
  (tCFG G' instr_edges Seq \<and> (\<exists>sim' tlsim'. tCFG_delay_bisim sim' tlsim' G' G step_rel obs get_mem))"
  in apply_some.induct, simp_all)
apply clarsimp
apply (rule_tac x="(=)" in exI, rule_tac x="(=)" in exI, unfold_locales, force, force, force, force,
  force)
apply clarsimp
apply (erule_tac x=\<tau>' in allE, erule_tac x=G in allE, erule_tac x=G' in allE, simp)
apply (drule_tac CFGs=G in cond_delay_bisimD, simp+, clarsimp)
apply (rule exI, rule exI, rule delay_bisim_comp, simp+)
done

lemma applyall_cond_delay_bisim [intro]: "\<lbrakk>cond_delay_bisim P T step_rel obs get_mem;
  \<forall>\<tau> CFGs CFGs'. P \<tau> CFGs \<and> CFGs' \<in> trans_sf T \<tau> CFGs \<longrightarrow> P \<tau> CFGs'\<rbrakk> \<Longrightarrow>
  cond_delay_bisim P (TApplyAll T) step_rel obs get_mem"
apply (clarsimp intro!: cond_delay_bisimI)
apply (drule applysome_cond_delay_bisim, force simp add: cond_delay_bisim_def)
apply simp+
done

end

end


theory Impl_List_Set_Ndj
imports
  "$AFP/Collections/Refine_Dflt_ICF"
  "$AFP/Refine_Imperative_HOL/IICF/IICF"
  "$AFP/Refine_Imperative_HOL/Sepref_ICF_Bindings"
begin

  definition [simp]: "ndls_rel \<equiv> br set (\<lambda>_. True)"
  definition "nd_list_set_assn A \<equiv> pure (ndls_rel O \<langle>the_pure A\<rangle>set_rel)"

  context
    notes [fcomp_norm_unfold] = nd_list_set_assn_def[symmetric]
    notes [fcomp_norm_unfold] = list_set_assn_def[symmetric]
  begin

    lemma ndls_empty_hnr_aux: "([],op_set_empty) \<in> ndls_rel" by (auto simp: in_br_conv)
    sepref_decl_impl (no_register) ndls_empty: ndls_empty_hnr_aux[sepref_param] .

    lemma ndls_is_empty_hnr_aux: "(op= [], op_set_is_empty) \<in> ndls_rel \<rightarrow> bool_rel"
      by (auto simp: in_br_conv)
    sepref_decl_impl ndls_is_empty: ndls_is_empty_hnr_aux[sepref_param] .

    lemma ndls_insert_hnr_aux: "(op #, op_set_insert) \<in> Id \<rightarrow> ndls_rel \<rightarrow> ndls_rel"
      by (auto simp: in_br_conv)

    sepref_decl_impl ndls_insert: ndls_insert_hnr_aux[sepref_param] .

    sepref_decl_op ndls_ls_copy: "\<lambda>x::'a set. x" :: "\<langle>A\<rangle>set_rel \<rightarrow> \<langle>A\<rangle>set_rel" .
    lemma op_ndls_ls_copy_hnr_aux:
      "(remdups, op_ndls_ls_copy)\<in>ndls_rel \<rightarrow> \<langle>Id\<rangle>list_set_rel"
      by (auto simp: in_br_conv list_set_rel_def)

    sepref_decl_impl op_ndls_ls_copy_hnr_aux[sepref_param] .
  end

  definition [simp]: "op_ndls_empty = op_set_empty"
  interpretation ndls: set_custom_empty "return []" op_ndls_empty
    by unfold_locales simp
  sepref_register op_ndls_empty
  lemmas [sepref_fr_rules] = ndls_empty_hnr[folded op_ndls_empty_def]

  lemma fold_ndls_ls_copy: "x = op_ndls_ls_copy x" by simp

end


chapter\<open>EFSM Inference\<close>
text\<open>This chapter presents the definitions necessary for EFSM inference by state-merging.\<close>

section\<open>Inference by State-Merging\<close>
text\<open>This theory sets out the key definitions for the inference of EFSMs from system traces.\<close>

theory Inference
  imports
    Subsumption
    "Extended_Finite_State_Machines.Transition_Lexorder"
    "HOL-Library.Product_Lexorder"
begin

declare One_nat_def [simp del]

subsection\<open>Transition Identifiers\<close>

text\<open>We first need to define the \texttt{iEFSM} data type which assigns each transition a unique identity.
This is necessary because transitions may not occur uniquely in an EFSM. Assigning transitions a unique
identifier enables us to look up the origin and destination states of transitions without having to
pass them around in the inference functions.\<close>

type_synonym tid = nat
type_synonym tids = "tid list"
type_synonym iEFSM = "(tids \<times> (cfstate \<times> cfstate) \<times> transition) fset"

definition origin :: "tids \<Rightarrow> iEFSM \<Rightarrow> nat" where
  "origin uid t = fst (fst (snd (fthe_elem (ffilter (\<lambda>x. set uid \<subseteq> set (fst x)) t))))"

definition dest :: "tids \<Rightarrow> iEFSM \<Rightarrow> nat" where
  "dest uid t = snd (fst (snd (fthe_elem (ffilter (\<lambda>x. set uid \<subseteq> set (fst x)) t))))"

definition get_by_id :: "iEFSM \<Rightarrow> tid \<Rightarrow> transition" where
  "get_by_id e uid = (snd \<circ> snd) (fthe_elem (ffilter (\<lambda>(tids, _). uid \<in> set tids) e))"

definition get_by_ids :: "iEFSM \<Rightarrow> tids \<Rightarrow> transition" where
  "get_by_ids e uid = (snd \<circ> snd) (fthe_elem (ffilter (\<lambda>(tids, _). set uid \<subseteq> set tids) e))"

definition uids :: "iEFSM \<Rightarrow> nat fset" where
  "uids e = ffUnion (fimage (fset_of_list \<circ> fst) e)"

definition max_uid :: "iEFSM \<Rightarrow> nat option" where
  "max_uid e = (let uids = uids e in if uids = {||} then None else Some (fMax uids))"

definition tm :: "iEFSM \<Rightarrow> transition_matrix" where
  "tm e = fimage snd e"

definition all_regs :: "iEFSM \<Rightarrow> nat set" where
  "all_regs e = EFSM.all_regs (tm e)"

definition max_reg :: "iEFSM \<Rightarrow> nat option" where
  "max_reg e = EFSM.max_reg (tm e)"

definition "max_reg_total e = (case max_reg e of None \<Rightarrow> 0 | Some r \<Rightarrow> r)"

definition max_output :: "iEFSM \<Rightarrow> nat" where
  "max_output e = EFSM.max_output (tm e)"

definition max_int :: "iEFSM \<Rightarrow> int" where
  "max_int e = EFSM.max_int (tm e)"

definition S :: "iEFSM \<Rightarrow> nat fset" where
  "S m = (fimage (\<lambda>(uid, (s, s'), t). s) m) |\<union>| fimage (\<lambda>(uid, (s, s'), t). s') m"

lemma S_alt: "S t = EFSM.S (tm t)"
  apply (simp add: S_def EFSM.S_def tm_def)
  by force

lemma to_in_S:
  "(\<exists>to from uid. (uid, (from, to), t) |\<in>| xb \<longrightarrow> to |\<in>| S xb)"
  apply (simp add: S_def)
  by blast

lemma from_in_S:
  "(\<exists>to from uid. (uid, (from, to), t) |\<in>| xb \<longrightarrow> from |\<in>| S xb)"
  apply (simp add: S_def)
  by blast

subsection\<open>Building the PTA\<close>
text\<open>The first step in EFSM inference is to construct a PTA from the observed traces in the same way
as for classical FSM inference. Beginning with the empty EFSM, we iteratively attempt to walk each
observed trace in the model. When we reach a point where there is no available transition, one is
added. For classical FSMs, this is simply an atomic label. EFSMs deal with data, so we need to add
guards which test for the observed input values and outputs which produce the observed values.\<close>

primrec make_guard :: "value list \<Rightarrow> nat \<Rightarrow> vname gexp list" where
"make_guard [] _ = []" |
"make_guard (h#t) n = (gexp.Eq (V (vname.I n)) (L h))#(make_guard t (n+1))"

primrec make_outputs :: "value list \<Rightarrow> output_function list" where
  "make_outputs [] = []" |
  "make_outputs (h#t) = (L h)#(make_outputs t)"

definition max_uid_total :: "iEFSM \<Rightarrow> nat" where
  "max_uid_total e = (case max_uid e of None \<Rightarrow> 0 | Some u \<Rightarrow> u)"

definition add_transition :: "iEFSM \<Rightarrow> cfstate \<Rightarrow> label \<Rightarrow> value list \<Rightarrow> value list \<Rightarrow> iEFSM" where
  "add_transition e s label inputs outputs = finsert ([max_uid_total e + 1], (s, (maxS (tm e))+1), \<lparr>Label=label, Arity=length inputs, Guards=(make_guard inputs 0), Outputs=(make_outputs outputs), Updates=[]\<rparr>) e"

fun make_branch :: "iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> iEFSM" where
  "make_branch e _ _ [] = e" |
  "make_branch e s r ((label, inputs, outputs)#t) =
    (case (step (tm e) s r label inputs) of
      Some (transition, s', outputs', updated) \<Rightarrow>
        if outputs' = (map Some outputs) then
          make_branch e s' updated t
        else
          make_branch (add_transition e s label inputs outputs) ((maxS (tm e))+1) r t  |
      None \<Rightarrow>
          make_branch (add_transition e s label inputs outputs) ((maxS (tm e))+1) r t
    )"

primrec make_pta_aux :: "log \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "make_pta_aux [] e = e" |
  "make_pta_aux (h#t) e = make_pta_aux t (make_branch e 0 <> h)"

definition "make_pta log = make_pta_aux log {||}"

lemma make_pta_aux_fold [code]:
  "make_pta_aux l e = fold (\<lambda>h e. make_branch e 0 <> h) l e"
  by(induct l arbitrary: e, auto)

subsection\<open>Integrating Heuristics\<close>
text\<open>A key contribution of the inference technique presented in \<^cite>\<open>"foster2019"\<close> is the ability to
introduce \emph{internal variables} to the model to generalise behaviours and allow transitions to
be merged. This is done by providing the inference technique with a set of \emph{heuristics}. The
aim here is not to create a ``one size fits all'' magic oracle, rather to recognise particular
\emph{data usage patterns} which can be abstracted.\<close>

type_synonym update_modifier = "tids \<Rightarrow> tids \<Rightarrow> cfstate \<Rightarrow> iEFSM \<Rightarrow> iEFSM \<Rightarrow> iEFSM \<Rightarrow> (transition_matrix \<Rightarrow> bool) \<Rightarrow> iEFSM option"

definition null_modifier :: update_modifier where
  "null_modifier f _ _ _ _ _ _ = None"

definition replace_transition :: "iEFSM \<Rightarrow> tids \<Rightarrow> transition \<Rightarrow> iEFSM" where
  "replace_transition e uid new = (fimage (\<lambda>(uids, (from, to), t). if set uid \<subseteq> set uids then (uids, (from, to), new) else (uids, (from, to), t)) e)"

definition replace_all :: "iEFSM \<Rightarrow> tids list \<Rightarrow> transition \<Rightarrow> iEFSM" where
  "replace_all e ids new = fold (\<lambda>id acc. replace_transition acc id new) ids e"

definition replace_transitions :: "iEFSM \<Rightarrow> (tids \<times> transition) list \<Rightarrow> iEFSM" where
  "replace_transitions e ts = fold (\<lambda>(uid, new) acc. replace_transition acc uid new) ts e"

primrec try_heuristics_check :: "(transition_matrix \<Rightarrow> bool) \<Rightarrow> update_modifier list \<Rightarrow> update_modifier" where
  "try_heuristics_check _ [] = null_modifier" |
  "try_heuristics_check check (h#t) = (\<lambda>a b c d e f ch.
    case h a b c d e f ch of
      Some e' \<Rightarrow> Some e' |
      None \<Rightarrow> (try_heuristics_check check t) a b c d e f ch
    )"

subsection\<open>Scoring State Merges\<close>
text\<open>To tackle the state merging challenge, we need some means of determining which states are
compatible for merging. Because states are merged pairwise, we additionally require a way of
ordering the state merges. The potential merges are then sorted highest to lowest according to this
score such that we can merge states in order of their merge score.

We want to sort first by score (highest to lowest) and then by state pairs (lowest to highest) so we
endup merging the states with the highest scores first and then break ties by those state pairs
which are closest to the origin.\<close>

record score =
  Score :: nat
  S1 :: cfstate
  S2 :: cfstate

instantiation score_ext :: (linorder) linorder begin
definition less_score_ext :: "'a::linorder score_ext \<Rightarrow> 'a score_ext \<Rightarrow> bool" where
"less_score_ext t1 t2 = ((Score t2, S1 t1, S2 t1, more t1) < (Score t1, S1 t2, S2 t2, more t2) )"

definition less_eq_score_ext :: "'a::linorder score_ext \<Rightarrow> 'a::linorder score_ext \<Rightarrow> bool" where
 "less_eq_score_ext s1 s2 = (s1 < s2 \<or> s1 = s2)"

instance
  apply standard prefer 5
  unfolding less_score_ext_def less_eq_score_ext_def
  using score.equality apply fastforce
  by auto
end

type_synonym scoreboard = "score fset"
type_synonym strategy = "tids \<Rightarrow> tids \<Rightarrow> iEFSM \<Rightarrow> nat"

definition outgoing_transitions :: "cfstate \<Rightarrow> iEFSM \<Rightarrow> (cfstate \<times> transition \<times> tids) fset" where
  "outgoing_transitions s e = fimage (\<lambda>(uid, (from, to), t'). (to, t', uid)) ((ffilter (\<lambda>(uid, (origin, dest), t). origin = s)) e)"

primrec paths_of_length :: "nat \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> tids list fset" where
  "paths_of_length 0 _ _ = {|[]|}" |
  "paths_of_length (Suc m) e s = (
    let
      outgoing = outgoing_transitions s e;
      paths = ffUnion (fimage (\<lambda>(d, t, id). fimage (\<lambda>p. id#p) (paths_of_length m e d)) outgoing)
    in
      ffilter (\<lambda>l. length l = Suc m) paths
  )"

lemma paths_of_length_1: "paths_of_length 1 e s = fimage (\<lambda>(d, t, id). [id]) (outgoing_transitions s e)"
  apply (simp add: One_nat_def)
  apply (simp add: outgoing_transitions_def comp_def One_nat_def[symmetric])
  apply (rule fBall_ffilter2)
   defer
   apply (simp add: ffilter_def ffUnion_def fBall_def Abs_fset_inverse)
   apply auto[1]
  apply (simp add: ffilter_def ffUnion_def fBall_def Abs_fset_inverse fset_both_sides)
  by force

fun step_score :: "(tids \<times> tids) list \<Rightarrow> iEFSM \<Rightarrow> strategy \<Rightarrow> nat" where
  "step_score [] _ _ = 0" |
  "step_score ((id1, id2)#t) e s = (
    let score = s id1 id2 e in
    if score = 0 then
      0
    else
      score + (step_score t e s)
  )"

lemma step_score_foldr [code]:
  "step_score xs e s = foldr (\<lambda>(id1, id2) acc. let score = s id1 id2 e in
    if score = 0 then
      0
    else
      score + acc) xs 0"
proof(induct xs)
case Nil
  then show ?case
    by simp
next
  case (Cons a xs)
  then show ?case
    apply (cases a, clarify)
    by (simp add: Let_def)
qed

definition score_from_list :: "tids list fset \<Rightarrow> tids list fset \<Rightarrow> iEFSM \<Rightarrow> strategy \<Rightarrow> nat" where
  "score_from_list P1 P2 e s = (
    let
      pairs = fimage (\<lambda>(l1, l2). zip l1 l2) (P1 |\<times>| P2);
      scored_pairs = fimage (\<lambda>l. step_score l e s) pairs
    in
    fSum scored_pairs
  )"

definition k_score :: "nat \<Rightarrow> iEFSM \<Rightarrow> strategy \<Rightarrow> scoreboard" where
  "k_score k e strat = (
    let
      states = S e;
      pairs_to_score = (ffilter (\<lambda>(x, y). x < y) (states |\<times>| states));
      paths = fimage (\<lambda>(s1, s2). (s1, s2, paths_of_length k e s1, paths_of_length k e s2)) pairs_to_score;
      scores = fimage (\<lambda>(s1, s2, p1, p2). \<lparr>Score = score_from_list p1 p2 e strat, S1 = s1, S2 = s2\<rparr>) paths
    in
    ffilter (\<lambda>x. Score x > 0) scores
)"

definition score_state_pair :: "strategy \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> cfstate \<Rightarrow> nat" where
  "score_state_pair strat e s1 s2 = (
    let
      T1 = outgoing_transitions s1 e;
      T2 = outgoing_transitions s2 e
    in
      fSum (fimage (\<lambda>((_, _, t1), (_, _, t2)). strat t1 t2 e) (T1 |\<times>| T2))
  )"

definition score_1 :: "iEFSM \<Rightarrow> strategy \<Rightarrow> scoreboard" where
  "score_1 e strat = (
    let
      states = S e;
      pairs_to_score = (ffilter (\<lambda>(x, y). x < y) (states |\<times>| states));
      scores = fimage (\<lambda>(s1, s2). \<lparr>Score = score_state_pair strat e s1 s2, S1 = s1, S2 = s2\<rparr>) pairs_to_score
    in
      ffilter (\<lambda>x. Score x > 0) scores
  )"

lemma score_1: "score_1 e s = k_score 1 e s"
proof-
  have fprod_fimage:
    "\<And>a b. ((\<lambda>(_, _, id). [id]) |`| a |\<times>| (\<lambda>(_, _, id). [id]) |`| b) =
       fimage (\<lambda>((_, _, id1), (_, _, id2)). ([id1], [id2])) (a |\<times>| b)"
    apply (simp add: fimage_def fprod_def Abs_fset_inverse fset_both_sides)
    by force
  show ?thesis
    apply (simp add: score_1_def k_score_def Let_def comp_def)
    apply (rule arg_cong[of _ _ "ffilter (\<lambda>x. 0 < Score x)"])
    apply (rule fun_cong[of _ _ "(Inference.S e |\<times>| Inference.S e)"])
    apply (rule ext)
    subgoal for x
      apply (rule fun_cong[of _ _ "ffilter (\<lambda>a. case a of (a, b) \<Rightarrow> a < b) x"])
      apply (rule arg_cong[of _ _ fimage])
      apply (rule ext)
      subgoal for x
        apply (case_tac x)
        apply simp
        apply (simp add: paths_of_length_1)
        apply (simp add: score_state_pair_def Let_def score_from_list_def comp_def)
        subgoal for a b
          apply (rule arg_cong[of _ _ fSum])
          apply (simp add: fprod_fimage)
          apply (rule fun_cong[of _ _ "(outgoing_transitions a e |\<times>| outgoing_transitions b e)"])
          apply (rule arg_cong[of _ _ fimage])
          apply (rule ext)
          apply clarify
          by (simp add: Let_def)
        done
      done
    done
qed

fun bool2nat :: "bool \<Rightarrow> nat" where
  "bool2nat True = 1" |
  "bool2nat False = 0"

definition score_transitions :: "transition \<Rightarrow> transition \<Rightarrow> nat" where
  "score_transitions t1 t2 = (
    if Label t1 = Label t2 \<and> Arity t1 = Arity t2 \<and> length (Outputs t1) = length (Outputs t2) then
      1 + bool2nat (t1 = t2) + card ((set (Guards t2)) \<inter> (set (Guards t2))) + card ((set (Updates t2)) \<inter> (set (Updates t2))) + card ((set (Outputs t2)) \<inter> (set (Outputs t2)))
    else
      0
  )"

subsection\<open>Merging States\<close>
definition merge_states_aux :: "nat \<Rightarrow> nat \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "merge_states_aux s1 s2 e = fimage (\<lambda>(uid, (origin, dest), t). (uid, (if origin = s1 then s2 else origin , if dest = s1 then s2 else dest), t)) e"

definition merge_states :: "nat \<Rightarrow> nat \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "merge_states x y t = (if x > y then merge_states_aux x y t else merge_states_aux y x t)"

lemma merge_states_symmetry: "merge_states x y t = merge_states y x t"
  by (simp add: merge_states_def)

lemma merge_state_self: "merge_states s s t = t"
  apply (simp add: merge_states_def merge_states_aux_def)
  by force

lemma merge_states_self_simp [code]:
  "merge_states x y t = (if x = y then t else if x > y then merge_states_aux x y t else merge_states_aux y x t)"
  apply (simp add: merge_states_def merge_states_aux_def)
  by force

subsection\<open>Resolving Nondeterminism\<close>
text\<open>Because EFSM transitions are not simply atomic actions, duplicated behaviours cannot be
resolved into a single transition by simply merging destination states, as it can in classical FSM
inference. It is now possible for attempts to resolve the nondeterminism introduced by merging
states to fail, meaning that two states which initially seemed compatible cannot actually be merged.
This is not the case in classical FSM inference.\<close>

type_synonym nondeterministic_pair = "(cfstate \<times> (cfstate \<times> cfstate) \<times> ((transition \<times> tids) \<times> (transition \<times> tids)))"

definition state_nondeterminism :: "nat \<Rightarrow> (cfstate \<times> transition \<times> tids) fset \<Rightarrow> nondeterministic_pair fset" where
  "state_nondeterminism og nt = (if size nt < 2 then {||} else ffUnion (fimage (\<lambda>x. let (dest, t) = x in fimage (\<lambda>y. let (dest', t') = y in (og, (dest, dest'), (t, t'))) (nt - {|x|})) nt))"

lemma state_nondeterminism_empty [simp]: "state_nondeterminism a {||} = {||}"
  by (simp add: state_nondeterminism_def ffilter_def Set.filter_def)

lemma state_nondeterminism_singledestn [simp]: "state_nondeterminism a {|x|} = {||}"
  by (simp add: state_nondeterminism_def ffilter_def Set.filter_def)

(* For each state, get its outgoing transitions and see if there's any nondeterminism there *)
definition nondeterministic_pairs :: "iEFSM \<Rightarrow> nondeterministic_pair fset" where
  "nondeterministic_pairs t = ffilter (\<lambda>(_, _, (t, _), (t', _)). Label t = Label t' \<and> Arity t = Arity t' \<and> choice t t') (ffUnion (fimage (\<lambda>s. state_nondeterminism s (outgoing_transitions s t)) (S t)))"

definition nondeterministic_pairs_labar_dest :: "iEFSM \<Rightarrow> nondeterministic_pair fset" where
  "nondeterministic_pairs_labar_dest t = ffilter
     (\<lambda>(_, (d, d'), (t, _), (t', _)).
      Label t = Label t' \<and> Arity t = Arity t' \<and> (choice t t' \<or> (Outputs t = Outputs t' \<and> d = d')))
     (ffUnion (fimage (\<lambda>s. state_nondeterminism s (outgoing_transitions s t)) (S t)))"

definition nondeterministic_pairs_labar :: "iEFSM \<Rightarrow> nondeterministic_pair fset" where
  "nondeterministic_pairs_labar t = ffilter
     (\<lambda>(_, (d, d'), (t, _), (t', _)).
      Label t = Label t' \<and> Arity t = Arity t' \<and> (choice t t' \<or> Outputs t = Outputs t'))
     (ffUnion (fimage (\<lambda>s. state_nondeterminism s (outgoing_transitions s t)) (S t)))"

definition deterministic :: "iEFSM \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> bool" where
  "deterministic t np = (np t = {||})"

definition nondeterministic :: "iEFSM \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> bool" where
  "nondeterministic t np = (\<not> deterministic t np)"

definition insert_transition :: "tids \<Rightarrow> cfstate \<Rightarrow> cfstate \<Rightarrow> transition \<Rightarrow> iEFSM \<Rightarrow> iEFSM" where
  "insert_transition uid from to t e = (
    if \<nexists>(uid, (from', to'), t') |\<in>| e. from = from' \<and> to = to' \<and> t = t' then
      finsert (uid, (from, to), t) e
    else
      fimage (\<lambda>(uid', (from', to'), t').
        if from = from' \<and> to = to' \<and> t = t' then
          (List.union uid' uid, (from', to'), t')
        else
          (uid', (from', to'), t')
      ) e
  )"

definition make_distinct :: "iEFSM \<Rightarrow> iEFSM" where
  "make_distinct e = ffold_ord (\<lambda>(uid, (from, to), t) acc. insert_transition uid from to t acc) e {||}"

\<comment> \<open>When we replace one transition with another, we need to merge their uids to keep track of which\<close>
\<comment> \<open>transition accounts for which action in the original traces                                     \<close>
definition merge_transitions_aux :: "iEFSM \<Rightarrow> tids \<Rightarrow> tids \<Rightarrow> iEFSM" where
  "merge_transitions_aux e oldID newID = (let
    (uids1, (origin, dest), old) = fthe_elem (ffilter (\<lambda>(uids, _). oldID = uids) e);
    (uids2, (origin, dest), new) = fthe_elem (ffilter (\<lambda>(uids, _). newID = uids) e) in
    make_distinct (finsert (List.union uids1 uids2, (origin, dest), new) (e - {|(uids1, (origin, dest), old), (uids2, (origin, dest), new)|}))
  )"

(* merge_transitions - Try dest merge transitions t1 and t2 dest help resolve nondeterminism in
                       newEFSM. If either subsumes the other directly then the subsumed transition
                       can simply be replaced with the subsuming one, else we try dest apply the
                       modifier function dest resolve nondeterminism that way.                    *)
(* @param oldEFSM   - the EFSM before merging the states which caused the nondeterminism          *)
(* @param preDestMerge   - the EFSM after merging the states which caused the nondeterminism      *)
(* @param newEFSM   - the current EFSM with nondeterminism                                        *)
(* @param t1        - a transition dest be merged with t2                                         *)
(* @param u1        - the unique identifier of t1                                                 *)
(* @param t2        - a transition dest be merged with t1                                         *)
(* @param u2        - the unique identifier of t2                                                 *)
(* @param modifier  - an update modifier function which tries dest generalise transitions         *)
definition merge_transitions :: "(cfstate \<times> cfstate) set \<Rightarrow> iEFSM \<Rightarrow> iEFSM \<Rightarrow> iEFSM \<Rightarrow> transition \<Rightarrow> tids \<Rightarrow> transition \<Rightarrow> tids \<Rightarrow> update_modifier \<Rightarrow> (transition_matrix \<Rightarrow> bool) \<Rightarrow> iEFSM option" where
  "merge_transitions failedMerges oldEFSM preDestMerge destMerge t1 u1 t2 u2 modifier check = (
     if \<forall>id \<in> set u1. directly_subsumes (tm oldEFSM) (tm destMerge) (origin [id] oldEFSM) (origin u1 destMerge) t2 t1 then
       \<comment> \<open>Replace t1 with t2\<close>
       Some (merge_transitions_aux destMerge u1 u2)
     else if \<forall>id \<in> set u2. directly_subsumes (tm oldEFSM) (tm destMerge) (origin [id] oldEFSM) (origin u2 destMerge) t1 t2 then
       \<comment> \<open>Replace t2 with t1\<close>
       Some (merge_transitions_aux destMerge u2 u1)
     else
        case modifier u1 u2 (origin u1 destMerge) destMerge preDestMerge oldEFSM check of
          None \<Rightarrow> None |
          Some e \<Rightarrow> Some (make_distinct e)
   )"

definition outgoing_transitions_from :: "iEFSM \<Rightarrow> cfstate \<Rightarrow> transition fset" where
  "outgoing_transitions_from e s = fimage (\<lambda>(_, _, t). t) (ffilter (\<lambda>(_, (orig, _), _). orig = s) e)"

definition order_nondeterministic_pairs :: "nondeterministic_pair fset \<Rightarrow> nondeterministic_pair list" where
  "order_nondeterministic_pairs s = map snd (sorted_list_of_fset (fimage (\<lambda>s. let (_, _, (t1, _), (t2, _)) = s in (score_transitions t1 t2, s)) s))"

(* resolve_nondeterminism - tries dest resolve nondeterminism in a given iEFSM                      *)
(* @param ((from, (dest1, dest2), ((t1, u1), (t2, u2)))#ss) - a list of nondeterministic pairs where
          from - nat - the state from which t1 and t2 eminate
          dest1  - nat - the destination state of t1
          dest2  - nat - the destination state of t2
          t1   - transition - a transition dest be merged with t2
          t2   - transition - a transition dest be merged with t1
          u1   - nat - the unique identifier of t1
          u2   - nat - the unique identifier of t2
          ss   - list - the rest of the list                                                      *)
(* @param oldEFSM - the EFSM before merging the states which caused the nondeterminism            *)
(* @param newEFSM - the current EFSM with nondeterminism                                          *)
(* @param m       - an update modifier function which tries dest generalise transitions             *)
(* @param check - a function which takes an EFSM and returns a bool dest ensure that certain
                  properties hold in the new iEFSM                                                *)
function resolve_nondeterminism :: "(cfstate \<times> cfstate) set \<Rightarrow> nondeterministic_pair list \<Rightarrow> iEFSM \<Rightarrow> iEFSM \<Rightarrow> update_modifier \<Rightarrow> (transition_matrix \<Rightarrow> bool) \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> (iEFSM option \<times> (cfstate \<times> cfstate) set)" where
  "resolve_nondeterminism failedMerges [] _ newEFSM _ check np = (
      if deterministic newEFSM np \<and> check (tm newEFSM) then Some newEFSM else None, failedMerges
  )" |
  "resolve_nondeterminism failedMerges ((from, (dest1, dest2), ((t1, u1), (t2, u2)))#ss) oldEFSM newEFSM m check np = (
    if (dest1, dest2) \<in> failedMerges \<or> (dest2, dest1) \<in> failedMerges then
      (None, failedMerges)
    else
    let destMerge = merge_states dest1 dest2 newEFSM in
    case merge_transitions failedMerges oldEFSM newEFSM destMerge t1 u1 t2 u2 m check of
      None \<Rightarrow> resolve_nondeterminism (insert (dest1, dest2) failedMerges) ss oldEFSM newEFSM m check np |
      Some new \<Rightarrow> (
        let newScores = order_nondeterministic_pairs (np new) in
        if (size new, size (S new), size (newScores)) < (size newEFSM, size (S newEFSM), size ss) then
          case resolve_nondeterminism failedMerges newScores oldEFSM new m check np of
            (Some new', failedMerges) \<Rightarrow> (Some new', failedMerges) |
            (None, failedMerges) \<Rightarrow> resolve_nondeterminism (insert (dest1, dest2) failedMerges) ss oldEFSM newEFSM m check np
        else
          (None, failedMerges)
      )
  )"
     apply (clarify, metis neq_Nil_conv prod_cases3 surj_pair)
  by auto
termination
  by (relation "measures [\<lambda>(_, _, _, newEFSM, _). size newEFSM,
                          \<lambda>(_, _, _, newEFSM, _). size (S newEFSM),
                          \<lambda>(_, ss, _, _, _). size ss]", auto)

subsection\<open>EFSM Inference\<close>

(* Merge - tries dest merge two states in a given iEFSM and resolve the resulting nondeterminism  *)
(* @param e     - an iEFSM                                                                        *)
(* @param s1    - a state dest be merged with s2                                                  *)
(* @param s2    - a state dest be merged with s1                                                  *)
(* @param m     - an update modifier function which tries dest generalise transitions             *)
(* @param check - a function which takes an EFSM and returns a bool dest ensure that certain
                  properties hold in the new iEFSM                                                *)
definition merge :: "(cfstate \<times> cfstate) set \<Rightarrow> iEFSM \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> update_modifier \<Rightarrow> (transition_matrix \<Rightarrow> bool) \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> (iEFSM option \<times> (cfstate \<times> cfstate) set)" where
  "merge failedMerges e s1 s2 m check np = (
    if s1 = s2 \<or> (s1, s2) \<in> failedMerges \<or> (s2, s1) \<in> failedMerges then
      (None, failedMerges)
    else
      let e' = make_distinct (merge_states s1 s2 e) in
      resolve_nondeterminism failedMerges (order_nondeterministic_pairs (np e')) e e' m check np
  )"

(* inference_step - attempt dest carry out a single step of the inference process by merging the  *)
(* @param e - an iEFSM dest be generalised                                                        *)
(* @param ((s, s1, s2)#t) - a list of triples of the form (score, state, state) dest be merged    *)
(* @param m     - an update modifier function which tries dest generalise transitions             *)
(* @param check - a function which takes an EFSM and returns a bool dest ensure that certain
                  properties hold in the new iEFSM                                                *)
function inference_step :: "(cfstate \<times> cfstate) set \<Rightarrow> iEFSM \<Rightarrow> score fset \<Rightarrow> update_modifier \<Rightarrow> (transition_matrix \<Rightarrow> bool) \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> (iEFSM option \<times> (cfstate \<times> cfstate) set)" where
  "inference_step failedMerges e s m check np = (
     if s = {||} then (None, failedMerges) else
     let
      h = fMin s;
      t = s - {|h|}
    in
    case merge failedMerges e (S1 h) (S2 h) m check np of
      (Some new, failedMerges) \<Rightarrow> (Some new, failedMerges) |
      (None, failedMerges) \<Rightarrow> inference_step (insert ((S1 h), (S2 h)) failedMerges) e t m check np
  )"
  by auto
termination
  apply (relation "measures [\<lambda>(_, _, s, _, _, _). size s]")
   apply simp
  by (simp add: card_minus_fMin)

(* Takes an iEFSM and iterates inference_step until no further states can be successfully merged  *)
(* @param e - an iEFSM dest be generalised                                                        *)
(* @param r - a strategy dest identify and prioritise pairs of states dest merge                  *)
(* @param m     - an update modifier function which tries dest generalise transitions             *)
(* @param check - a function which takes an EFSM and returns a bool dest ensure that certain
                  properties hold in the new iEFSM                                                *)
function infer :: "(cfstate \<times> cfstate) set \<Rightarrow> nat \<Rightarrow> iEFSM \<Rightarrow> strategy \<Rightarrow> update_modifier \<Rightarrow> (transition_matrix \<Rightarrow> bool) \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> iEFSM" where
  "infer failedMerges k e r m check np = (
    let scores = if k = 1 then score_1 e r else (k_score k e r) in
    case inference_step failedMerges e (ffilter (\<lambda>s. (S1 s, S2 s) \<notin> failedMerges \<and> (S2 s, S1 s) \<notin> failedMerges) scores) m check np of
      (None, _) \<Rightarrow> e |
      (Some new, failedMerges) \<Rightarrow> if (S new) |\<subset>| (S e) then infer failedMerges k new r m check np else e
  )"
  by auto
termination
  apply (relation "measures [\<lambda>(_, _, e, _). size (S e)]")
   apply simp
  by (metis (no_types, lifting) case_prod_conv measures_less size_fsubset)

fun get_ints :: "trace \<Rightarrow> int list" where
  "get_ints [] = []" |
  "get_ints ((_, inputs, outputs)#t) = (map (\<lambda>x. case x of Num n \<Rightarrow> n) (filter is_Num (inputs@outputs)))"

definition learn :: "nat \<Rightarrow> iEFSM \<Rightarrow> log \<Rightarrow> strategy \<Rightarrow> update_modifier \<Rightarrow> (iEFSM \<Rightarrow> nondeterministic_pair fset) \<Rightarrow> iEFSM" where
  "learn n pta l r m np = (
     let check = accepts_log (set l) in
         (infer {} n pta r m check np)
   )"

subsection\<open>Evaluating Inferred Models\<close>
text\<open>We need a function to test the EFSMs we infer. The \texttt{test\_trace} function executes a
trace in the model and outputs a more comprehensive trace such that the expected outputs and actual
outputs can be compared. If a point is reached where the model does not recognise an action, the
remainder of the trace forms the second element of the output pair such that we know the exact point
at which the model stopped processing.\<close>

definition i_possible_steps :: "iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> label \<Rightarrow> inputs \<Rightarrow> (tids \<times> cfstate \<times> transition) fset" where
  "i_possible_steps e s r l i = fimage (\<lambda>(uid, (origin, dest), t). (uid, dest, t))
  (ffilter (\<lambda>(uid, (origin, dest::nat), t::transition).
      origin = s
      \<and> (Label t) = l
      \<and> (length i) = (Arity t)
      \<and> apply_guards (Guards t) (join_ir i r)
     )
    e)"

fun test_trace :: "trace \<Rightarrow> iEFSM \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> ((label \<times> inputs \<times> cfstate \<times> cfstate \<times> registers \<times> tids \<times> value list \<times> outputs) list \<times> trace)" where
  "test_trace [] _ _ _ = ([], [])" |
  "test_trace ((l, i, expected)#es) e s r = (
    let
      ps = i_possible_steps e s r l i
    in
      if fis_singleton ps then
        let
          (id, s', t) = fthe_elem ps;
          r' = evaluate_updates t i r;
          actual = evaluate_outputs t i r;
          (est, fail) = (test_trace es e s' r')
        in
        ((l, i, s, s', r, id, expected, actual)#est, fail)
      else
        ([], (l, i, expected)#es)
  )"

text\<open>The \texttt{test\_log} function executes the \texttt{test\_trace} function on a collection of
traces known as the \emph{test set.}\<close>
definition test_log :: "log \<Rightarrow> iEFSM \<Rightarrow> ((label \<times> inputs \<times> cfstate \<times> cfstate \<times> registers \<times> tids \<times> value list \<times> outputs) list \<times> trace) list" where
  "test_log l e = map (\<lambda>t. test_trace t e 0 <>) l"

end


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

theory Sep_Cancel
imports Sep_Provers Sep_Tactic_Helpers Sep_Cancel_Set
begin

(* Sep_Cancel performs cancellative elimination of conjuncts *)

lemma sep_curry': "\<lbrakk>(P \<and>* F) s; \<And>s. (Q \<and>* P \<and>* F) s \<Longrightarrow> R s\<rbrakk> \<Longrightarrow> (Q \<longrightarrow>* R) s"
  by (metis (full_types) sep.mult_commute sep_curry)

lemma sep_conj_sep_impl_safe:
  "(P \<longrightarrow>* P') s \<Longrightarrow> (\<And>s. ((P \<longrightarrow>* P') \<and>* Q) s \<Longrightarrow> (Q') s) \<Longrightarrow> (Q \<longrightarrow>* Q') s"
  by (rule sep_curry)

lemma  sep_conj_sep_impl_safe': "P s \<Longrightarrow> (\<And>s. (P \<and>* Q) s \<Longrightarrow> (P \<and>* R) s) \<Longrightarrow> (Q \<longrightarrow>* P \<and>* R) s"
  by (rule sep_curry)

lemma sep_wand_lens_simple: "(\<And>s. T s = (Q \<and>* R) s) \<Longrightarrow> (P \<longrightarrow>* T) s \<Longrightarrow> (P \<longrightarrow>* Q \<and>* R) s"
  by (clarsimp simp: sep_impl_def)

schematic_goal schem_impAny: " (?C \<and>* B) s \<Longrightarrow> A s" by (erule sep_mp)

ML {*
  fun sep_cancel_tactic ctxt concl  =
    let val thms = rev (SepCancel_Rules.get ctxt)
        val tac  = assume_tac ctxt ORELSE'
                   eresolve_tac ctxt [@{thm sep_mp}, @{thm sep_conj_empty}, @{thm sep_empty_conj}] ORELSE'
                   sep_erule_tactic ctxt thms
        val direct_tac = eresolve_tac ctxt thms
        val safe_sep_wand_tac = rotator' ctxt (resolve0_tac [@{thm sep_wand_lens_simple}]) (eresolve0_tac [@{thm sep_conj_sep_impl_safe'}])
        fun sep_cancel_tactic_inner true   = sep_erule_full_tac' tac ctxt
          | sep_cancel_tactic_inner false  = sep_erule_full_tac tac ctxt
  in sep_cancel_tactic_inner concl ORELSE'
      eresolve_tac ctxt [@{thm sep_curry'}, @{thm sep_conj_sep_impl_safe}, @{thm sep_imp_empty}, @{thm sep_empty_imp'}] ORELSE'
      safe_sep_wand_tac ORELSE'
      direct_tac
  end

  fun sep_cancel_tactic' ctxt concl =
    let
      val sep_cancel = sep_cancel_tactic ctxt
    in
      (sep_flatten ctxt THEN_ALL_NEW sep_cancel concl) ORELSE' sep_cancel concl
    end

  fun sep_cancel_method (concl,_) ctxt = SIMPLE_METHOD' (sep_cancel_tactic' ctxt concl)

  val sep_cancel_syntax =
    Method.sections [Args.add -- Args.colon >> K (Method.modifier SepCancel_Rules.add @{here})];

  val sep_cancel_syntax' =
    Scan.lift (Args.mode "concl") -- sep_cancel_syntax
*}

method_setup sep_cancel =
  {* sep_cancel_syntax' >> sep_cancel_method *}  {* Simple elimination of conjuncts *}

end