theory SM_Sticky
imports
  SM_Indep
  DFS_Framework.Reachable_Nodes
  DFS_Framework.Feedback_Arcs
  Partial_Order_Reduction.Ample_Analysis
begin

  lemma eq_conv_sym:
    assumes "(a=b) = c"
    shows "(b=a) = c"
    using assms by auto

  lemma neq_conv_sym:
    assumes "(a\<noteq>b) = c"
    shows "(b\<noteq>a) = c"
    using assms by auto

  lemmas [iff] = not_None_eq[THEN neq_conv_sym]

  lemma none_notin_set_map_Some_conv: "None \<notin> set w \<longleftrightarrow> (\<exists>w'. w=map Some w')"
    apply rule
      apply (induction w)
      apply (auto simp: map_eq_Cons_conv[THEN eq_conv_sym]) [2]

      apply auto []
    done

  context cprog begin
    definition "cfgc_V0 \<equiv> comp.\<gamma> ` cfg_V0 prog"
    definition "cfgc_V0_list \<equiv> map comp.\<gamma> (cfg_V0_list prog)"

    lemma cfgc_V0_list_refine: "(cfgc_V0_list, cfgc_V0) \<in> \<langle>Id\<rangle>list_set_rel"
      unfolding cfgc_V0_def cfgc_V0_list_def list_set_rel_def br_def
      using cfg_V0_list_invar cfg_V0_list_refine
      apply (auto simp: distinct_map intro!: inj_onI)
      using comp.\<alpha>_\<gamma>_inverse comp.rl_reachable
      apply auto
      by (meson Image_iff comp.\<gamma>_inj inj_onD inj_on_subset rtrancl.rtrancl_refl)

    definition "cfgc_E \<equiv> {(c,c'). \<exists>a. cfgc c a c'}"
    definition "cfgc_E_succ \<equiv> remdups o map snd o comp.succ_impl"

    lemma cfgc_E_succ_refine: "(cfgc_E_succ, cfgc_E) \<in> \<langle>nat_rel\<rangle>slg_rel"
      unfolding cfgc_E_def cfgc_E_succ_def comp.astep_impl_def
      unfolding slg_rel_def build_rel_def
      apply (rule relcompI[where b="\<lambda>c. snd`set (comp.succ_impl c)"])
      apply (auto simp: list_set_rel_def build_rel_def comp.succ_impl_invar)
      done

    definition "cfgc_G \<equiv> \<lparr> g_V = UNIV, g_E = cfgc_E, g_V0 = cfgc_V0 \<rparr>"
    definition "cfgc_G_impl \<equiv> \<lparr> gi_V = \<lambda> _. True, gi_E = cfgc_E_succ, gi_V0 = cfgc_V0_list \<rparr>"

    lemma cfg_G_simps[simp]:
      "g_V cfgc_G = UNIV"
      "g_E cfgc_G = cfgc_E"
      "g_V0 cfgc_G = cfgc_V0"
      unfolding cfgc_G_def by auto

    lemma cfgc_G_impl_refine: "(cfgc_G_impl, cfgc_G) \<in> \<langle>unit_rel, nat_rel\<rangle>g_impl_rel_ext"
      unfolding cfgc_G_def cfgc_G_impl_def
      by (parametricity add: fun_set_UNIV_refine cfgc_V0_list_refine cfgc_E_succ_refine)

    lemma cfgc_V0_invarc: "c\<in>cfgc_V0 \<Longrightarrow> comp.invar c"
      unfolding cfgc_V0_def comp.invar_def
      apply auto
      apply (rule comp.\<gamma>_invar)
      apply (auto simp: approx_reachable_list_refine cfg_V0_def approx_reachable_prog0)
      done

    lemma cfgc_Estar_invarc: "\<lbrakk>comp.invar c; (c,c')\<in>cfgc_E\<^sup>*\<rbrakk> \<Longrightarrow> comp.invar c'"
      apply (rotate_tac)
      apply (induction rule: rtrancl_induct)
      apply (auto simp: cfgc_E_def comp.astep_impl_invarc)
      done

  end

  context visible_prog
  begin

    lemma pid_valid_preserve[simp]: "pid_valid (ga_ex a gc) pid = pid_valid gc pid"
      by (auto
        simp: ga_ex_def ga_gex_def stutter_extend_ex_def
        split: option.splits prod.splits
      )

    lemma pid_valid_preserve_fold[simp]: "pid_valid (fold ga_ex w gc) pid = pid_valid gc pid"
      by (induction w arbitrary: gc) auto

    lemma pid_valid_ga_gen: "(pid,cac)\<in>ga_gen gc \<Longrightarrow> pid_valid gc pid"
      by (auto simp: ga_gen_def)

    lemma pid_valid_ga_en: "Some (pid,cac)\<in>ga_en gc \<Longrightarrow> pid_valid gc pid"
      by (auto simp: some_ga_en_eq pid_valid_ga_gen)

    sublocale sys_graph: fb_graph cfgc_G
      apply unfold_locales
      apply (simp_all add: cfgc_V0_def cfg_V0_def cfgc_E_def)
      done

    lemma finite_cfgE_reachable[simp, intro!]: "finite (cfgc_E\<^sup>* `` cfgc_V0)"
      apply (rule finite_ImageI)
      using sys_graph.finite_V0
      apply simp
      apply (rule finite_subset[where B="Collect comp.invar"])
      apply (auto intro: cfgc_V0_invarc cfgc_Estar_invarc) []
      apply (simp add: comp.invar_def[abs_def])
      done

    definition "vis_edges \<equiv> {(c,c'). \<exists>a. cfgc c a c' \<and> write_globals a \<inter> vis_vars \<noteq> {}}"

    fun ga_is_pid :: "global_action option \<Rightarrow> pid \<Rightarrow> bool" where
      "ga_is_pid None _ \<longleftrightarrow> True"
    | "ga_is_pid (Some (pid',_)) pid \<longleftrightarrow> pid'=pid"

    lemma
      assumes "(pid,c,a,c') \<in> ga_gen gc"
      shows
        ga_gen_cmd: "cmd_of_pid gc pid = c" and
        ga_gen_cmd': "cmd_of_pid (ga_gex (pid,c,a,c') gc) pid = c'" and
        ga_gen_edge: "(c,c')\<in>cfgc_E"
      using assms
      apply -
      apply (cases a)
      apply (auto
        simp: cfgc_E_def
        simp: ga_gen_def la_en'_def
        simp: ga_gex_def la_ex'_def
        split: option.splits
        ) [5]
      apply (cases a)
      apply (auto
        simp: cfgc_E_def
        simp: ga_gen_def la_en'_def
        simp: ga_gex_def la_ex'_def
        split: option.splits
        ) [5]
      apply (cases a)
      apply (auto
        simp: cfgc_E_def
        simp: ga_gen_def la_en'_def
        simp: ga_gex_def la_ex'_def
        split: option.splits
        ) [5]
      done

    lemmas ga_gen_cmd_cfg = ga_gen_cmd ga_gen_cmd' ga_gen_edge

    lemma ga_gex_other:
      assumes "pid'\<noteq>pid"
      shows "cmd_of_pid (ga_gex (pid',c,a,c') gc) pid = cmd_of_pid gc pid"
      using assms
      apply (cases a)
      apply (auto
        simp: ga_gex_def la_ex'_def
        split: option.splits
        ) [5]
      done

    lemma proj_word_fin_to_cfg_E:
      assumes "jsys.path (map Some w) gc"
      assumes "fold ga_gex w gc = gc'"
      shows "(cmd_of_pid gc pid, cmd_of_pid gc' pid)
        \<in> (cfgc_E \<inter> (\<lambda>(_,c,_,c'). (c,c'))`set w)\<^sup>*" (is "_\<in>(?E w)\<^sup>*")
      using assms
    proof (induction w arbitrary: gc)
      case (Cons ga w)
      from Cons.prems have
        EN: "ga \<in> ga_gen gc" and
        WF': "jsys.path (map Some w) (ga_gex ga gc)" and
        EX': "fold ga_gex w (ga_gex ga gc) = gc'"
        by (auto simp: some_ga_en_eq some_ga_ex_eq)
      obtain pid' c a c' where [simp]: "ga = (pid',c,a,c')"
        by (cases ga)

      have "(cmd_of_pid gc pid, cmd_of_pid (ga_gex ga gc) pid) \<in> (?E (ga#w))\<^sup>*"
      proof (cases "pid'=pid")
        case True
        note True[simp]
        from EN have "(pid,c,a,c')\<in>ga_gen gc" by simp
        from ga_gen_cmd_cfg[OF this]
        have "(cmd_of_pid gc pid, cmd_of_pid (ga_gex ga gc) pid) \<in> ?E (ga#w)"
          by auto
        thus ?thesis ..
      next
        case False
        hence "cmd_of_pid (ga_gex ga gc) pid = cmd_of_pid gc pid"
          by (simp add: ga_gex_other)
        thus ?thesis by auto
      qed
      also from Cons.IH[OF WF' EX'] have
        "(cmd_of_pid (ga_gex ga gc) pid, cmd_of_pid gc' pid) \<in> (?E (ga#w))\<^sup>*"
        apply (rule set_rev_mp[OF _ rtrancl_mono])
        by auto
      finally show ?case .
    qed simp

    lemma words_fin_None_fmt:
      assumes "jsys.path w gc"
      obtains w' n where "w=map Some w'@replicate n None"
      using assms
    proof (induction arbitrary: thesis)
      case nil thus ?case by simp
    next
      case (cons a gc w)
      from cons.IH obtain w' n where [simp]: "w=map Some w'@replicate n None" .
      show ?case proof (cases a)
        case None
        note None[simp]
        from cons.hyps have [simp]: "w'=[]"
          by (cases w') (auto simp: none_ga_en_eq some_ga_en_eq)
        show ?thesis apply (rule cons.prems[of "[]" "Suc n"]) by simp
      next
        case (Some aa)
        note Some[simp]
        show ?thesis apply (rule cons.prems[of "aa#w'" n]) by simp
      qed
    qed

    lemma proj_reachable_to_cfgE:
      assumes R: "gc\<in>jsys.nodes"
      assumes PIDV: "pid_valid gc pid"
      shows "\<exists>c0\<in>cfgc_V0. (c0,cmd_of_pid gc pid)\<in>cfgc_E\<^sup>*"
    proof -
      from R obtain w where
        WF: "jsys.path w pid_init_gc"
        and EX: "fold ga_ex w (pid_init_gc) = gc"
        by rule auto
      from words_fin_None_fmt[OF WF] obtain w' n where
        [simp]: "w = map Some w'@replicate n None" .

      from EX have "fold ga_ex (map Some w') (pid_init_gc) = gc"
        by simp
      hence EX': "fold ga_gex w' (pid_init_gc) = gc"
        by (simp add: fold_map some_ga_ex_eq)

      from WF have WF': "jsys.path (map Some w') pid_init_gc"
        by auto

      from proj_word_fin_to_cfg_E[OF WF' EX', of pid] have
        G: "(cmd_of_pid (pid_init_gc) pid,cmd_of_pid gc pid) \<in> cfgc_E\<^sup>*"
        by (rule set_rev_mp[OF _ rtrancl_mono]) auto

      show ?thesis proof (cases "pid_valid (pid_init_gc) pid")
        case True
        hence "cmd_of_pid (pid_init_gc) pid \<in> cfgc_V0"
          by (auto simp: cfgc_V0_def cfg_V0_def pid_init_gc_def init_pc_def)
        with G show ?thesis ..
      next
        case False
        hence "\<not>pid_valid gc pid"
          unfolding EX[symmetric] by simp
        with PIDV have False by blast thus ?thesis ..
      qed
    qed

    lemma proj_ne_word_fin_to_cfg_E:
      assumes WF: "jsys.path (map Some w) gc"
      assumes EX: "fold ga_gex w gc = gc'"
      assumes [simp]: "w=(pid,cac)#w'" (is "w=?ga#_")
      shows "(cmd_of_pid gc pid, cmd_of_pid gc' pid)
        \<in> (cfgc_E \<inter> (\<lambda>(_,c,_,c'). (c,c'))`set w)\<^sup>+" (is "_\<in>?E\<^sup>+")
    proof -
      from WF EX have
        EN: "?ga \<in> ga_gen gc" and
        WF': "jsys.path (map Some w') (ga_gex ?ga gc)" and
        EX': "fold ga_gex w' (ga_gex ?ga gc) = gc'"
        by (auto simp: some_ga_en_eq some_ga_ex_eq)

      obtain c a c' where [simp]: "cac = (c,a,c')" by (cases cac)

      from EN have "(pid,c,a,c')\<in>ga_gen gc" by simp
      from ga_gen_cmd_cfg[OF this]
      have "(cmd_of_pid gc pid, cmd_of_pid (ga_gex ?ga gc) pid) \<in> ?E"
        by auto
      also from proj_word_fin_to_cfg_E[OF WF' EX']
      have "(cmd_of_pid (ga_gex ?ga gc) pid, cmd_of_pid gc' pid) \<in> ?E\<^sup>*"
        apply (rule set_rev_mp[OF _ rtrancl_mono])
        by auto
      finally (rtrancl_into_trancl2) show ?thesis .
    qed

  end

  locale sticky_prog = visible_prog +
    fixes sticky_E
    assumes sticky_E_fas: "is_fas cfgc_G sticky_E"
    assumes sticky_E_vis: "vis_edges \<subseteq> sticky_E"
  begin

    definition "sticky_ga \<equiv> Collect (
      \<lambda>None \<Rightarrow> True
    | Some (pid,c,a,c') \<Rightarrow> (c,c')\<in>sticky_E)"

    lemma sticky_ga_approx_visible: "jsys.visible \<subseteq> sticky_ga"
    proof -
      have aux: "\<And>s s'. sm_props s \<noteq> sm_props s' \<Longrightarrow> s \<noteq> s'"
        by auto

      show ?thesis
        apply (clarsimp simp: sticky_ga_def split: option.split)
        apply (rule set_mp[OF sticky_E_vis])
        apply (clarsimp
          elim!: jsys.visibleE
          simp: sticky_ga_def
          split: option.split)
        apply (clarsimp
          split: prod.splits
          simp: ga_en_def ga_gen_def ga_ex_def ga_gex_def
          simp: pid_interp_gc_def interp_gs_def
          simp: vis_edges_def)
        apply (intro exI conjI, assumption)
        apply (drule ex_mod_limit)

        apply (drule aux)
        apply (fastforce simp: eq_on_def restrict_map_def)
        done
    qed

    lemma sticky_ga_breaks_cycles:
      assumes "gc\<in>jsys.nodes"
      assumes "w\<in>jsys.cycles gc"
      assumes "w\<noteq>[]"
      shows "set w \<inter> sticky_ga \<noteq> {}"
    proof (cases "None \<in> set w")
      case True
      thus ?thesis
        by (auto simp: sticky_ga_def)
    next
      case False
      then obtain w' where [simp]: "w=map Some w'"
        by (auto simp: none_notin_set_map_Some_conv)

      have aux1: "Some ` set w' \<inter> sticky_ga
        = Some ` (set w' \<inter> {(pid,c,a,c'). (c,c')\<in>sticky_E})"
        by (auto simp: sticky_ga_def)

      show ?thesis
      proof (cases "\<exists>(pid,c,a,c')\<in>set w'. (c,c')\<in>sticky_E")
        case True thus ?thesis by (auto simp: aux1)
      next
        case False
        let ?E = "(cfgc_E \<inter> (\<lambda>(_, c, _, c'). (c, c')) ` set w')"

        from False have NO_STICKY: "?E \<inter> sticky_E = {}" by auto

        from \<open>w\<noteq>[]\<close> obtain pid cac w'' where W'_FMT[simp]: "w'=(pid,cac)#w''"
          by (auto simp: neq_Nil_conv)

        from \<open>w\<in>jsys.cycles gc\<close> have PIDV: "pid_valid gc pid"
          by (auto simp: pid_valid_ga_en)

        have "(cmd_of_pid gc pid, cmd_of_pid gc pid)\<in> ?E\<^sup>+"
          apply (rule proj_ne_word_fin_to_cfg_E[OF _ _ W'_FMT])
          using \<open>w\<in>jsys.cycles gc\<close>
          by (auto simp: fold_map some_ga_ex_eq)
        hence CYC: "(cmd_of_pid gc pid, cmd_of_pid gc pid) \<in> (cfgc_E-sticky_E)\<^sup>+"
          apply (rule trancl_mono)
          using NO_STICKY by blast

        from proj_reachable_to_cfgE[OF \<open>gc\<in>jsys.nodes\<close> PIDV] obtain
          c0 where C0: "c0\<in>cfgc_V0" and REACH: "(c0,cmd_of_pid gc pid)\<in>cfgc_E\<^sup>*" ..

        from CYC C0 REACH sticky_E_fas[unfolded is_fas_def]
          have False by force
        thus ?thesis ..
      qed
    qed

    sublocale jsys: transition_system_sticky
      ga_ex "\<lambda> a p. a \<in> ga_en p" "\<lambda> p. p = pid_init_gc" pid_interp_gc sticky_ga
      apply unfold_locales
      using sticky_ga_breaks_cycles apply blast
      using sticky_ga_approx_visible apply blast
      done

    sublocale jsys: transition_system_ample ga_ex "\<lambda> a p. a \<in> ga_en p" "\<lambda> p. p = pid_init_gc"
      pid_interp_gc sticky_ga ind
      by unfold_locales

  end

end


theory ExclLemma
  imports RedSafeCV ProcCVars ProcDef
begin

definition can_access where
  "can_access e x = (x \<in> ref_vars e)"

  (*thm proper_exp_def*)

lemma well_typed_deref_ex: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; Loc x \<notin> res_vars e; x \<in> ref_vars e \<rbrakk> \<Longrightarrow> (\<exists> z. (z, x) \<in> own_pairs e)"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
         apply (case_tac xa)
           apply (auto)
    (* pair case. *)
        apply (blast)
       apply (blast)
    (* if case. *)
      apply (blast)
     apply (blast)
    apply (blast)
    (* lam case. *)
   apply (blast)
    (* app case. *)
  apply (blast)
  done

lemma well_typed_deref_ref_use: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; (x, y) \<in> own_pairs e \<rbrakk> \<Longrightarrow> x \<in> ref_vars e"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
      apply (case_tac xa)
        apply (auto)
    (* other cases. *)
     apply (blast)
    apply (blast)
   apply (blast)
  apply (blast)
  done

lemma well_typed_deref_npv_use: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; (x, y) \<in> own_pairs e \<rbrakk> \<Longrightarrow> Loc x \<in> non_prim_vars env e"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
          apply (case_tac xa)
            apply (auto)
          apply (simp add: non_prim_vars_def)
          apply (simp add: non_prim_entry_def)
    (* other cases. *)
         apply (simp add: non_prim_vars_def)
        apply (simp add: non_prim_vars_def)
       apply (simp add: non_prim_vars_def)
      apply (simp add: non_prim_vars_def)
     apply (simp add: non_prim_vars_def)
    apply (simp add: non_prim_vars_def)
    (* lam case *)
    apply (simp add: non_prim_entry_def)
    apply (case_tac "\<exists> t. add_env env (Var x1a) t1 (Loc x) = Some t \<and> req_type t \<noteq> Prim")
     apply (simp add: add_env_def)
    apply (auto)
    (* app case *)
   apply (simp add: non_prim_vars_def)
  apply (simp add: non_prim_vars_def)
  done

fun in_path where
  "in_path x [] = False"
| "in_path x (y # t) = (x = y \<or> in_path x t)"

    (* if x \<leadsto> z and y \<leadsto> z, and x is in the path from y \<leadsto> z, then y \<leadsto> a \<leadsto> x \<leadsto> z *)
lemma path_lookup_cross_ih: "\<lbrakk> path_lookup rs_map x l z; in_path x m; path_lookup rs_map y m z \<rbrakk> \<Longrightarrow>
  (\<exists> a m'. path_lookup rs_map y m' a \<and> nres_lookup rs_map a (Loc x) \<noteq> NoPerm \<and> path_lookup rs_map x l z \<and> (a = y \<or> in_path a m))"
  apply (induct m arbitrary: y)
   apply (auto)
    (* case where x = a (the top of the path) *)
   apply (case_tac "rs_map y")
    apply (auto)
   apply (rule_tac x="y" in exI)
   apply (auto)
    apply (rule_tac x="[]" in exI)
    apply (simp)
   apply (simp add: nres_lookup_def)
    (* inductive case *)
  apply (case_tac "rs_map y")
   apply (auto)
  apply (case_tac "\<exists>b. (\<exists>m'. path_lookup rs_map a m' b) \<and> nres_lookup rs_map b (Loc x) \<noteq> NoPerm \<and> (b = a \<or> in_path b m)")
   apply (erule_tac exE)
   apply (auto)
   apply (rule_tac x="a" in exI)
   apply (auto)
   apply (rule_tac x="[a]" in exI)
   apply (auto)
  apply (rule_tac x="b" in exI)
  apply (auto)
   apply (rule_tac x="a # m'" in exI)
  apply (auto)
  done

lemma lookup_in_path: "\<lbrakk> in_path z l; path_lookup rs_map x l y \<rbrakk> \<Longrightarrow> (\<exists> a. nres_lookup rs_map a (Loc z) \<noteq> NoPerm)"
  apply (induct l arbitrary: x)
   apply (auto)
   apply (case_tac "rs_map x")
    apply (auto)
   apply (simp add: nres_lookup_def)
   apply (rule_tac x="x" in exI)
   apply (auto)
  apply (case_tac "rs_map x")
   apply (auto)
  done

lemma end_in_path: "\<lbrakk> x \<noteq> y; path_lookup rs_map x l y \<rbrakk> \<Longrightarrow> in_path y l"
  apply (induct l arbitrary: x)
   apply (auto)
  apply (case_tac "rs_map x")
   apply (auto)
  apply (case_tac "a = y")
   apply (auto)
  done

    (* if x \<leadsto> z and y \<leadsto> z, then x \<leadsto> a \<leadsto> c \<leadsto> z, and y \<leadsto> b \<leadsto> c \<leadsto> z, a \<noteq> b *)
lemma path_lookup_cross: "\<lbrakk> x \<noteq> y; \<not> in_path x m; \<not> in_path y l; path_lookup rs_map x l z; path_lookup rs_map y m z \<rbrakk> \<Longrightarrow>
  (\<exists> a b c l' m' lx. a \<noteq> b \<and> path_lookup rs_map x l' a \<and> path_lookup rs_map y m' b \<and>
    nres_lookup rs_map a (Loc c) \<noteq> NoPerm \<and> nres_lookup rs_map b (Loc c) \<noteq> NoPerm \<and> path_lookup rs_map c lx z)"
    (* we induct over the l, attempting to apply the induction lemma, when x is in_path m *)
  apply (induct l arbitrary: x)
   apply (auto)
    (* empty list case is impossible, since z must be in m *)
   apply (cut_tac y="z" and l="m" in end_in_path)
     apply (auto)
  apply (case_tac "rs_map x")
   apply (auto)
    (* if a is in_path m, by lemma we can get y \<leadsto> ? \<leadsto> a \<leadsto> z. we can select x \<leadsto> x \<leadsto> a \<leadsto> z, y \<leadsto> ? \<leadsto> a \<leadsto> z *)
  apply (case_tac "in_path a m")
   apply (case_tac "\<not> (\<exists>aa m'. path_lookup rs_map y m' aa \<and> nres_lookup rs_map aa (Loc a) \<noteq> NoPerm \<and> path_lookup rs_map a l z \<and> (aa \<noteq> x))")
    apply (cut_tac x="a" and rs_map="rs_map" and l="l" and y="y" and z="z" and m="m" in path_lookup_cross_ih)
       apply (auto)
   apply (rule_tac x="x" in exI)
   apply (rule_tac x="aaa" in exI)
   apply (auto)
    apply (rule_tac x="[]" in exI)
    apply (auto)
   apply (rule_tac x="a" in exI)
   apply (simp add: nres_lookup_def)
   apply (case_tac "rs_map aaa")
    apply (auto)
    (* otherwise, we can induct. *)
  apply (case_tac "\<exists>a' b. a' \<noteq> b \<and> (\<exists>l'. path_lookup rs_map a l' a') \<and>
                          (\<exists>m'. path_lookup rs_map y m' b) \<and>
                          (\<exists>c. nres_lookup rs_map a' (Loc c) \<noteq> NoPerm \<and> nres_lookup rs_map b (Loc c) \<noteq> NoPerm \<and> (\<exists>lx. path_lookup rs_map c lx z))")
   apply (erule_tac exE)
   apply (auto)
    (* - we take x \<leadsto> a' \<leadsto> c \<leadsto> z, y \<leadsto> b \<leadsto> c \<leadsto> z *)
  apply (rule_tac x="a'" in exI)
  apply (rule_tac x="b" in exI)
  apply (auto)
  apply (rule_tac x="a # l'" in exI)
  apply (auto)
  done

definition close_dom_use_env where
  "close_dom_use_env env rs_map e = (\<lambda> x. if x \<in> { Loc x | x. \<exists> l z. Loc z \<in> non_prim_vars env e \<and> path_lookup rs_map z l x }
    then OwnPerm else NoPerm)"

lemma full_close_dom_use_env: "\<lbrakk> well_typed_system env rs_map p_map s p_set; p_set u = Some e \<rbrakk> \<Longrightarrow>
  close_dom_use_env env rs_map e = full_dom_use_env env rs_map e"
    (* we want to prove these two definitions are equivalent in a well-typed system *)
  apply (case_tac "\<forall> x. close_dom_use_env env rs_map e x = full_dom_use_env env rs_map e x")
   apply (auto)
  apply (simp add: close_dom_use_env_def)
  apply (simp add: full_dom_use_env_def)
  apply (simp add: dom_use_env_def)
    (* the only part where they would differ would be if x was in the set of non-prim vars, but not in the closure *)
  apply (case_tac "\<exists>xa. x = Loc xa \<and> (\<exists>l z. Loc z \<in> non_prim_vars env e \<and> path_lookup rs_map z l xa)")
   apply (auto)
  apply (case_tac "x \<in> non_prim_vars env e")
   apply (auto)
    (* x cannot be a var since the env is contained in the state *)
  apply (case_tac x)
   apply (auto)
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_state_def)
   apply (simp add: sub_env_def)
   apply (simp add: non_prim_vars_def)
   apply (simp add: non_prim_entry_def)
   apply (auto)
    (* since x is a location, we need only demonstrate a path to it. it should lead to itself *)
  apply (erule_tac x="[]" in allE)
  apply (erule_tac x="x2" in allE)
  apply (auto)
  done

lemma wts_excl_dom_use_env: "\<lbrakk> well_typed_system env rs_map p_map s p_set; u \<noteq> v; p_set u = Some e; p_set v = Some e';
  p_map u = Some r_sa; p_map v = Some r_sb; well_typed env r_sa e UnitTy r_se r_xe; well_typed env r_sb e' UnitTy r_se' r_xe' \<rbrakk> \<Longrightarrow>
  strong_disj_use_env (full_dom_use_env env rs_map e) (full_dom_use_env env rs_map e')"
    (* first, we use a weaker definition of dominator, to cancel out some edge cases *)
  apply (rule_tac t="full_dom_use_env env rs_map e" and s="close_dom_use_env env rs_map e" in subst)
   apply (simp add: full_close_dom_use_env)
  apply (rule_tac t="full_dom_use_env env rs_map e'" and s="close_dom_use_env env rs_map e'" in subst)
   apply (simp add: full_close_dom_use_env)
    (* if they are not disjoint, there is some z \<leadsto> xa, za \<leadsto> x *)
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  apply (simp add: close_dom_use_env_def)
  apply (auto)
  apply (case_tac "\<exists>l z. Loc z \<in> non_prim_vars env e' \<and> path_lookup rs_map z l xa")
   apply (auto)
    (* we can establish r_sa z \<noteq> None, and r_sb za \<noteq> None *)
  apply (case_tac "r_sa (Loc z) = NoPerm")
   apply (cut_tac x="Loc z" and ?r_s1.0="r_sa" and e="e" in well_typed_no_npv_use)
     apply (auto)
  apply (case_tac "r_sb (Loc za) = NoPerm")
   apply (cut_tac x="Loc za" and ?r_s1.0="r_sb" and e="e'" in well_typed_no_npv_use)
     apply (auto)
    (* if z = za, we have a contradiction by map exclusion. *)
  apply (case_tac "z = za")
   apply (case_tac "\<not> disj_nres_map p_map")
    apply (simp add: well_typed_system_def)
    apply (simp add: well_typed_proc_set_def)
   apply (simp add: disj_nres_map_def)
   apply (erule_tac x="u" in allE)
   apply (erule_tac x="v" in allE)
   apply (auto)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="Loc za" in allE)
   apply (simp add: nres_lookup_def)
    (* if za is in l, we have a contradiction by map separation. *)
  apply (case_tac "in_path za l")
   apply (simp add: well_typed_system_def)
   apply (auto)
   apply (erule_tac x="v" in allE)
   apply (auto)
   apply (cut_tac rs_map="rs_map" and z="za" and l="l" in lookup_in_path)
     apply (auto)
   apply (simp add: sep_nres_map_def)
   apply (erule_tac x="a" in allE)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="Loc za" in allE)
   apply (auto)
    (* similarly, we can show z is not in la *)
  apply (case_tac "in_path z la")
   apply (simp add: well_typed_system_def)
   apply (auto)
   apply (erule_tac x="u" in allE)
   apply (auto)
   apply (cut_tac rs_map="rs_map" and z="z" and l="la" in lookup_in_path)
     apply (auto)
   apply (simp add: sep_nres_map_def)
   apply (erule_tac x="a" in allE)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="Loc z" in allE)
   apply (auto)
    (* otherwise we should be able to find a, b, c where z \<leadsto> a \<leadsto> c \<leadsto> xa and za \<leadsto> b \<leadsto> c \<leadsto> xa*)
  apply (cut_tac rs_map="rs_map" and x="z" and y="za" and z="xa" in path_lookup_cross)
       apply (auto)
    (* this is a contradiction by res map exclusion on the maps of a + b containing c *)
  apply (case_tac "\<not> disj_nres_map rs_map")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_state_def)
   apply (simp add: valid_nres_map_def)
  apply (simp add: disj_nres_map_def)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="b" in allE)
  apply (auto)
  apply (simp add: strong_disj_use_env_def)
  apply (erule_tac x="Loc c" in allE)
  apply (auto)
  done

lemma well_typed_no_dom_use: "\<lbrakk> well_typed_state s env rs_map; p_set u = Some e; p_map u = Some r_s;
  well_typed env r_s e UnitTy r_se r_xe; x \<in> ref_vars e; proper_exp rs_map e \<rbrakk> \<Longrightarrow> full_dom_use_env env rs_map e (Loc x) \<noteq> NoPerm"
    (* res_var case. in this case it is in the dominator since it is non-prim *)
  apply (case_tac "Loc x \<in> res_vars e")
   apply (case_tac "env (Loc x) = None")
    apply (cut_tac env="env" and x="x" and e="e" in well_typed_rv_env_use)
      apply (auto)
   apply (case_tac "Loc x \<notin> non_prim_vars env e")
    apply (cut_tac s="s" and env="env" and rs_map="rs_map" in wts_mem_val_env)
     apply (simp)
    apply (simp add: mem_val_env_def)
    apply (erule_tac x="Loc x" in allE)
    apply (auto)
    apply (simp add: non_prim_vars_def)
    apply (simp add: non_prim_entry_def)
    apply (case_tac y)
          apply (auto)
   apply (simp add: full_dom_use_env_def)
   apply (simp add: dom_use_env_def)(*
   apply (case_tac "\<exists> l z. z \<in> non_prim_vars env e \<and> path_lookup rs_map z l x")
    apply (auto)
   apply (erule_tac x="[]" in allE)
   apply (erule_tac x="x" in allE)
   apply (auto)*)
    (* otherwise, we presume that it has an owner with permissions in r_s. since e is proper, there is a lookup between them *)
  apply (cut_tac x="x" and e="e" in well_typed_deref_ex)
     apply (auto)
  apply (simp add: proper_exp_def)
  apply (erule_tac x="z" in allE)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (simp add: full_dom_use_env_def)
  apply (simp add: dom_use_env_def)
  apply (case_tac "\<exists> l z. Loc z \<in> non_prim_vars env e \<and> path_lookup rs_map z l x")
   apply (auto)
  apply (erule_tac x="l" in allE)
  apply (erule_tac x="z" in allE)
  apply (auto)
  apply (cut_tac x="z" and y="x" and e="e" in well_typed_deref_npv_use)
    apply (auto)
  done

lemma excl_safe_lemma: "\<lbrakk> well_typed_system env rs_map p_map s p_set; p_set u = Some e; can_access e x;
  p_set v = Some e'; u \<noteq> v \<rbrakk> \<Longrightarrow> \<not> can_access e' x"
    (* prelim: p_map u + v has an entry *)
  apply (case_tac "p_map u = None \<or> p_map v = None")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_proc_set_def)
   apply (simp add: full_nres_map_def)
   apply (auto)
    apply (erule_tac x="u" in allE)
    apply (auto)
   apply (erule_tac x="v" in allE)
   apply (auto)
    (* prelim: e must be well-typed + proper *)
  apply (case_tac "\<not> (\<exists> r_s rx. well_typed env y e UnitTy r_s rx \<and> proper_exp rs_map e)")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
    apply (erule_tac x="u" in allE)
    apply (auto)
   apply (erule_tac x="u" in allE)
   apply (auto)
    (* prelim: e' is also well-typed + proper *)
  apply (case_tac "\<not> (\<exists> r_s rx. well_typed env ya e' UnitTy r_s rx \<and> proper_exp rs_map e')")
   apply (simp add: well_typed_system_def)
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
    apply (erule_tac x="v" in allE)
    apply (auto)
   apply (erule_tac x="v" in allE)
   apply (auto)
    (* from here, we know that x is in the completion of y + ya *)
  apply (cut_tac env="env" and rs_map="rs_map" and e="e" and x="x" and r_s="y" and s="s" in well_typed_no_dom_use)
        apply (auto)
    apply (simp add: well_typed_system_def)
   apply (simp add: can_access_def)
  apply (cut_tac env="env" and rs_map="rs_map" and e="e'" and x="x" and r_s="ya" and s="s" in well_typed_no_dom_use)
        apply (auto)
    apply (simp add: well_typed_system_def)
   apply (simp add: can_access_def)
    (* this is a contradiction by dominator exlcusion *)
  apply (cut_tac env="env" and rs_map="rs_map" and e="e" and e'="e'" and u="u" and v="v" and p_map="p_map" and s="s" and
      p_set="p_set" in wts_excl_dom_use_env)
          apply (auto)
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  done

end


theory Proof_5_5
  imports Requirements VCTheoryLemmas
begin

abbreviation s where "s s0 requestButton_value \<equiv> (toEnv (setVarAny s0 requestButton_value)) "

lemma VC5_R5_aux1: "toEnvP s2 \<and> toEnvP s0 \<and> substate s2 s0 \<and> toEnvNum s2 s3 < T1 \<and> s3 = s s0 requestButton_value \<Longrightarrow>
toEnvNum s2 s0 < T1"
  apply auto
  apply(simp split: if_splits)
  using substate_refl substate_asym[of s0 "s s0 requestButton_value"] by  auto

lemma VC5_R5: "   (toEnvP s0 \<and>
        (\<forall>s1 s2 s3.
            substate s1 s2 \<and>
            substate s2 s3 \<and>
            substate s3 s0 \<and>
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            toEnvP s3 \<and>
            toEnvNum s1 s2 = Ctrl \<and>
            toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<longrightarrow>
            getVarBool s3 minimalRed = NOT_PRESSED)) \<and>
       env (setVarAny s0 requestButton_value) requestButton_value \<and>
       getPstate (setVarAny s0 requestButton_value) Ctrl = minimalRed \<and>
       \<not> getVarBool (setVarAny s0 requestButton_value) Ctrl \<and>
       \<not> MINIMAL_RED_TIME_LIMIT \<le> ltimeEnv (setVarAny s0 requestButton_value) Ctrl \<Longrightarrow>
       substate s1 s2 \<and>
       substate s2 s3 \<and>
       substate s3 (s s0 requestButton_value) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvP s3 \<and>
       toEnvNum s1 s2 = Ctrl \<and>
       toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<Longrightarrow>
       getVarBool s3 minimalRed = NOT_PRESSED"
  apply(cases "s3 = s s0 requestButton_value")
   apply(cases "s2 = s s0 requestButton_value")
    apply blast
   apply(rule cut_rl[of "substate s2 s0"])
    apply(rule cut_rl[of "getVarBool s0 trafficLight = RED"])
  apply (metis getVarBool.simps(2) getVarBool.simps(4) getVarBool.simps(6) getVarBool.simps(7) numeral_eq_iff one_eq_numeral_iff semiring_norm(85) semiring_norm(89))
    apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule allE[of _ s1])
     prefer 2
  apply assumption
   apply(drule allE[of _ s2])
     prefer 2
     apply assumption
apply(drule allE[of _ s0])
     prefer 2
     apply assumption
    apply(rule cut_rl[of "toEnvNum s2 s0 < T1"])
  using substate_refl apply fast
    apply((rule VC5_R5_aux1);fast)
  apply (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))
  apply(rule cut_rl [of "substate s3 s0"])
   apply blast
  by (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))

theorem proof_5_5: "VC5 R5 s0 requestButton_value"
  apply(simp only: VC5_def R5_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  apply((rule allI);(rule allI);(rule allI))
  apply(rule impI)
  by ((rule VC5_R5);assumption)


theory SC_Depth_Limit
imports SC_Sema SC_Depth
begin

lemma SC_completeness: "\<Turnstile> \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> sequent_cost \<Gamma> \<Delta>"
proof(induction "sequent_cost \<Gamma> \<Delta>" arbitrary: \<Gamma> \<Delta>)
  case 0 hence False by(simp add: sequent_cost_def) thus ?case by clarify
next
  case (Suc n)
  from Suc(3) show ?case
    using SCc.cases[OF Suc.hyps(1)]
oops
text\<open>Making this proof of completeness go through should be possible,
  but finding the right way to split the cases could get verbose.
The variant with the search procedure is a lot more elegant.\<close>

lemma sc_sim_depth:
  assumes "sc \<Gamma> A \<Delta> B = {}"
  shows "image_mset Atom (mset A) + mset \<Gamma> \<Rightarrow> image_mset Atom (mset B) + mset \<Delta> \<down> sum_list (map size (\<Gamma>@\<Delta>)) + (if set A \<inter> set B = {} then 0 else 1)"
proof -
  have [simp]: "image_mset Atom (mset A) \<Rightarrow> image_mset Atom (mset B) \<down> Suc 0" (is ?k) if "set A \<inter> set B \<noteq> {}" for A B
  proof -
    from that obtain a where "a \<in> set A" "a \<in> set B" by blast
    thus ?k by(force simp: in_image_mset intro: SCc.Ax[where k=a])
  qed
  note SCc.intros(3-)[intro]
  have [elim!]: "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> n \<le> m \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> m" for \<Gamma> \<Delta> n m using dec_induct by(fastforce elim!: deeper_suc) (* sledgehammer is flippin' using induction. *)
  from assms show ?thesis
    by(induction \<Gamma> A \<Delta> B rule: sc.induct)
      (auto
      simp add: list_sequent_cost_def add.assoc deeper_suc weakenR'
      split: if_splits option.splits)
qed

corollary sc_depth_complete:
  assumes s: "\<Turnstile> \<Gamma> \<Rightarrow> \<Delta>"
  shows "\<Gamma> \<Rightarrow> \<Delta> \<down> sum_mset (image_mset size (\<Gamma>+\<Delta>))"
proof -
  obtain \<Gamma>' \<Delta>' where p: "\<Gamma> = mset \<Gamma>'" "\<Delta> = mset \<Delta>'" by (metis ex_mset)
  with s have sl: "\<Turnstile> mset \<Gamma>' \<Rightarrow> mset \<Delta>'" by simp
  let ?d = "sum_mset (image_mset size (\<Gamma>+\<Delta>))"
  have d: "?d = sum_list (map size (\<Gamma>'@\<Delta>'))"
    unfolding p by (metis mset_append mset_map sum_mset_sum_list)
  have "mset \<Gamma>' \<Rightarrow> mset \<Delta>' \<down> ?d"
  proof cases
    assume "sc \<Gamma>' [] \<Delta>' [] = {}"
    from sc_sim_depth[OF this] show "mset \<Gamma>' \<Rightarrow> mset \<Delta>' \<down> ?d" unfolding d by auto
  next
    assume "sc \<Gamma>' [] \<Delta>' [] \<noteq> {}"
    with SC_counterexample have "\<not> \<Turnstile> mset \<Gamma>' \<Rightarrow> mset \<Delta>'" by fastforce
    moreover note s[unfolded p]
    ultimately have False ..
    thus "mset \<Gamma>' \<Rightarrow> mset \<Delta>' \<down> ?d" ..
  qed
  thus ?thesis unfolding p .
qed

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: utp_circus_tutorial_ex.thy                                           *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)

section {* {\Circus} Tutorial *}

theory utp_circus_tutorial_ex
imports "../theories/utp_circus" Transitive_Closure
begin recall_syntax

subsection {* Preliminaries *}

no_translations
  "a \<^bold>\<rightarrow> P" == "CONST PrefixCSP \<guillemotleft>a\<guillemotright> P"

translations
  "a \<^bold>\<rightarrow> P" == "CONST PrefixCSP \<guillemotleft>a()\<guillemotright> P"

text \<open>Hints for the tutorial exercise.\<close>

consts COMPLETE :: "'a" ("\<^bold>C\<^bold>O\<^bold>M\<^bold>P\<^bold>L\<^bold>E\<^bold>T\<^bold>E")

paragraph \<open>Additional proof support\<close>

declare list_concat_minus_list_concat [simp]

lemma list_Cons_minus [simp]:
"(x # y) - (x # z) = y - z"
  by (simp add: minus_list_def)

subsection {* Time Types *}

text \<open>Below we define synonyms for the types \<open>TIME\<close> and \<open>PERIOD\<close>.\<close>

type_synonym TIME   = "nat"
type_synonym PERIOD = "nat"

subsection {* Channel Declarations *}

datatype timer_evt =
  setT "TIME" |
  updateSS "PERIOD" |
  step "TIME \<times> PERIOD" |
  endc "unit"

abbreviation timer_prefix ::
  "('a, timer_evt) chan \<Rightarrow>
   ('a, timer_evt + 'ext) chan" where
"timer_prefix c \<equiv> Inl o c"

notation timer_prefix ("tm:_" [1000] 1000)

abbreviation "tm_events \<equiv>
  \<epsilon>(tm:setT) \<union> \<epsilon>(tm:updateSS) \<union> \<epsilon>(tm:step) \<union> \<epsilon>(tm:endc)"

subsection {* Process Definition *}

alphabet timer_state =
  currentTime :: "TIME"
  stepSize :: "PERIOD"

type_synonym timer_action =
  "(timer_state, timer_evt) action"

definition [rdes]:
"process Timer(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(timer_state)
  Step = (
    (tm:setT?(t : \<guillemotleft>t \<le> tN\<guillemotright>) \<^bold>\<rightarrow> currentTime :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
    (tm:updateSS?(ss) \<^bold>\<rightarrow> stepSize :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
    \<^bold>C\<^bold>O\<^bold>M\<^bold>P\<^bold>L\<^bold>E\<^bold>T\<^bold>E) ;; Step
  \<bullet> \<^bold>C\<^bold>O\<^bold>M\<^bold>P\<^bold>L\<^bold>E\<^bold>T\<^bold>E
end"

text \<open>The same process definition using deep variables.\<close>

definition [rdes]:
"process DvarTimer(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(vstore)
  Step = (
    (tm:setT?(t : \<guillemotleft>t \<le> tN\<guillemotright>) \<^bold>\<rightarrow> <currentTime> :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
    (tm:updateSS?(ss) \<^bold>\<rightarrow> <stepSize> :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
    (tm:step!(&<currentTime>)!(&<stepSize>) \<^bold>\<rightarrow>
      <currentTime> :=\<^sub>C min\<^sub>u(&<currentTime> + &<stepSize>, \<guillemotleft>tN\<guillemotright>)) \<box>
    (&<currentTime> =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u tm:endc \<^bold>\<rightarrow> Stop) ;; Step
  \<bullet> (<currentTime>, <stepSize>) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

text \<open>Proof that the @{const Timer} process does not diverge.\<close>

lemma "pre\<^sub>R(Timer(ct, hc, tN)) = true\<^sub>r"
-- \<open>TODO: try to complete this prove using the @{method rdes_calc} tactic.\<close>
oops

text \<open>Proof about the initial refusal set of the @{const Timer} process.\<close>

text \<open>
  Simplified encoding of the @{const Timer} process action. The simplification
  does not consider hiding of the state in the process semantics and neither
  uses the extensible event type. The @{const setT} communication is slightly
  more restrictive, requiring \<open>t < tN\<close> rather than \<open>t \<le> tN\<close>.
\<close>

definition StepBody :: "TIME \<Rightarrow> timer_action" where
"StepBody tN =
  (setT?(t : \<guillemotleft>t\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright>) \<^bold>\<rightarrow> currentTime :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
  (updateSS?(ss) \<^bold>\<rightarrow> stepSize :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
  (step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
    currentTime :=\<^sub>C min\<^sub>u(&currentTime + &stepSize, \<guillemotleft>tN\<guillemotright>)) \<box>
  (&currentTime =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u endc \<^bold>\<rightarrow> Stop"

fun MainAction :: "(TIME \<times> PERIOD \<times> TIME) \<Rightarrow> timer_action" where
"MainAction (ct, hc, tN) =
  (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; (\<mu>\<^sub>C Step \<bullet> StepBody(tN) ;; Step)"

text \<open>Additional lemma needed for the proof below.\<close>

lemma wpR_assign [wp]:
  assumes "P is NCSP"
  shows "($tr\<acute> =\<^sub>u $tr \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>S) wp\<^sub>R pre\<^sub>R P = \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> pre\<^sub>R(P)"
apply (simp add: wpR_def unrest rdes assms rea_not_not closure usubst)
done

text \<open>Communications on @{const setT} are initially not refused.\<close>

lemma StepBody_muI:
"[true \<turnstile> \<^bold>\<forall> t \<bullet> \<guillemotleft>t\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright> \<and> \<guillemotleft>trace\<guillemotright> =\<^sub>u \<langle>\<rangle> \<Rightarrow> (setT\<cdot>\<guillemotleft>t\<guillemotright>)\<^sub>u \<notin>\<^sub>u \<guillemotleft>refs\<guillemotright> | false]\<^sub>C
  \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> StepBody tN ;; X)"
apply (unfold StepBody_def)
apply (rule CRD_mu_basic_refine)
-- \<open>TODO: Can you finalise the rest of the proof?\<close>
-- {* Subgoal 1 *}
-- {* Subgoal 2 *}
-- {* Subgoal 3 *}
-- {* Subgoal 4 *}
-- {* Subgoal 5 *}
oops

text \<open>@{const setT} is only enabled when \<open>t < tN\<close>.\<close>

lemma StepBody_muI2:
"[true \<turnstile> \<^bold>\<forall> t \<bullet> \<guillemotleft>trace\<guillemotright> =\<^sub>u \<langle>(setT\<cdot>\<guillemotleft>t\<guillemotright>)\<^sub>u\<rangle> \<Rightarrow> \<guillemotleft>t\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright> | false]\<^sub>C
  \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> StepBody tN ;; X)"
apply (unfold StepBody_def)
apply (rule CRD_mu_basic_refine)
-- {* Subgoal 1 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 2 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 3 *}
apply (rdes_calc)
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
-- {* Subgoal 5 *}
apply (rdes_calc)
apply (rel_auto)
done

lemma StepBody_muI3:
"[true \<turnstile> \<^bold>\<forall> (ct, ss) \<bullet> \<guillemotleft>ct\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright> \<and>
    \<guillemotleft>trace\<guillemotright> =\<^sub>u \<langle>(setT\<cdot>\<guillemotleft>ct\<guillemotright>)\<^sub>u, (updateSS\<cdot>\<guillemotleft>ss\<guillemotright>)\<^sub>u\<rangle> \<Rightarrow> (step\<cdot>\<guillemotleft>(ct, ss)\<guillemotright>)\<^sub>u \<notin>\<^sub>u \<guillemotleft>refs\<guillemotright>
 | false]\<^sub>C
 \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> StepBody tN ;; X)"
apply (unfold StepBody_def)
apply (rule CRD_mu_basic_refine)
-- {* Subgoal 1 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 2 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 3 *}
apply (rdes_calc)
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
-- {* Subgoal 5 *}
apply (rdes_calc)
apply (rel_simp)
apply (erule prefixE)
apply (auto)
oops

text \<open>A simpler version of \<open>Timer\<close> with fewer communications and no recursion.\<close>

definition [rdes]:
"process SimpleTimer(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(timer_state)
  Step = (
    (step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
      currentTime :=\<^sub>C min\<^sub>u(&currentTime + &stepSize, \<guillemotleft>tN\<guillemotright>)) \<box>
    (&currentTime =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u endc \<^bold>\<rightarrow> Stop)
  \<bullet> (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

lemma
"SimpleTimer(ct, hc, tN) \<sqsubseteq> step!(\<guillemotleft>ct\<guillemotright>)!(\<guillemotleft>hc\<guillemotright>) \<^bold>\<rightarrow> Skip"
apply (unfold SimpleTimer_def)
apply (unfold circus_syntax)
apply (simp add: Let_def)
apply (rule_tac SRD_refine_intro)
-- {* Subgoal 1 *}
apply (simp add: closure)
-- {* Subgoal 2 *}
apply (simp add: closure)
-- {* Subgoal 3 *}
apply (rdes_calc)
apply (rel_simp)
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
apply (erule_tac Q = "endc () \<in> ref\<^sub>v" in contrapos_pp)
apply (simp) defer
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
oops

method rdes_refine_auto =
  (rule_tac SRD_refine_intro;
    (simp add: closure rdes unrest usubst; (rdes_calc, rel_auto?)))

lemma
"ct < tN \<Longrightarrow> SimpleTimer(ct, hc, tN) \<sqsubseteq> step!(\<guillemotleft>ct\<guillemotright>)!(\<guillemotleft>hc\<guillemotright>) \<^bold>\<rightarrow> Skip"
apply (unfold SimpleTimer_def)
apply (unfold circus_syntax)
apply (simp add: Let_def)
apply (rdes_refine_auto)
done

text \<open>Simpler version of the Timer communicating only on channel @{const step}.\<close>

definition [rdes]: -- \<open>@{const Timer} with only @{const step} recursion\<close>
"process SimpleTimer2(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(timer_state)
  Step = (step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
    currentTime :=\<^sub>C min\<^sub>u(&currentTime + &stepSize, \<guillemotleft>tN\<guillemotright>)) ;; Step
  \<bullet> (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

text \<open>Let us try proving something about @{const step} events.\<close>

lemma "`peri\<^sub>R(SimpleTimer2(ct, hc, tN)) \<and> $tr =\<^sub>u $tr\<acute> \<Rightarrow> \<guillemotleft>step(ct, hc)\<guillemotright> \<notin>\<^sub>u $ref\<acute>`"
apply (rdes_calc)
apply (rel_simp)
apply (erule_tac Q = "step (ct, hc) \<in> ref\<^sub>v" in contrapos_pp; simp)
apply (subgoal_tac "currentTime\<^sub>v' = ct \<and> stepSize\<^sub>v' = hc")
-- {* Subgoal 1 *}
apply (clarsimp)
-- {* Subgoal 2 *}
apply (thin_tac "\<not> step (currentTime\<^sub>v', stepSize\<^sub>v') \<in> ref\<^sub>v")
apply (rename_tac n)
apply (case_tac "n = 0")
-- {* Subgoal 2.1 *}
apply (clarsimp)
-- {* Subgoal 2.2 *}
apply (clarify)
apply (erule contrapos_pp; simp)
-- \<open>@{command sledgehammer}\<close>
-- \<open>We need additional lemmas here to make progress..!\<close>
oops

lemma nat_one_induct:
"0 < n \<Longrightarrow> (P 1 \<Longrightarrow> (\<And>n. P n \<Longrightarrow> P (Suc n)) \<Longrightarrow> P n)"
apply (induction n)
apply (simp_all)
apply (blast)
done

lemma tr_in_relpow_grows:
"0 < n \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 (tr1::'\<epsilon> list) (tr2::'\<epsilon> list) (st1::'\<sigma>) (st2::'\<sigma>)
    (ref1::'\<epsilon> set) (ref2::'\<epsilon> set).
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr1, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr2, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<in> r \<longrightarrow>
    tr1 < tr2) \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 (tr1::'\<epsilon> list) (tr2::'\<epsilon> list) (st1::'\<sigma>) (st2::'\<sigma>)
    (ref1::'\<epsilon> set) (ref2::'\<epsilon> set).
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr1, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr2, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<in> (r ^^ n)
  \<longrightarrow> tr1 < tr2)"
apply (erule nat_one_induct)
apply (simp_all)
apply (clarsimp)
apply (case_tac y)
apply (case_tac more)
apply (case_tac morea)
apply (case_tac moreb)
apply (clarsimp)
using dual_order.strict_trans by (blast)

lemma empty_trace_neq_relpowI [rule_format]:
"0 < n \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 (tr1::'\<epsilon> list) (tr2::'\<epsilon> list) (st1::'\<sigma>) (st2::'\<sigma>)
    (ref1::'\<epsilon> set) (ref2::'\<epsilon> set).
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr1, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr2, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<in> r \<longrightarrow>
    tr1 < tr2) \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 tr st1 st2 ref1 ref2.
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<notin> (r ^^ n))"
apply (drule_tac tr_in_relpow_grows)
apply (assumption)
apply (clarsimp)
apply (subgoal_tac "tr < tr")
apply (clarsimp)
apply (blast)
done

text \<open>Let us try again with those two lemmas above.\<close>

lemma "`peri\<^sub>R(SimpleTimer2(ct, hc, tN)) \<and> $tr =\<^sub>u $tr\<acute> \<Rightarrow> \<guillemotleft>step(ct, hc)\<guillemotright> \<notin>\<^sub>u $ref\<acute>`"
apply (rdes_calc)
apply (rel_simp)
apply (erule_tac Q = "step (ct, hc) \<in> ref\<^sub>v" in contrapos_pp; simp)
apply (subgoal_tac "currentTime\<^sub>v' = ct \<and> stepSize\<^sub>v' = hc")
-- {* Subgoal 1 *}
apply (clarsimp)
-- {* Subgoal 2 *}
apply (thin_tac "\<not> step (currentTime\<^sub>v', stepSize\<^sub>v') \<in> ref\<^sub>v")
apply (rename_tac n)
apply (case_tac "n = 0")
-- {* Subgoal 2.1 *}
apply (clarsimp)
-- {* Subgoal 2.2 *}
apply (clarify)
apply (erule contrapos_pp; simp)
apply (erule empty_trace_neq_relpowI)
apply (clarsimp)
apply (simp add: Prefix_Order.strict_prefixI')
done
end


(*  Title:      HOL/Auth/Guard/Analz.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>Decomposition of Analz into two parts\<close>

theory Analz imports Extensions begin

text\<open>decomposition of \<^term>\<open>analz\<close> into two parts:
      \<^term>\<open>pparts\<close> (for pairs) and analz of \<^term>\<open>kparts\<close>\<close>

subsection\<open>messages that do not contribute to analz\<close>

inductive_set
  pparts :: "msg set => msg set"
  for H :: "msg set"
where
  Inj [intro]: "[| X \<in> H; is_MPair X |] ==> X \<in> pparts H"
| Fst [dest]: "[| \<lbrace>X,Y\<rbrace> \<in> pparts H; is_MPair X |] ==> X \<in> pparts H"
| Snd [dest]: "[| \<lbrace>X,Y\<rbrace> \<in> pparts H; is_MPair Y |] ==> Y \<in> pparts H"

subsection\<open>basic facts about \<^term>\<open>pparts\<close>\<close>

lemma pparts_is_MPair [dest]: "X \<in> pparts H \<Longrightarrow> is_MPair X"
by (erule pparts.induct, auto)

lemma Crypt_notin_pparts [iff]: "Crypt K X \<notin> pparts H"
by auto

lemma Key_notin_pparts [iff]: "Key K \<notin> pparts H"
by auto

lemma Nonce_notin_pparts [iff]: "Nonce n \<notin> pparts H"
by auto

lemma Number_notin_pparts [iff]: "Number n \<notin> pparts H"
by auto

lemma Agent_notin_pparts [iff]: "Agent A \<notin> pparts H"
by auto

lemma pparts_empty [iff]: "pparts {} = {}"
by (auto, erule pparts.induct, auto)

lemma pparts_insertI [intro]: "X \<in> pparts H \<Longrightarrow> X \<in> pparts (insert Y H)"
by (erule pparts.induct, auto)

lemma pparts_sub: "[| X \<in> pparts G; G \<subseteq> H |] ==> X \<in> pparts H"
by (erule pparts.induct, auto)

lemma pparts_insert2 [iff]: "pparts (insert X (insert Y H))
= pparts {X} Un pparts {Y} Un pparts H"
by (rule eq, (erule pparts.induct, auto)+)

lemma pparts_insert_MPair [iff]: "pparts (insert \<lbrace>X,Y\<rbrace> H)
= insert \<lbrace>X,Y\<rbrace> (pparts ({X,Y} \<union> H))"
apply (rule eq, (erule pparts.induct, auto)+)
apply (rule_tac Y=Y in pparts.Fst, auto)
apply (erule pparts.induct, auto)
by (rule_tac X=X in pparts.Snd, auto)

lemma pparts_insert_Nonce [iff]: "pparts (insert (Nonce n) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Crypt [iff]: "pparts (insert (Crypt K X) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Key [iff]: "pparts (insert (Key K) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Agent [iff]: "pparts (insert (Agent A) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Number [iff]: "pparts (insert (Number n) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Hash [iff]: "pparts (insert (Hash X) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert: "X \<in> pparts (insert Y H) \<Longrightarrow> X \<in> pparts {Y} \<union> pparts H"
by (erule pparts.induct, blast+)

lemma insert_pparts: "X \<in> pparts {Y} \<union> pparts H \<Longrightarrow> X \<in> pparts (insert Y H)"
by (safe, erule pparts.induct, auto)

lemma pparts_Un [iff]: "pparts (G \<union> H) = pparts G \<union> pparts H"
by (rule eq, erule pparts.induct, auto dest: pparts_sub)

lemma pparts_pparts [iff]: "pparts (pparts H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_eq: "pparts (insert X H) = pparts {X} Un pparts H"
by (rule_tac A=H in insert_Un, rule pparts_Un)

lemmas pparts_insert_substI = pparts_insert_eq [THEN ssubst]

lemma in_pparts: "Y \<in> pparts H \<Longrightarrow> \<exists>X. X \<in> H \<and> Y \<in> pparts {X}"
by (erule pparts.induct, auto)

subsection\<open>facts about \<^term>\<open>pparts\<close> and \<^term>\<open>parts\<close>\<close>

lemma pparts_no_Nonce [dest]: "[| X \<in> pparts {Y}; Nonce n \<notin> parts {Y} |]
==> Nonce n \<notin> parts {X}"
by (erule pparts.induct, simp_all)

subsection\<open>facts about \<^term>\<open>pparts\<close> and \<^term>\<open>analz\<close>\<close>

lemma pparts_analz: "X \<in> pparts H \<Longrightarrow> X \<in> analz H"
by (erule pparts.induct, auto)

lemma pparts_analz_sub: "[| X \<in> pparts G; G \<subseteq> H |] ==> X \<in> analz H"
by (auto dest: pparts_sub pparts_analz)

subsection\<open>messages that contribute to analz\<close>

inductive_set
  kparts :: "msg set => msg set"
  for H :: "msg set"
where
  Inj [intro]: "[| X \<in> H; not_MPair X |] ==> X \<in> kparts H"
| Fst [intro]: "[| \<lbrace>X,Y\<rbrace> \<in> pparts H; not_MPair X |] ==> X \<in> kparts H"
| Snd [intro]: "[| \<lbrace>X,Y\<rbrace> \<in> pparts H; not_MPair Y |] ==> Y \<in> kparts H"

subsection\<open>basic facts about \<^term>\<open>kparts\<close>\<close>

lemma kparts_not_MPair [dest]: "X \<in> kparts H \<Longrightarrow> not_MPair X"
by (erule kparts.induct, auto)

lemma kparts_empty [iff]: "kparts {} = {}"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insertI [intro]: "X \<in> kparts H \<Longrightarrow> X \<in> kparts (insert Y H)"
by (erule kparts.induct, auto dest: pparts_insertI)

lemma kparts_insert2 [iff]: "kparts (insert X (insert Y H))
= kparts {X} \<union> kparts {Y} \<union> kparts H"
by (rule eq, (erule kparts.induct, auto)+)

lemma kparts_insert_MPair [iff]: "kparts (insert \<lbrace>X,Y\<rbrace> H)
= kparts ({X,Y} \<union> H)"
by (rule eq, (erule kparts.induct, auto)+)

lemma kparts_insert_Nonce [iff]: "kparts (insert (Nonce n) H)
= insert (Nonce n) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Crypt [iff]: "kparts (insert (Crypt K X) H)
= insert (Crypt K X) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Key [iff]: "kparts (insert (Key K) H)
= insert (Key K) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Agent [iff]: "kparts (insert (Agent A) H)
= insert (Agent A) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Number [iff]: "kparts (insert (Number n) H)
= insert (Number n) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Hash [iff]: "kparts (insert (Hash X) H)
= insert (Hash X) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert: "X \<in> kparts (insert X H) \<Longrightarrow> X \<in> kparts {X} \<union> kparts H"
by (erule kparts.induct, (blast dest: pparts_insert)+)

lemma kparts_insert_fst [rule_format,dest]: "X \<in> kparts (insert Z H) \<Longrightarrow>
X \<notin> kparts H \<longrightarrow> X \<in> kparts {Z}"
by (erule kparts.induct, (blast dest: pparts_insert)+)

lemma kparts_sub: "[| X \<in> kparts G; G \<subseteq> H |] ==> X \<in> kparts H"
by (erule kparts.induct, auto dest: pparts_sub)

lemma kparts_Un [iff]: "kparts (G \<union> H) = kparts G \<union> kparts H"
by (rule eq, erule kparts.induct, auto dest: kparts_sub)

lemma pparts_kparts [iff]: "pparts (kparts H) = {}"
by (rule eq, erule pparts.induct, auto)

lemma kparts_kparts [iff]: "kparts (kparts H) = kparts H"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_eq: "kparts (insert X H) = kparts {X} \<union> kparts H"
by (rule_tac A=H in insert_Un, rule kparts_Un)

lemmas kparts_insert_substI = kparts_insert_eq [THEN ssubst]

lemma in_kparts: "Y \<in> kparts H \<Longrightarrow> \<exists>X. X \<in> H \<and> Y \<in> kparts {X}"
by (erule kparts.induct, auto dest: in_pparts)

lemma kparts_has_no_pair [iff]: "has_no_pair (kparts H)"
by auto

subsection\<open>facts about \<^term>\<open>kparts\<close> and \<^term>\<open>parts\<close>\<close>

lemma kparts_no_Nonce [dest]: "[| X \<in> kparts {Y}; Nonce n \<notin> parts {Y} |]
==> Nonce n \<notin> parts {X}"
by (erule kparts.induct, auto)

lemma kparts_parts: "X \<in> kparts H \<Longrightarrow> X \<in> parts H"
by (erule kparts.induct, auto dest: pparts_analz)

lemma parts_kparts: "X \<in> parts (kparts H) \<Longrightarrow> X \<in> parts H"
by (erule parts.induct, auto dest: kparts_parts
intro: parts.Fst parts.Snd parts.Body)

lemma Crypt_kparts_Nonce_parts [dest]: "[| Crypt K Y \<in> kparts {Z};
Nonce n \<in> parts {Y} |] ==> Nonce n \<in> parts {Z}"
by auto

subsection\<open>facts about \<^term>\<open>kparts\<close> and \<^term>\<open>analz\<close>\<close>

lemma kparts_analz: "X \<in> kparts H \<Longrightarrow> X \<in> analz H"
by (erule kparts.induct, auto dest: pparts_analz)

lemma kparts_analz_sub: "[| X \<in> kparts G; G \<subseteq> H |] ==> X \<in> analz H"
by (erule kparts.induct, auto dest: pparts_analz_sub)

lemma analz_kparts [rule_format,dest]: "X \<in> analz H \<Longrightarrow>
Y \<in> kparts {X} \<longrightarrow> Y \<in> analz H"
by (erule analz.induct, auto dest: kparts_analz_sub)

lemma analz_kparts_analz: "X \<in> analz (kparts H) \<Longrightarrow> X \<in> analz H"
by (erule analz.induct, auto dest: kparts_analz)

lemma analz_kparts_insert: "X \<in> analz (kparts (insert Z H)) \<Longrightarrow> X \<in> analz (kparts {Z} \<union> kparts H)"
by (rule analz_sub, auto)

lemma Nonce_kparts_synth [rule_format]: "Y \<in> synth (analz G)
\<Longrightarrow> Nonce n \<in> kparts {Y} \<longrightarrow> Nonce n \<in> analz G"
by (erule synth.induct, auto)

lemma kparts_insert_synth: "[| Y \<in> parts (insert X G); X \<in> synth (analz G);
Nonce n \<in> kparts {Y}; Nonce n \<notin> analz G |] ==> Y \<in> parts G"
apply (drule parts_insert_substD, clarify)
apply (drule in_sub, drule_tac X=Y in parts_sub, simp)
apply (auto dest: Nonce_kparts_synth)
done

lemma Crypt_insert_synth:
  "[| Crypt K Y \<in> parts (insert X G); X \<in> synth (analz G); Nonce n \<in> kparts {Y}; Nonce n \<notin> analz G |]
   ==> Crypt K Y \<in> parts G"
by (metis Fake_parts_insert_in_Un Nonce_kparts_synth UnE analz_conj_parts synth_simps(5))

subsection\<open>analz is pparts + analz of kparts\<close>

lemma analz_pparts_kparts: "X \<in> analz H \<Longrightarrow> X \<in> pparts H \<or> X \<in> analz (kparts H)"
by (erule analz.induct, auto)

lemma analz_pparts_kparts_eq: "analz H = pparts H Un analz (kparts H)"
by (rule eq, auto dest: analz_pparts_kparts pparts_analz analz_kparts_analz)

lemmas analz_pparts_kparts_substI = analz_pparts_kparts_eq [THEN ssubst]
lemmas analz_pparts_kparts_substD = analz_pparts_kparts_eq [THEN sym, THEN ssubst]

end


(*by Lammich*)
section \<open>Imperative Interface\<close>
theory VEBT_Intf_Imperative
  imports
  VEBT_Definitions
  VEBT_Uniqueness
  VEBT_Member
  VEBT_Insert VEBT_InsertCorrectness
  VEBT_MinMax
  VEBT_Pred VEBT_Succ
  VEBT_Delete VEBT_DeleteCorrectness
  VEBT_Bounds
  VEBT_DeleteBounds
  VEBT_Space
  VEBT_Intf_Functional
  VEBT_List_Assn
  VEBT_BuildupMemImp
  VEBT_SuccPredImperative
  VEBT_DelImperative
begin

  subsection \<open>Code Export\<close>

  context begin
    interpretation VEBT_internal .

    lemmas [code] = replicatei.simps vebt_memberi.simps highi_def lowi_def vebt_inserti.simps
      minNulli.simps vebt_succi.simps vebt_predi.simps vebt_deletei.simps

      greater.simps

  end

  export_code
    vebt_buildupi
    vebt_memberi
    vebt_inserti
    vebt_maxti vebt_minti
    vebt_predi vebt_succi
    vebt_deletei

   checking SML_imp

  subsection \<open>Interface\<close>

definition vebt_assn::"nat \<Rightarrow> nat set \<Rightarrow> VEBTi \<Rightarrow> assn" where
"vebt_assn n s ti \<equiv> \<exists>\<^sub>A t. vebt_assn_raw t ti * \<up>(s = set_vebt t \<and> invar_vebt t n)"

subsubsection \<open>Buildup\<close>

context begin
  interpretation VEBT_internal .

  interpretation vebt_inst for n .

lemma vebt_buildupi_rule_basic[sep_heap_rules]: "n > 0 \<Longrightarrow> <emp> vebt_buildupi n <\<lambda> r. vebt_assn n {} r >"
  unfolding vebt_assn_def
  apply(rule  post_exI_rule[where x = "vebt_buildup n"])
  using builupicorr[of n] invar_vebt_buildup[of n] set_vebt_buildup[of n]
  apply simp
  done

lemma vebt_buildupi_rule: "<\<up> (n > 0)> vebt_buildupi  n <\<lambda> r. vebt_assn n {} r > T[10 * 2^n]"
  unfolding vebt_assn_def htt_def
  apply rule
  apply(rule  post_exI_rule[where x = "vebt_buildup n"])
  using vebt_buildupi_rule[of n] invar_vebt_buildup[of  n] set_vebt_buildup[of n]
  unfolding htt_def
   apply simp
  using TBOUND_buildupi[of n] unfolding TBOUND_def
  apply simp
  done

subsubsection \<open>Member\<close>
lemma vebt_memberi_rule: "<vebt_assn n s ti> vebt_memberi ti x <\<lambda> r. vebt_assn n s ti *  \<up>(r = (x \<in> s))>T[5 + 5 * (nat \<lceil>lb n \<rceil>)]"
  unfolding vebt_assn_def
  apply(rule norm_pre_ex_rule_htt)
  apply(clarsimp simp: norm_pre_pure_iff_htt)
  apply(rule htt_cons_rule[OF htt_vebt_memberi_invar_vebt])
     apply assumption
    apply simp
   apply (sep_auto simp: member_correct)
  apply simp
  done

subsubsection \<open>Insert\<close>
lemma vebt_inserti_rule: "x < 2^n \<Longrightarrow> <vebt_assn n s ti> vebt_inserti ti x <\<lambda> r. vebt_assn n (s \<union> {x}) r >T[13 + 13 * (nat \<lceil>lb n \<rceil>)]"
  apply(sep_auto simp: norm_pre_pure_iff_htt)
  unfolding vebt_assn_def
  apply(rule norm_pre_ex_rule_htt)
  apply(clarsimp simp: norm_pre_pure_iff_htt)
  apply(rule htt_cons_rule[OF htt_vebt_inserti_invar_vebt])
     apply assumption
    apply simp
   apply sep_auto
      apply (auto simp add: insert_correct)
     apply (simp add: valid_insert_both_member_options_add set_vebt_def)
    apply (metis UnCI insert_correct)
   apply (metis UnE insert_correct singletonD)
  using valid_pres_insert by presburger

subsubsection \<open>Maximum\<close>
lemma vebt_maxti_rule: "<vebt_assn n s ti> vebt_maxti ti <\<lambda> r. vebt_assn n s ti *  \<up>( r = Some y \<longleftrightarrow> max_in_set s y)>T[1]"
  unfolding vebt_assn_def
  apply(rule norm_pre_ex_rule_htt)
  apply(clarsimp simp: norm_pre_pure_iff_htt)
  apply(rule htt_cons_rule[OF vebt_maxti_hT])
  apply(rule ent_refl)
  apply (sep_auto simp: set_vebt_maxt)
  by simp

subsubsection \<open>Minimum\<close>
lemma vebt_minti_rule: "<vebt_assn n s ti> vebt_minti ti <\<lambda> r. vebt_assn n s ti *  \<up>( r = Some y \<longleftrightarrow> min_in_set s y)>T[1]"
  unfolding vebt_assn_def
  apply(rule norm_pre_ex_rule_htt)
  apply(clarsimp simp: norm_pre_pure_iff_htt)
  apply(rule htt_cons_rule[OF vebt_minti_hT])
  apply(rule ent_refl)
  apply (sep_auto simp: set_vebt_mint)
  by auto

subsubsection \<open>Successor\<close>
lemma vebt_succi_rule: "<vebt_assn n s ti> vebt_succi ti x <\<lambda> r. vebt_assn n s ti *  \<up>( r = Some y \<longleftrightarrow> is_succ_in_set s x y)>T[7 + 7 * (nat \<lceil>lb n \<rceil>)]"
  unfolding vebt_assn_def
  apply(rule norm_pre_ex_rule_htt)
  apply(clarsimp simp: norm_pre_pure_iff_htt)
  apply(rule htt_cons_rule[OF htt_vebt_succi])
  apply assumption
  apply simp
  apply (sep_auto simp: set_vebt_succ)
  apply simp
  done

subsubsection \<open>Predecessor\<close>
lemma vebt_predi_rule: "<vebt_assn n s ti> vebt_predi ti x <\<lambda> r. vebt_assn n s ti *  \<up>( r = Some y \<longleftrightarrow> is_pred_in_set s x y)>T[7 + 7 * (nat \<lceil>lb n \<rceil>)]"
  unfolding vebt_assn_def
  apply(rule norm_pre_ex_rule_htt)
  apply(clarsimp simp: norm_pre_pure_iff_htt)
  apply(rule htt_cons_rule[OF htt_vebt_predi])
  apply assumption
  apply simp
  apply (sep_auto simp: set_vebt_pred)
  apply simp
  done

subsubsection \<open>Delete\<close>
lemma vebt_deletei_rule: "<vebt_assn n s ti > vebt_deletei ti x <\<lambda> r. vebt_assn n (s - {x}) r >T[20 + 20 * (nat \<lceil>lb n \<rceil>)]"
  unfolding vebt_assn_def
  apply(rule norm_pre_ex_rule_htt)
  apply(clarsimp simp: norm_pre_pure_iff_htt)
  apply(rule htt_cons_rule[OF htt_vebt_deletei])
  apply assumption
  apply simp
  apply sep_auto
   apply (auto simp add: set_vebt_delete invar_vebt_delete)
  done

subsection \<open>Setup of VCG\<close>
lemmas vebt_heap_rules[THEN htt_htD,sep_heap_rules] =
  vebt_buildupi_rule
  vebt_memberi_rule
  vebt_inserti_rule
  vebt_maxti_rule
  vebt_minti_rule
  vebt_succi_rule
  vebt_predi_rule
  vebt_deletei_rule

end
end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |

            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Domain_T_cms
imports Domain_T CSP.RS
begin

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

         1.
         2.
         3.
         4.

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

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(**********************************************************
           Definitions (Restriction in domT)
 **********************************************************)

(*
instance domT :: (type) ms0
by (intro_classes)
*)

definition
  restT      :: "'a domT => nat => 'a trace set" ("_ restT _" [84,900] 84)
  where
  restT_def  : "T restT n == {s. s :t T & (lengtht s) <= n}"

(* ("_ restT _" [55,56] 55) in Isabelle 2005 *)

definition
  LimitT     :: "'a domT infinite_seq => 'a trace set"
  where
  LimitT_def : "LimitT Ts == {s. s :t Ts (lengtht s)}"

definition
  Limit_domT :: "'a domT infinite_seq => 'a domT"
  where
  Limit_domT_def    : "Limit_domT Ts    == Abs_domT (LimitT Ts)"

(* isabelle 2009-2 *)

instantiation domT :: (type) rs0
begin

definition
  rest_domT_def : "T .|. n == Abs_domT (T restT n)"

  instance ..

end

(* isabelle 2009-1
defs (overloaded)
  rest_domT_def : "T .|. n == Abs_domT (T restT n)"
*)

(**********************************************************
              Lemmas (Restriction in Dom_T)
 **********************************************************)

(*** restT_def in domT ***)

lemma restT_in[simp] : "T restT n : domT"
apply (simp add: restT_def)
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI, simp)

apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (elim conjE exE)

apply (rule conjI)
apply (rule memT_prefix_closed, simp_all)

apply (subgoal_tac "lengtht s <= lengtht t", simp)
apply (rule length_of_prefix)
apply (simp)
done

(*** restT in domT ***)

lemmas restT_def_in = restT_in[simplified memT_def restT_def]

(*********************************************************
                     .|. on dom_T
 *********************************************************)

lemma rest_domT_iff: "T .|. n = {s. s :t T & lengtht s <= n}t"
apply (simp add: rest_domT_def)
apply (simp add: restT_in[simplified restT_def] Abs_domT_inject)
apply (simp add: restT_def)
done

lemma in_rest_domT: "s :t T .|. n = (s :t T & lengtht s <= n)"
apply (simp add: memT_def rest_domT_def)
apply (simp add: Abs_domT_inverse)
apply (simp add: memT_def restT_def)
done

lemma rest_domT_eq_iff:
   "(T .|. n = S .|. m) =
    (ALL s. (s :t T & lengtht s <= n) = (s :t S & lengtht s <= m))"
apply (simp add: rest_domT_def Abs_domT_inject)
apply (simp add: restT_def)
by (auto)

(*********************************************************
                     Dom_T --> RS
 *********************************************************)

(*******************************
        zero_eq_rs_domT
 *******************************)

(*** restT 0 ***)

lemma zero_domT: "T restT 0 = {<>}"
apply (simp add: restT_def)
apply (rule order_antisym)

apply (rule subsetI)
apply (simp)
apply (erule conjE)
apply (simp add: lengtht_zero)
by (simp)

(*** zero_eq_rs_domT ***)

lemma zero_rs_domT: "T .|. 0 = {<>}t"
apply (simp add: rest_domT_def)
apply (simp add: Abs_domT_inject)
apply (simp add: zero_domT)
done

lemma zero_eq_rs_domT: "(T::'a domT) .|. 0 = S .|. 0"
apply (simp add: zero_rs_domT)
done

(*******************************
         min_rs_domT
 *******************************)

lemma min_rs_domT: "((T::'a domT) .|. m) .|. n = T .|. (min m n)"
apply (simp add: rest_domT_def)
apply (simp add: Abs_domT_inject)

apply (simp add: restT_def memT_def)
apply (simp add: restT_in[simplified memT_def restT_def]
                 Abs_domT_inverse)
done

(*******************************
         diff_rs_domT
 *******************************)

(*** contra = ***)

lemma contra_diff_rs_domT:
  "(ALL n. (T::'a domT) .|. n = S .|. n) ==> T = S"
apply (simp add: rest_domT_eq_iff)
apply (rule order_antisym)
by (auto)

(*** diff_rs_domT ***)

lemma diff_rs_domT:
  "(T::'a domT) ~= S ==> (EX n. T .|. n ~= S .|. n)"
apply (erule contrapos_pp)
apply (simp)
apply (rule contra_diff_rs_domT, simp)
done

(***************************************************************
                       domT ==> RS
 ***************************************************************)

instance domT :: (type) rs
apply (intro_classes)
apply (simp add: zero_eq_rs_domT)
apply (simp add: min_rs_domT)
apply (simp add: diff_rs_domT)
done

(************************************************************
                        domT ==> MS
 ************************************************************)

instantiation domT :: (type) ms0
begin

definition
  domT_distance_def:
     "distance (TT::('a domT * 'a domT)) = distance_rs TT"
  instance ..
end

instance domT :: (type) ms
apply (intro_classes)
apply (simp_all add: domT_distance_def)
apply (simp add: diagonal_rs)
apply (simp add: symmetry_rs)
apply (simp add: triangle_inequality_rs)
done

(************************************************************
                 i.e.  domT ==> MS & RS
 ************************************************************)

instance domT :: (type) ms_rs
apply (intro_classes)
apply (simp add: domT_distance_def)
done

(***********************************************************
                      lemmas (Limit)
 ***********************************************************)

(*** normal_seq lemma ***)

lemma normal_seq_domT:
  "[| normal Ts ; lengtht s <= n |]
   ==> (s :t Ts (lengtht s)) = (s :t Ts n)"
apply (simp add: normal_def)
apply (drule_tac x="lengtht s" in spec)
apply (drule_tac x="n" in spec)
apply (simp add: min_is)

apply (simp add: to_distance_rs)
apply (simp add: distance_rs_le_1[THEN sym])
apply (simp add: rest_domT_eq_iff)
apply (drule_tac x="s" in spec)
by (simp)

lemma normal_seq_domT_only_if:
  "[| normal Ts ; lengtht s <= n ; s :t Ts (lengtht s) |]
   ==> s :t Ts n"
by (simp add: normal_seq_domT)

lemma normal_seq_domT_if:
  "[| normal Ts ; lengtht s <= n ; s :t Ts n |]
   ==>  s :t Ts (lengtht s)"
by (simp add: normal_seq_domT)

(*** LimitT_def in domT ***)

lemma LimitT_in[simp]:
  "normal (Ts::'a domT infinite_seq) ==> LimitT Ts : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)

apply (simp add: LimitT_def)
apply (rule_tac x="<>" in exI)
apply (simp)

apply (simp add: prefix_closed_def LimitT_def)
apply (intro allI impI)
apply (elim conjE exE)

apply (subgoal_tac "lengtht s <= lengtht t")
apply (rule normal_seq_domT_if)
apply (simp_all)
apply (rule memT_prefix_closed, simp_all)
apply (rule length_of_prefix)
apply (simp)
done

(*** :t Limit_domT ***)

lemma Limit_domT_memT:
  "normal (Ts::'a domT infinite_seq)
   ==> (s :t Limit_domT Ts) = (s :t Ts (lengtht s))"
apply (simp add: memT_def)
apply (simp add: Limit_domT_def)
apply (simp add: Abs_domT_inverse)
apply (simp add: LimitT_def memT_def)
done

(*** Limit_domT lemma ***)

lemma Limit_domT_Limit_lm:
  "normal (Ts::'a domT infinite_seq)
   ==> (ALL n. (Limit_domT Ts) .|. n = (Ts n) .|. n)"
apply (intro allI)
apply (simp add: rest_domT_eq_iff)
apply (simp add: Limit_domT_memT)
by (auto simp add: normal_seq_domT)

(*** (normal) Ts converges to (Limit_domT Ts) ***)

lemma Limit_domT_Limit:
  "normal (Ts::'a domT infinite_seq) ==> Ts convergeTo (Limit_domT Ts)"
by (simp add: to_distance_rs Limit_domT_Limit_lm rest_Limit)

(*** (cauchy) Ts converges to (Limit_domT NF Ts) ***)

lemma cauchy_Limit_domT_Limit:
  "cauchy (Ts::'a domT infinite_seq) ==> Ts convergeTo (Limit_domT (NF Ts))"
apply (simp add: normal_form_seq_same_Limit)
apply (simp add: Limit_domT_Limit normal_form_seq_normal)
done

(***************************************
     Dom_T --> Complete Metric Space
 ***************************************)

lemma domT_cms:
  "cauchy (Ts::'a domT infinite_seq) ==> (EX T. Ts convergeTo T)"
apply (rule_tac x="Limit_domT (NF Ts)" in exI)
by (simp add: cauchy_Limit_domT_Limit)

(************************************************************
                   domT ==> CMS and RS
 ************************************************************)

instance domT :: (type) cms
apply (intro_classes)
by (simp add: domT_cms)

instance domT :: (type) cms_rs
by (intro_classes)

(*** (normal) Limit Ts = Limit_domT Ts ***)

lemma Limit_domT_Limit_eq:
  "normal (Ts::'a domT infinite_seq) ==> Limit Ts = Limit_domT Ts"
apply (insert unique_convergence[of Ts "Limit Ts" "Limit_domT Ts"])
by (simp add: Limit_domT_Limit Limit_is normal_cauchy)

(*----------------------------------------------------------*
 |                                                          |
 |                       cms rs order                       |
 |                                                          |
 *----------------------------------------------------------*)

instance domT :: (type) ms_rs_order0
apply (intro_classes)
done

instance domT :: (type) ms_rs_order
apply (intro_classes)
apply (intro allI)
apply (rule iffI)
apply (simp add: rest_domT_def)
apply (simp add: subdomT_def)
apply (simp add: Abs_domT_inverse)
apply (fold subdomT_def)
apply (rule)
apply (drule_tac x="lengtht t" in spec)
apply (simp add: restT_def)
apply (force)

apply (intro allI)
apply (simp add: rest_domT_def)
apply (simp add: subdomT_def)
apply (simp add: Abs_domT_inverse)
apply (fold subdomT_def)
apply (rule)
apply (simp add: restT_def)
apply (force)
done

instance domT :: (type) cms_rs_order
by (intro_classes)

(*----------------------------------------------------------*
 |                                                          |
 |  i.e. lemma "continuous_rs (Ref_fun (S::'a domT))"       |
 |       by (simp add: continuous_rs_Ref_fun)               |
 |                                                          |
 |  see RS.thy                                              |
 |                                                          |
 *----------------------------------------------------------*)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Early_Bisim_Subst_SC
  imports Strong_Early_Bisim Strong_Late_Bisim_Subst_SC Strong_Early_Late_Comp
begin

(******** Structural Congruence **********)

(******** The \<nu>-operator *****************)

lemma resComm:
  fixes P :: pi

  shows "<\<nu>a><\<nu>b>P \<sim>\<^sup>s\<^sub>e <\<nu>b><\<nu>a>P"
proof -
  have "<\<nu>a><\<nu>b>P \<sim>\<^sup>s\<^sub>l <\<nu>b><\<nu>a>P"
    by(rule Strong_Late_Bisim_Subst_SC.resComm)
  thus ?thesis by(rule lateEarlyCong)
qed

(******** The Match *********)

lemma matchId:
  fixes a :: name
  and   P :: pi

  shows "[a\<frown>a]P \<sim>\<^sup>s\<^sub>e P"
proof -
  have "[a\<frown>a]P \<sim>\<^sup>s\<^sub>l P" by(rule Strong_Late_Bisim_Subst_SC.matchId)
  thus ?thesis by(rule lateEarlyCong)
qed

(******** Mismatch *********)

(******** The +-operator *********)

lemma sumSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<oplus> Q \<sim>\<^sup>s\<^sub>e Q \<oplus> P"
proof -
  have "P \<oplus> Q \<sim>\<^sup>s\<^sub>l Q \<oplus> P" by(rule Strong_Late_Bisim_Subst_SC.sumSym)
  thus ?thesis by(rule lateEarlyCong)
qed

(******** The |-operator *********)

lemma parZero:
  fixes P :: pi

  shows "P \<parallel> \<zero> \<sim>\<^sup>s\<^sub>e P"
proof -
  have "P \<parallel> \<zero> \<sim>\<^sup>s\<^sub>l P" by(rule Strong_Late_Bisim_Subst_SC.parZero)
  thus ?thesis by(rule lateEarlyCong)
qed

lemma parSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<parallel> Q \<sim>\<^sup>s\<^sub>e Q \<parallel> P"
proof -
  have "P \<parallel> Q \<sim>\<^sup>s\<^sub>l Q \<parallel> P" by(rule Strong_Late_Bisim_Subst_SC.parSym)
  thus ?thesis by(rule lateEarlyCong)
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<parallel> Q) \<sim>\<^sup>s\<^sub>e P \<parallel> <\<nu>x>Q"
proof -
  from `x \<sharp> P` have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sup>s\<^sub>l P \<parallel> <\<nu>x>Q" by(rule Strong_Late_Bisim_Subst_SC.scopeExtPar)
  thus ?thesis by(rule lateEarlyCong)
qed

lemma scopeExtPar':
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes xFreshQ: "x \<sharp> Q"

  shows "<\<nu>x>(P \<parallel> Q) \<sim>\<^sup>s\<^sub>e (<\<nu>x>P) \<parallel> Q"
proof -
  from `x \<sharp> Q` have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sup>s\<^sub>l (<\<nu>x>P) \<parallel> Q" by(rule Strong_Late_Bisim_Subst_SC.scopeExtPar')
  thus ?thesis by(rule lateEarlyCong)
qed

  shows "(P \<parallel> Q) \<parallel> R \<sim>\<^sup>s\<^sub>e P \<parallel> (Q \<parallel> R)"
proof -
  have "(P \<parallel> Q) \<parallel> R \<sim>\<^sup>s\<^sub>l P \<parallel> (Q \<parallel> R)" by(rule Strong_Late_Bisim_Subst_SC.parAssoc)
  thus ?thesis by(rule lateEarlyCong)
qed

lemma freshRes:
  fixes P :: pi
  and   a :: name

  assumes a \<sharp> P"

  shows "<\<nu>a>P \<sim>\<^sup>s\<^sub>e P"
proof -
  from a \<sharp> P` have "<\<nu>a>P \<sim>\<^sup>s\<^sub>l P" by(rule Strong_Late_Bisim_Subst_SC.freshRes)
  thus ?thesis by(rule lateEarlyCong)
qed

lemma scopeExtSum:
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<oplus> Q) \<sim>\<^sup>s\<^sub>e P \<oplus> <\<nu>x>Q"
proof -
  from `x \<sharp> P` have "<\<nu>x>(P \<oplus> Q) \<sim>\<^sup>s\<^sub>l P \<oplus> <\<nu>x>Q" by(rule Strong_Late_Bisim_Subst_SC.scopeExtSum)
  thus ?thesis by(rule lateEarlyCong)
qed

lemma bangSC:
  fixes P

  shows "!P \<sim>\<^sup>s\<^sub>e P \<parallel> !P"
proof -
  have "!P \<sim>\<^sup>s\<^sub>l P \<parallel> !P" by(rule Strong_Late_Bisim_Subst_SC.bangSC)
  thus ?thesis by(rule lateEarlyCong)
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory BinarySearch
imports "AutoCorres.AutoCorres" "../../DataStructures"
begin

external_file "binary_search.c"
install_C_file "binary_search.c"

autocorres [ts_rules = nondet, unsigned_word_abs=binary_search] "binary_search.c"

context binary_search begin

lemma uint_of_nat:
    "uint (of_nat x :: 'a::len word) = (int x) mod 2^ len_of TYPE('a)"
  apply (clarsimp simp only: uint_nat unat_of_nat)
  apply (metis of_nat_numeral semiring_1_class.of_nat_power zmod_int)
  done

lemma ptr_add_uint_of_nat [simp]:
    "p +\<^sub>p uint (of_nat x :: addr) = p +\<^sub>p int x"
  apply (subst uint_of_nat)
  apply (unfold CTypesDefs.ptr_add_def)
  apply (metis (hide_lams, no_types) uint_of_nat of_int_of_nat_eq of_int_uint)
  done

lemmas [simp] = sint_ucast_eq_uint is_up is_down

primrec
  array :: "lifted_globals \<Rightarrow> word32 ptr \<Rightarrow> word32 list \<Rightarrow> bool"
where
    "array s p [] = True"
  | "array s p (x#xs) = ((heap_w32 s p = x) \<and> (is_valid_w32 s p) \<and> array s (p +\<^sub>p 1) xs)"

definition
  "is_array s p n \<equiv> \<exists>l. array s p l \<and> length l = n"

definition
  "the_array s p n \<equiv> (THE l. length l = n \<and> array s p l)"

lemma array_unique:
    "\<lbrakk> array s p l; array s p l'; length l = length l' \<rbrakk> \<Longrightarrow> l = l'"
  apply (induct l arbitrary: l' p)
   apply clarsimp
  apply (case_tac l')
   apply clarsimp
   apply clarsimp
  done

lemma array_concat [simp]:
  "array s p (a @ b) = (array s p a \<and> array s (p +\<^sub>p int (length a)) b)"
  apply (induct a arbitrary: p)
   apply clarsimp
  apply clarsimp
  apply atomize
  apply (erule_tac x="p +\<^sub>p 1" in allE)
  apply (clarsimp simp: CTypesDefs.ptr_add_def field_simps)
  done

lemma array_is_array: "array s p a \<Longrightarrow> is_array s p (length a)"
  apply (clarsimp simp: is_array_def)
  apply force
  done

lemma array_the_array: "\<lbrakk> array s p a; length a = n \<rbrakk> \<Longrightarrow> the_array s p n = a"
  apply (simp add: the_array_def)
  apply (metis (lifting, mono_tags) array_unique the_equality)
  done

lemma length_the_array [simp]: "is_array s p n \<Longrightarrow> length (the_array s p n) = n"
  apply (induct n arbitrary: n)
   apply (clarsimp simp: is_array_def)
   apply (metis array_the_array)
  apply (clarsimp simp: is_array_def)
  done

lemma the_array_Suc:
  "\<lbrakk> is_array s p n; n > 0 \<rbrakk> \<Longrightarrow> the_array s p n = (heap_w32 s p) # (the_array s (p +\<^sub>p 1) (n - 1))"
  apply (clarsimp simp: is_array_def)
  apply (case_tac l)
   apply clarsimp
  apply clarsimp
  apply (metis One_nat_def Suc_eq_plus1 list.size(4) array.simps(2) array_the_array)
  done

lemma the_array_0 [simp]:
  "the_array s p 0 = []"
  by (metis list.size(3) array.simps(1) array_the_array)

lemma is_array_0 [simp]:
  "is_array s p 0"
  apply (clarsimp simp: is_array_def)
  done

lemma is_array_Suc:
  "\<lbrakk> is_array s p n; is_valid_w32 s (p +\<^sub>p int n) \<rbrakk> \<Longrightarrow>
      is_array s p (Suc n)"
  apply (clarsimp simp: is_array_def)
  apply (rule_tac x="l @ [heap_w32 s (p +\<^sub>p int (length l))]" in exI)
  apply clarsimp
  done

lemma array_expand: "array s p n \<Longrightarrow> array s (p +\<^sub>p 1) (tl n)"
  apply (case_tac n)
   apply clarsimp
  apply clarsimp
  done

lemma array_Ex:
  "\<lbrakk> array s p n; 0 \<le> i; i < int (length n) \<rbrakk> \<Longrightarrow> is_valid_w32 s (p +\<^sub>p i)"
  apply (induct n arbitrary: p i)
   apply clarsimp
  apply clarsimp
  apply atomize
  apply (erule_tac x="p +\<^sub>p 1" in allE)
  apply (erule_tac x="i - 1" in allE)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  done

lemma sorted_index_lt:
  "\<lbrakk> sorted xs; unat (xs ! m) < v; n \<le> m; m < length xs \<rbrakk> \<Longrightarrow>  unat (xs ! n) < v"
  by (meson le_less_trans sorted_nth_mono unat_arith_simps(1))

lemma sorted_index_gt:
    "\<lbrakk> sorted xs; v < unat (xs ! m); m \<le> n; n < length xs \<rbrakk> \<Longrightarrow>  v < unat (xs ! n)"
  by (metis le_less_linear le_less_trans less_irrefl sorted_nth_mono word_less_nat_alt)

lemma array_access_to_list_access:
    "\<lbrakk> array s p data; n < length data \<rbrakk> \<Longrightarrow> (heap_w32 s (p +\<^sub>p int n)) = data ! n"
  apply (induct data arbitrary: n p)
   apply clarsimp
  apply (case_tac "n = 0")
   apply clarsimp
  apply atomize
  apply (erule_tac x="n - 1" in allE)
  apply (erule_tac x="p +\<^sub>p 1" in allE)
  apply (erule impE)
   apply clarsimp
  apply (erule impE)
   apply clarsimp
   apply arith
  apply (clarsimp simp: field_simps CTypesDefs.ptr_add_def)
  done

lemma binary_search_correct:
  "\<lbrace> \<lambda>s. array s arr data \<and> length data < 1000000000 \<and> n = length data \<and> sorted data \<rbrace>
           binary_search' arr n v
        \<lbrace> \<lambda>r s. r \<noteq> 0 \<longleftrightarrow> v \<in> unat ` set data \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (unfold binary_search'_def)
  apply (case_tac "n = 0")
   apply (subst whileLoop_add_inv [where I="\<lambda>(f, l, r) _. f = 0 \<and> l = 0 \<and> r = 0" and M="\<lambda>_. 0"])
   apply ((wp | clarsimp)+)[1]
  apply (subst whileLoop_add_inv [where
        I="\<lambda>(found, l, r) s. array s arr data  \<and> (r \<le> n)
                \<and> (\<forall>i. i < l \<longrightarrow> i < n \<longrightarrow> unat (data ! i) <  v)
                \<and> (\<forall>i. i \<ge> r \<longrightarrow> i < n \<longrightarrow> v < unat (data ! i))
                \<and> (found \<noteq> 0 \<longrightarrow> v \<in> unat ` set data)"
          and  M="\<lambda>((found, l, r), s). if found = 0 then 1 + (r - l) else 0" ])
  apply wp
     apply (clarsimp split del: if_split cong: if_cong
       simp: field_simps array_access_to_list_access array_Ex UINT_MAX_def)
    apply (subgoal_tac "aa \<le> ((aa + b)  div 2) \<and> ((aa + b) div 2) \<le> b")
     apply (case_tac "unat (data ! ((aa + b) div 2)) = v")
      apply (clarsimp simp: UINT_MAX_def INT_MAX_def)
     apply (case_tac "unat (data ! ((aa + b) div 2)) < v")
      apply (auto elim: sorted_index_lt simp: UINT_MAX_def INT_MAX_def cong: if_cong)[1]
     apply (subgoal_tac "unat (data ! ((aa + b) div 2)) > v")
      apply (clarsimp simp: UINT_MAX_def INT_MAX_def)
      apply (fastforce elim: sorted_index_gt)
     apply force
    apply force
   apply (clarsimp split del: if_split simp: field_simps cong: if_cong)
   apply rule
    apply clarsimp
   apply clarsimp
   apply (metis (no_types) in_set_conv_nth le_less_trans neq_iff not_less)
  apply clarsimp
  done

end

end