theory mfspace
  imports mdom_mran
begin

context Function_Model begin

definition mfspace' :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  where "mfspace' x y \<equiv>
    <set, { <func, f> | f \<in> (snd x \<ominus> func) \<midarrow>p\<rightarrow> (snd y \<ominus> func) }>"

definition mfspace :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  where "mfspace x y \<equiv> if x : mSet \<and> y : mSet
                         then mfspace' x y
                         else Function_Model_mdefault"

lemma mfspace_eq :
  assumes x : "x : mSet" and y : "y : mSet"
    shows "mfspace x y \<equiv>
    <set, { <func, f> | f \<in> (snd x \<ominus> func) \<midarrow>p\<rightarrow> (snd y \<ominus> func) }>"
  unfolding mfspace_def mfspace'_def
  using assms by auto

lemma mfspace_typ :
  "mfspace : mSet \<rightarrow> mSet \<rightarrow> mSetOf mFunc"
proof (rule funI, rule funI, rule msetofI)
  thm mI_mset ex_func_set ex_func_set_subset
  fix x y assume
    x : "x : mSet" and y : "y : mSet"
  then obtain i x' j y' where
    i : "i : Ord" and x_eq : "x = <set, x'>" and
    x' : "x' : Set" and x'_sub:"x' \<subseteq> Tier i \<ominus> set" and
    j : "j : Ord" and y_eq : "y = <set,y'>" and
    y' : "y' : Set" and y'_sub:"y' \<subseteq> Tier j \<ominus> set"
    using mE_mset[OF mset_m] msetE by (metis)
  obtain k where
    k : "k : Ord" and "x' \<subseteq> Tier k" "y' \<subseteq> Tier k"
    using greatest_tier_subset[OF i j,
      OF ex_subset2[OF x' tier_set[OF i] x'_sub],
      OF ex_subset2[OF y' tier_set[OF j] y'_sub]] .
  hence
    x'_sub : "x' \<ominus> func \<subseteq> Tier k \<ominus> func" and
    y'_sub : "y' \<ominus> func \<subseteq> Tier k \<ominus> func"
    using ex_subset3[OF x' tier_set[OF k], of func]
          ex_subset3[OF y' tier_set[OF k], of func]
    by auto

  have f_mem:"\<And>f. f \<in> { <func, f'> | f' \<in> (x' \<ominus> func) \<midarrow>p\<rightarrow> (y' \<ominus> func) } \<Longrightarrow>
    f \<in> Tier (succ k) \<ominus> set \<and> f : mFunc"
  proof (rule, rule exsetI[OF tier_set[OF succ_ord[OF k]]])
    fix f assume
      "f \<in> { <func, f'> | f' \<in> (x' \<ominus> func) \<midarrow>p\<rightarrow> (y' \<ominus> func) }"
    then obtain f' where
      f : "f = <func, f'>" and "f' \<in> (x' \<ominus> func) \<midarrow>p\<rightarrow> (y' \<ominus> func)"
      using repfunE[OF setof_set[OF fspace_setof[OF exset_set[OF x'] exset_set[OF y']]]]
      by metis
    hence "f' : Function" "dom f' \<subseteq> x' \<ominus> func" "ran f' \<subseteq> y' \<ominus> func"
      using fspace_mem[OF exset_set[OF x'] exset_set[OF y']]
            fspaceD[OF exset_set[OF x'] exset_set[OF y']] by auto
    thus "f \<in> Tier (succ k)"
      unfolding f
      using tierI_mfunc[OF k] subset_trans[OF _ x'_sub] subset_trans[OF _ y'_sub]
      by auto
    thus "f : mFunc"
      using mfuncI[OF mI[OF succ_ord[OF k]]]
      unfolding f by auto
    show "\<not> Excluded set f"
      using func_set_excluded func_not_excluded
      unfolding f subtyp_def has_ty_def by auto
  qed
  thus "mfspace x y : mSet"
    using msetI[OF mI_mset[OF succ_ord[OF k]
      repfun_set[OF setof_set[OF
        fspace_setof[OF exset_set[OF x', of func] exset_set[OF y', of func]]]] subsetI]]
    unfolding mfspace_eq[OF x y]
    unfolding mset_snd_eq'[OF x'] mset_snd_eq'[OF y'] x_eq y_eq
    by auto

  fix f assume "f m mfspace x y"
  thus "f : mFunc"
    unfolding mfspace_eq[OF x y]
    unfolding x_eq y_eq mset_snd_eq'[OF x'] mset_snd_eq'[OF y']
    using f_mem mmemD by auto
qed

lemmas mfspace_msetof = funE[OF funE[OF mfspace_typ]]

lemma mfspace_typ_ax :
  "m\<forall>x0. x0 : mSet \<longrightarrow> (m\<forall>x1. x1 : mSet \<longrightarrow> mfspace x0 x1 : mSetOf mFunc)"
  unfolding mall_def tall_def
  using mfspace_msetof by auto

lemma mfspace_iff :
  assumes x : "x : mSet" and y : "y : mSet"
      and f : "f : mFunc"
    shows "f m mfspace x y \<longleftrightarrow> mSubset (mdom f) x \<and> mSubset (mran f) y "
proof (auto)
  assume "f m mfspace x y"
  hence "f \<in> {<func, f'> | f' \<in> (snd x \<ominus> func) \<midarrow>p\<rightarrow> (snd y \<ominus> func)}"
    unfolding mfspace_eq[OF x y]
    using mmemD by auto
  then obtain f' where
    "f = <func, f'>" "f' \<in> (snd x \<ominus> func) \<midarrow>p\<rightarrow> (snd y \<ominus> func)"
    using repfunE[OF setof_set[OF
      fspace_setof[OF exset_set[OF mset_snd_set] exset_set[OF mset_snd_set], OF x y]]]
    by metis
  hence "dom f' \<subseteq> snd x \<ominus> func" "ran f' \<subseteq> snd y \<ominus> func"
    using fspaceD[OF exset_set[OF mset_snd_set] exset_set[OF mset_snd_set], OF x y]
    by auto
  hence dom:"dom (snd f) \<subseteq> snd x" and ran: "ran (snd f) \<subseteq> snd y"
    using mfunc_snd_eq f
      ex_subset2[OF dom_set[OF mfunc_snd_func[OF f]] mset_snd_set[OF x]]
      ex_subset2[OF ran_set[OF mfunc_snd_func[OF f]] mset_snd_set[OF y]]
    unfolding \<open>f = <func,f'>\<close>
    by auto
  show "mSubset (mdom f) x"
  by (rule msubsetI, unfold mdom_eq[OF f], drule mmemD,
      unfold mMem_def, use dom x in auto)
  show "mSubset (mran f) y"
  by (rule msubsetI, unfold mran_eq[OF f], drule mmemD,
      unfold mMem_def, use ran y in auto)
next
  obtain f' j where
    f' : "f' : Function" and f_eq : "f = <func, f'>" and
    j : "j : Ord" and dom :"dom f' \<subseteq> Tier j \<ominus> func" and
    ran : "ran f' \<subseteq> Tier j \<ominus> func"
    using mfuncE2[OF f] .

  assume x_sub:"mSubset (mdom f) x" and y_sub: "mSubset (mran f) y"
  have "dom (snd f) \<subseteq> snd x" "ran (snd f) \<subseteq> snd y"
    using msubsetD[OF x_sub] msubsetD[OF y_sub] mmemI mMem_def
      mdom_mset[OF f] mran_mset[OF f]
    unfolding mdom_eq[OF f] mran_eq[OF f]
    by auto
  hence "dom f' \<subseteq> snd x" "ran f' \<subseteq> snd y"
    using mfunc_snd_eq f
    unfolding f_eq by auto
  hence "dom f' \<subseteq> snd x \<ominus> func" "ran f' \<subseteq> snd y \<ominus> func"
    using dom ran
    unfolding Subset_def
      exset_iff[OF mset_snd_set[OF x]]
      exset_iff[OF mset_snd_set[OF y]]
      exset_iff[OF tier_set[OF j]] by auto
  hence "f' \<in> (snd x \<ominus> func) \<midarrow>p\<rightarrow> (snd y \<ominus> func)"
    using fspaceI[OF exset_set[OF mset_snd_set[OF x]],
                  OF exset_set[OF mset_snd_set[OF y]], OF f']
    by auto
  hence "f \<in> { <func, f'> | f' \<in> (snd x \<ominus> func) \<midarrow>p\<rightarrow> (snd y \<ominus> func)}"
    using repfunI[OF setof_set[OF fspace_setof],
                  OF exset_set[OF mset_snd_set[OF x]],
                  OF exset_set[OF mset_snd_set[OF y]]]
          pair_smem[OF m_pair[OF mfunc_m[OF f]]]
    unfolding f_eq by auto
  thus "f m mfspace x y"
    using mmemI msetof_mset[OF mfspace_msetof[OF x y]]
    unfolding mfspace_eq[OF x y] by auto
qed

lemma mfspace_ax :
  "m\<forall>x : mSet. m\<forall>y : mSet. m\<forall>f : mFunc.
    (f m mfspace x y) = (mSubset (mdom f) x \<and> mSubset (mran f) y)"
  unfolding mtall_def mall_def tall_def
  using mfspace_iff by auto

theorem mfspace_rsp :
  "x : M \<Longrightarrow> y : M \<Longrightarrow> mfspace x y : M"
  using mset_m[OF msetof_mset[OF mfspace_msetof]] Function_Model_mdefault_m
  unfolding mfspace_def by auto

end
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 factorial
imports "../CTranslation"
begin

declare hrs_simps [simp add]
declare sep_conj_ac [simp add]

consts free_pool :: "nat \<Rightarrow> heap_assert"

primrec
  fac :: "nat \<Rightarrow> word32"
where
  "fac 0 = 1"
| "fac (Suc n) = of_nat (Suc n) * fac n"

lemma fac_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac (unat n) = n * fac (unat (n - 1))"
apply(case_tac "unat n")
 apply simp
apply(subst unat_minus_one)
 apply(simp only: unat_simps)
 apply(clarify)
 apply simp
apply clarsimp
apply(simp only: unat_simps)
apply(subst mod_less)
 apply (fold len_of_addr_card)
 apply unat_arith
apply (clarsimp simp: distrib_right split: unat_splits)
done

primrec
  fac_list :: "nat \<Rightarrow> word32 list"
where
  "fac_list 0 = [1]"
| "fac_list (Suc n) = fac (Suc n) # fac_list n"

lemma fac_list_length [simp]:
  "length (fac_list n) = n + 1"
  by (induct n) auto

lemma fac_list_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac_list (unat n) = fac (unat n) # fac_list (unat (n - 1))"
apply(case_tac "unat n")
 apply clarsimp
apply(subst unat_minus_one)
 apply clarsimp+
done

primrec
  sep_list :: "word32 list \<Rightarrow> word32 ptr \<Rightarrow> heap_assert"
where
  "sep_list [] p = (\<lambda>s. p=NULL \<and> \<box> s)"
| "sep_list (x#xs) p = (\<lambda>s. \<exists>j. ((p \<mapsto> x) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> j \<and>\<^sup>*
      sep_list xs (Ptr j)) s)"

lemma sep_list_NULL [simp]:
  "sep_list xs NULL = (\<lambda>s. xs = [] \<and> \<box> s)"
apply(rule ext)
apply(case_tac xs)
 apply simp+
done

definition
  sep_fac_list :: "word32 \<Rightarrow> word32 ptr \<Rightarrow> heap_assert"
where
  "sep_fac_list n p \<equiv> sep_list (fac_list (unat n)) p"

lemma sep_fac_list_unfold:
  "((\<lambda>s. unat n \<noteq> 0 \<and> (\<exists>q. (p \<mapsto> fac (unat n) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> q \<and>\<^sup>*
      sep_fac_list (n - 1) (Ptr q)) s)) \<and>\<^sup>* R) s \<Longrightarrow>
      (sep_fac_list n p \<and>\<^sup>* R) s"
apply (erule sep_globalise)
apply (simp add: sep_fac_list_def fac_list_unfold)
done

lemma sep_fac_list_points:
  "sep_points (sep_fac_list n p) s \<Longrightarrow> (p \<hookrightarrow> fac (unat n)) s"
apply(unfold sep_points_def)
apply(subst sep_map'_unfold)
apply(erule sep_conj_impl)
 apply(unfold sep_fac_list_def)
 apply(case_tac "unat n")
  apply simp
  apply(unfold sep_map'_old)
  apply(erule (1) sep_conj_impl)
  apply simp
 apply clarsimp
 apply(subst (asm) sep_conj_assoc [symmetric])+
 apply(erule sep_conj_impl)
  apply simp+
done

install_C_file memsafe "factorial.c"

thm factorial_global_addresses.factorial_body_def

lemma (in factorial_global_addresses) mem_safe_alloc:
  "mem_safe (\<acute>ret__ptr_to_unsigned :== PROC alloc()) \<Gamma>"
apply(insert alloc_impl)
apply(unfold alloc_body_def)
apply(subst mem_safe_restrict)
apply(rule intra_mem_safe)
 apply(simp_all add: restrict_map_def split: split_if_asm)
apply(auto simp: whileAnno_def comp_def hrs_comm split_def mono_guard_def intro!: ext)
done

lemma (in factorial_global_addresses) sep_frame_alloc:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> \<acute>ret__ptr_to_unsigned :== PROC alloc() \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              \<acute>ret__ptr_to_unsigned :== PROC alloc()
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
apply(simp only: sep_app_def)
apply(rule sep_frame)
    apply(auto intro!: mem_safe_alloc)
done

lemma (in alloc_spec) alloc_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>x. free_pool k) ((\<lambda>x. undefined) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    \<acute>ret__ptr_to_unsigned :== PROC alloc()
    \<lbrace> ((\<lambda>p s. if k > 0 then (\<turnstile>\<^sub>s p \<and>\<^sup>* \<turnstile>\<^sub>s (p +\<^sub>p 1) \<and>\<^sup>*
        free_pool (k - 1)) s else (free_pool k) s \<and> p = NULL) \<acute>ret__ptr_to_unsigned
        \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
apply clarify
apply(insert alloc_spec)
apply(rule_tac x=\<sigma> in spec)
   apply(rule sep_frame_alloc)
   apply(clarsimp simp: sep_app_def split: split_if_asm)
  apply(simp add: htd_ind_def)+
done

lemma (in factorial_global_addresses) mem_safe_free:
  "mem_safe (PROC free(\<acute>p)) \<Gamma>"
apply(insert free_impl)
apply(unfold free_body_def)
apply(subst mem_safe_restrict)
apply(auto simp: whileAnno_def)
apply(rule intra_mem_safe)
apply(auto simp: restrict_map_def split: split_if_asm)
done

lemma (in factorial_global_addresses) sep_frame_free:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> PROC free(\<acute>p) \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              PROC free(\<acute>p)
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
apply(simp only: sep_app_def)
apply(rule sep_frame)
    apply(auto intro!: mem_safe_free)
done

lemma (in free_spec) free_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>p. sep_cut' (ptr_val p) (2 * size_of TYPE(word32)) \<and>\<^sup>* free_pool k) \<acute>p  \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    PROC free(\<acute>p)
    \<lbrace> ((\<lambda>x. free_pool (k + 1)) ((\<lambda>x. ()) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
apply clarify
apply(insert free_spec)
apply(rule_tac x=\<sigma> in spec)
   apply(rule sep_frame_free)
   apply(clarsimp simp: sep_app_def split: split_if_asm)
  apply(simp add: htd_ind_def)+
done

lemma double_word_sep_cut':
  "(p \<mapsto> x \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> y) s \<Longrightarrow> sep_cut' (ptr_val (p::word32 ptr)) 8 s"
apply(clarsimp simp: sep_conj_def sep_cut'_def dest!: sep_map_dom)
apply(subgoal_tac "{ptr_val p..+4} \<subseteq> {ptr_val p..+8}")
 apply(subgoal_tac "{ptr_val p+4..+4} \<subseteq> {ptr_val p..+8}")
  apply rule
   apply fast
  apply clarsimp
  apply(drule intvlD)
  apply clarsimp
  apply(case_tac "k < 4")
   apply(erule intvlI)
  apply(erule notE)
  apply(clarsimp simp: intvl_def)
  apply(rule_tac x="k - 4" in exI)
  apply rule
   apply(simp only: unat_simps)
   apply(subst mod_less)
    apply(simp add: addr_card)
   apply simp
  apply simp
 apply(clarsimp simp: intvl_def)
 apply(rule_tac x="4+k" in exI)
 apply simp
apply(rule intvl_start_le)
apply simp
done

locale specs = factorial_global_addresses + alloc_spec + free_spec

lemma (in specs) factorial_spec:
  shows "factorial_spec"
apply unfold_locales
apply(hoare_rule HoarePartial.ProcRec1)
apply (hoare_rule anno = "factorial_invs_body k" in HoarePartial.annotateI)
 prefer 2
 apply (simp add: whileAnno_def factorial_invs_body_def)
apply(subst factorial_invs_body_def)
apply(unfold sep_app_def)
apply (vcg exspec=alloc_spec' exspec=free_spec')
apply (fold lift_def)

apply(clarsimp simp: sep_app_def)
apply rule
 apply clarsimp
 apply(rule_tac x=k in exI)
 apply(rule_tac x="\<lambda>p. \<box>" in exI)
 apply(rule_tac x="\<lambda>s. undefined" in exI)
 apply clarsimp
 apply (rule conjI)
  apply clarsimp
 apply clarsimp
 apply (rename_tac a b ret__ptr_to_unsigned)
 apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned \<and>\<^sup>* sep_true) (lift_state (a,b))")
  apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (a,b))")
   apply(simp add: tagd_ptr_safe tagd_g c_guard_ptr_aligned c_guard_NULL)
   apply(simp add: sep_fac_list_def)
   apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
   apply(rule sep_heap_update_global')
   apply (simp add: scast_id)
   apply(rule sep_heap_update_global')
   apply simp
  apply(drule sep_conj_sep_true_left)
  apply simp
  apply(subst (asm) sep_conj_assoc [symmetric])+
  apply(drule_tac Q="free_pool (k - Suc 0)" in sep_conj_sep_true_right)
  apply simp
 apply(drule sep_conj_sep_true_right)
 apply simp
apply clarsimp
apply(rule_tac x=k in exI)
apply clarsimp
apply(rule_tac x="k - Suc (unat (n - 1))" in exI)
apply clarsimp
apply(rule_tac x="\<lambda>(n,p). sep_fac_list (n - 1) p" in exI)
apply(rule_tac x="\<lambda>s. (n_' s,q_' s)" in exI)
apply rule
 apply (clarsimp simp: scast_id)
apply clarsimp
apply rule
 apply clarsimp
 apply(simp add: sep_fac_list_def)
 apply(rule_tac x="fac_list (unat (n - 1))" in exI)
 apply rule
  apply simp
 apply (clarsimp simp: scast_id)
apply clarsimp
apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
 apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
  apply(sep_point_tac sep_fac_list_points)
  apply(simp add: tagd_ptr_safe tagd_g sep_map'_g c_guard_ptr_aligned
                  c_guard_NULL sep_map'_lift)
  apply rule
   apply(rule sep_fac_list_unfold)
   apply clarsimp
   apply rule
    apply unat_arith
   apply sep_exists_tac
   apply(rule_tac x="ptr_val ret__ptr_to_unsigneda" in exI)
   apply clarsimp
   apply(subst fac_unfold)
    apply unat_arith
   apply clarsimp
   apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
   apply(rule sep_heap_update_global')
   apply(sep_select_tac "_ \<mapsto> _")
   apply(rule sep_heap_update_global')
   apply(erule (1) sep_conj_impl)+
   apply clarsimp
   apply(subgoal_tac "Suc (Suc (unat (n - 1))) = Suc (unat n)")
    apply simp
   apply unat_arith
  apply unat_arith
 apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned \<and>\<^sup>*
         \<turnstile>\<^sub>s (ret__ptr_to_unsigned +\<^sub>p 1) \<and>\<^sup>*
         sep_fac_list (n - 1) ret__ptr_to_unsigneda \<and>\<^sup>*
         free_pool (k - Suc (Suc (unat (n - 1))))) =
         (\<turnstile>\<^sub>s (ret__ptr_to_unsigned +\<^sub>p 1) \<and>\<^sup>* (\<turnstile>\<^sub>s ret__ptr_to_unsigned \<and>\<^sup>*
         sep_fac_list (n - 1) ret__ptr_to_unsigneda \<and>\<^sup>*
         free_pool (k - Suc (Suc (unat (n - 1))))))")
  apply(simp only:)
  apply(erule (1) sep_conj_impl)
  apply simp
 apply simp
apply(erule (1) sep_conj_impl)
apply simp

apply clarsimp
apply(case_tac xs)
 apply simp
apply clarsimp
apply sep_exists_tac
apply clarsimp
apply sep_point_tac
 apply(simp add: sep_map'_g c_guard_ptr_aligned
                   c_guard_NULL sep_map'_lift)
 apply(rule_tac x="k - Suc (length list)" in exI)
 apply(rule_tac x="\<lambda>p. sep_list list (Ptr j)" in exI)
 apply(rule_tac x="\<lambda>x. ()" in exI)
 apply(clarsimp simp: sep_app_def)
 apply rule
  apply(subgoal_tac "(q \<mapsto> aa \<and>\<^sup>*
         sep_list list (Ptr j) \<and>\<^sup>*
         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))) =
         (sep_list list (Ptr j) \<and>\<^sup>* (q \<mapsto> aa \<and>\<^sup>*
         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))))")
   apply(simp only:)
   apply(erule (1) sep_conj_impl)
   apply simp
   apply(subst sep_conj_com)
   apply(subst (asm) sep_conj_assoc [symmetric])+
   apply(erule sep_conj_impl)
    apply simp
    apply(erule double_word_sep_cut')
   apply assumption
  apply simp
 apply clarsimp
 apply(subgoal_tac "Suc (k - Suc (length list)) = k - length list")
  apply force
 apply arith
apply clarsimp
done

declare hrs_simps [simp del]

lemma (in factorial_global_addresses) mem_safe_factorial:
  shows "mem_safe (\<acute>ret__ptr_to_unsigned :== PROC factorial(\<acute>n)) \<Gamma>"
apply(subst mem_safe_restrict)
apply(rule intra_mem_safe)
 apply (insert factorial_impl free_impl alloc_impl)
 apply(drule_tac t="Some C" in sym)
 apply(simp_all add: restrict_map_def call_def block_def whileAnno_def
                     free_body_def alloc_body_def factorial_body_def creturn_def
                split: split_if_asm option.splits)
apply((erule disjE)?, simp,
      (thin_tac "C=x" for x, (thin_tac "\<Gamma> x = y" for x y)+,
       force simp: intra_sc)?)+
done

end


(*  Title:      ZF/UNITY/UNITY.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>The Basic UNITY Theory\<close>

theory UNITY imports State begin

text\<open>The basic UNITY theory (revised version, based upon the "co" operator)
From Misra, "A Logic for Concurrent Programming", 1994.

This ZF theory was ported from its HOL equivalent.\<close>

definition
  program  :: i  where
  "program == {<init, acts, allowed>:
               Pow(state) * Pow(Pow(state*state)) * Pow(Pow(state*state)).
               id(state) \<in> acts & id(state) \<in> allowed}"

definition
  mk_program :: "[i,i,i]=>i"  where
  \<comment> \<open>The definition yields a program thanks to the coercions
       init \<inter> state, acts \<inter> Pow(state*state), etc.\<close>
  "mk_program(init, acts, allowed) ==
    <init \<inter> state, cons(id(state), acts \<inter> Pow(state*state)),
              cons(id(state), allowed \<inter> Pow(state*state))>"

definition
  SKIP :: i  (\<open>\<bottom>\<close>) where
  "SKIP == mk_program(state, 0, Pow(state*state))"

  (* Coercion from anything to program *)
definition
  programify :: "i=>i"  where
  "programify(F) == if F \<in> program then F else SKIP"

definition
  RawInit :: "i=>i"  where
  "RawInit(F) == fst(F)"

definition
  Init :: "i=>i"  where
  "Init(F) == RawInit(programify(F))"

definition
  RawActs :: "i=>i"  where
  "RawActs(F) == cons(id(state), fst(snd(F)))"

definition
  Acts :: "i=>i"  where
  "Acts(F) == RawActs(programify(F))"

definition
  RawAllowedActs :: "i=>i"  where
  "RawAllowedActs(F) == cons(id(state), snd(snd(F)))"

definition
  AllowedActs :: "i=>i"  where
  "AllowedActs(F) == RawAllowedActs(programify(F))"

definition
  Allowed :: "i =>i"  where
  "Allowed(F) == {G \<in> program. Acts(G) \<subseteq> AllowedActs(F)}"

definition
  initially :: "i=>i"  where
  "initially(A) == {F \<in> program. Init(F)\<subseteq>A}"

definition "constrains" :: "[i, i] => i"  (infixl \<open>co\<close> 60)  where
  "A co B == {F \<in> program. (\<forall>act \<in> Acts(F). act``A\<subseteq>B) & st_set(A)}"
    \<comment> \<open>the condition \<^term>\<open>st_set(A)\<close> makes the definition slightly
         stronger than the HOL one\<close>

definition unless :: "[i, i] => i"  (infixl \<open>unless\<close> 60)  where
  "A unless B == (A - B) co (A \<union> B)"

definition
  stable     :: "i=>i"  where
   "stable(A) == A co A"

definition
  strongest_rhs :: "[i, i] => i"  where
  "strongest_rhs(F, A) == \<Inter>({B \<in> Pow(state). F \<in> A co B})"

definition
  invariant :: "i => i"  where
  "invariant(A) == initially(A) \<inter> stable(A)"

  (* meta-function composition *)
definition
  metacomp :: "[i=>i, i=>i] => (i=>i)" (infixl \<open>comp\<close> 65)  where
  "f comp g == %x. f(g(x))"

definition
  pg_compl :: "i=>i"  where
  "pg_compl(X)== program - X"

text\<open>SKIP\<close>
lemma SKIP_in_program [iff,TC]: "SKIP \<in> program"
by (force simp add: SKIP_def program_def mk_program_def)

subsection\<open>The function \<^term>\<open>programify\<close>, the coercion from anything to
 program\<close>

lemma programify_program [simp]: "F \<in> program ==> programify(F)=F"
by (force simp add: programify_def)

lemma programify_in_program [iff,TC]: "programify(F) \<in> program"
by (force simp add: programify_def)

text\<open>Collapsing rules: to remove programify from expressions\<close>
lemma programify_idem [simp]: "programify(programify(F))=programify(F)"
by (force simp add: programify_def)

lemma Init_programify [simp]: "Init(programify(F)) = Init(F)"
by (simp add: Init_def)

lemma Acts_programify [simp]: "Acts(programify(F)) = Acts(F)"
by (simp add: Acts_def)

lemma AllowedActs_programify [simp]:
     "AllowedActs(programify(F)) = AllowedActs(F)"
by (simp add: AllowedActs_def)

subsection\<open>The Inspectors for Programs\<close>

lemma id_in_RawActs: "F \<in> program ==>id(state) \<in> RawActs(F)"
by (auto simp add: program_def RawActs_def)

lemma id_in_Acts [iff,TC]: "id(state) \<in> Acts(F)"
by (simp add: id_in_RawActs Acts_def)

lemma id_in_RawAllowedActs: "F \<in> program ==>id(state) \<in> RawAllowedActs(F)"
by (auto simp add: program_def RawAllowedActs_def)

lemma id_in_AllowedActs [iff,TC]: "id(state) \<in> AllowedActs(F)"
by (simp add: id_in_RawAllowedActs AllowedActs_def)

lemma cons_id_Acts [simp]: "cons(id(state), Acts(F)) = Acts(F)"
by (simp add: cons_absorb)

lemma cons_id_AllowedActs [simp]:
     "cons(id(state), AllowedActs(F)) = AllowedActs(F)"
by (simp add: cons_absorb)

subsection\<open>Types of the Inspectors\<close>

lemma RawInit_type: "F \<in> program ==> RawInit(F)\<subseteq>state"
by (auto simp add: program_def RawInit_def)

lemma RawActs_type: "F \<in> program ==> RawActs(F)\<subseteq>Pow(state*state)"
by (auto simp add: program_def RawActs_def)

lemma RawAllowedActs_type:
     "F \<in> program ==> RawAllowedActs(F)\<subseteq>Pow(state*state)"
by (auto simp add: program_def RawAllowedActs_def)

lemma Init_type: "Init(F)\<subseteq>state"
by (simp add: RawInit_type Init_def)

lemmas InitD = Init_type [THEN subsetD]

lemma st_set_Init [iff]: "st_set(Init(F))"
apply (unfold st_set_def)
apply (rule Init_type)
done

lemma Acts_type: "Acts(F)\<subseteq>Pow(state*state)"
by (simp add: RawActs_type Acts_def)

lemma AllowedActs_type: "AllowedActs(F) \<subseteq> Pow(state*state)"
by (simp add: RawAllowedActs_type AllowedActs_def)

text\<open>Needed in Behaviors\<close>
lemma ActsD: "[| act \<in> Acts(F); <s,s'> \<in> act |] ==> s \<in> state & s' \<in> state"
by (blast dest: Acts_type [THEN subsetD])

lemma AllowedActsD:
     "[| act \<in> AllowedActs(F); <s,s'> \<in> act |] ==> s \<in> state & s' \<in> state"
by (blast dest: AllowedActs_type [THEN subsetD])

subsection\<open>Simplification rules involving \<^term>\<open>state\<close>, \<^term>\<open>Init\<close>,
  \<^term>\<open>Acts\<close>, and \<^term>\<open>AllowedActs\<close>\<close>

text\<open>But are they really needed?\<close>

lemma state_subset_is_Init_iff [iff]: "state \<subseteq> Init(F) \<longleftrightarrow> Init(F)=state"
by (cut_tac F = F in Init_type, auto)

lemma Pow_state_times_state_is_subset_Acts_iff [iff]:
     "Pow(state*state) \<subseteq> Acts(F) \<longleftrightarrow> Acts(F)=Pow(state*state)"
by (cut_tac F = F in Acts_type, auto)

lemma Pow_state_times_state_is_subset_AllowedActs_iff [iff]:
     "Pow(state*state) \<subseteq> AllowedActs(F) \<longleftrightarrow> AllowedActs(F)=Pow(state*state)"
by (cut_tac F = F in AllowedActs_type, auto)

subsubsection\<open>Eliminating \<open>\<inter> state\<close> from expressions\<close>

lemma Init_Int_state [simp]: "Init(F) \<inter> state = Init(F)"
by (cut_tac F = F in Init_type, blast)

lemma state_Int_Init [simp]: "state \<inter> Init(F) = Init(F)"
by (cut_tac F = F in Init_type, blast)

lemma Acts_Int_Pow_state_times_state [simp]:
     "Acts(F) \<inter> Pow(state*state) = Acts(F)"
by (cut_tac F = F in Acts_type, blast)

lemma state_times_state_Int_Acts [simp]:
     "Pow(state*state) \<inter> Acts(F) = Acts(F)"
by (cut_tac F = F in Acts_type, blast)

lemma AllowedActs_Int_Pow_state_times_state [simp]:
     "AllowedActs(F) \<inter> Pow(state*state) = AllowedActs(F)"
by (cut_tac F = F in AllowedActs_type, blast)

lemma state_times_state_Int_AllowedActs [simp]:
     "Pow(state*state) \<inter> AllowedActs(F) = AllowedActs(F)"
by (cut_tac F = F in AllowedActs_type, blast)

subsubsection\<open>The Operator \<^term>\<open>mk_program\<close>\<close>

lemma mk_program_in_program [iff,TC]:
     "mk_program(init, acts, allowed) \<in> program"
by (auto simp add: mk_program_def program_def)

lemma RawInit_eq [simp]:
     "RawInit(mk_program(init, acts, allowed)) = init \<inter> state"
by (auto simp add: mk_program_def RawInit_def)

lemma RawActs_eq [simp]:
     "RawActs(mk_program(init, acts, allowed)) =
      cons(id(state), acts \<inter> Pow(state*state))"
by (auto simp add: mk_program_def RawActs_def)

lemma RawAllowedActs_eq [simp]:
     "RawAllowedActs(mk_program(init, acts, allowed)) =
      cons(id(state), allowed \<inter> Pow(state*state))"
by (auto simp add: mk_program_def RawAllowedActs_def)

lemma Init_eq [simp]: "Init(mk_program(init, acts, allowed)) = init \<inter> state"
by (simp add: Init_def)

lemma Acts_eq [simp]:
     "Acts(mk_program(init, acts, allowed)) =
      cons(id(state), acts  \<inter> Pow(state*state))"
by (simp add: Acts_def)

lemma AllowedActs_eq [simp]:
     "AllowedActs(mk_program(init, acts, allowed))=
      cons(id(state), allowed \<inter> Pow(state*state))"
by (simp add: AllowedActs_def)

text\<open>Init, Acts, and AlowedActs  of SKIP\<close>

lemma RawInit_SKIP [simp]: "RawInit(SKIP) = state"
by (simp add: SKIP_def)

lemma RawAllowedActs_SKIP [simp]: "RawAllowedActs(SKIP) = Pow(state*state)"
by (force simp add: SKIP_def)

lemma RawActs_SKIP [simp]: "RawActs(SKIP) = {id(state)}"
by (force simp add: SKIP_def)

lemma Init_SKIP [simp]: "Init(SKIP) = state"
by (force simp add: SKIP_def)

lemma Acts_SKIP [simp]: "Acts(SKIP) = {id(state)}"
by (force simp add: SKIP_def)

lemma AllowedActs_SKIP [simp]: "AllowedActs(SKIP) = Pow(state*state)"
by (force simp add: SKIP_def)

text\<open>Equality of UNITY programs\<close>

lemma raw_surjective_mk_program:
     "F \<in> program ==> mk_program(RawInit(F), RawActs(F), RawAllowedActs(F))=F"
apply (auto simp add: program_def mk_program_def RawInit_def RawActs_def
            RawAllowedActs_def, blast+)
done

lemma surjective_mk_program [simp]:
  "mk_program(Init(F), Acts(F), AllowedActs(F)) = programify(F)"
by (auto simp add: raw_surjective_mk_program Init_def Acts_def AllowedActs_def)

lemma program_equalityI:
    "[|Init(F) = Init(G); Acts(F) = Acts(G);
       AllowedActs(F) = AllowedActs(G); F \<in> program; G \<in> program |] ==> F = G"
apply (subgoal_tac "programify(F) = programify(G)")
apply simp
apply (simp only: surjective_mk_program [symmetric])
done

lemma program_equalityE:
 "[|F = G;
    [|Init(F) = Init(G); Acts(F) = Acts(G); AllowedActs(F) = AllowedActs(G) |]
    ==> P |]
  ==> P"
by force

lemma program_equality_iff:
    "[| F \<in> program; G \<in> program |] ==>(F=G)  \<longleftrightarrow>
     (Init(F) = Init(G) & Acts(F) = Acts(G) & AllowedActs(F) = AllowedActs(G))"
by (blast intro: program_equalityI program_equalityE)

subsection\<open>These rules allow "lazy" definition expansion\<close>

lemma def_prg_Init:
     "F == mk_program (init,acts,allowed) ==> Init(F) = init \<inter> state"
by auto

lemma def_prg_Acts:
     "F == mk_program (init,acts,allowed)
      ==> Acts(F) = cons(id(state), acts \<inter> Pow(state*state))"
by auto

lemma def_prg_AllowedActs:
     "F == mk_program (init,acts,allowed)
      ==> AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
by auto

lemma def_prg_simps:
    "[| F == mk_program (init,acts,allowed) |]
     ==> Init(F) = init \<inter> state &
         Acts(F) = cons(id(state), acts \<inter> Pow(state*state)) &
         AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
by auto

text\<open>An action is expanded only if a pair of states is being tested against it\<close>
lemma def_act_simp:
     "[| act == {<s,s'> \<in> A*B. P(s, s')} |]
      ==> (<s,s'> \<in> act) \<longleftrightarrow> (<s,s'> \<in> A*B & P(s, s'))"
by auto

text\<open>A set is expanded only if an element is being tested against it\<close>
lemma def_set_simp: "A == B ==> (x \<in> A) \<longleftrightarrow> (x \<in> B)"
by auto

subsection\<open>The Constrains Operator\<close>

lemma constrains_type: "A co B \<subseteq> program"
by (force simp add: constrains_def)

lemma constrainsI:
    "[|(!!act s s'. [| act: Acts(F);  <s,s'> \<in> act; s \<in> A|] ==> s' \<in> A');
        F \<in> program; st_set(A) |]  ==> F \<in> A co A'"
by (force simp add: constrains_def)

lemma constrainsD:
   "F \<in> A co B ==> \<forall>act \<in> Acts(F). act``A\<subseteq>B"
by (force simp add: constrains_def)

lemma constrainsD2: "F \<in> A co B ==> F \<in> program & st_set(A)"
by (force simp add: constrains_def)

lemma constrains_empty [iff]: "F \<in> 0 co B \<longleftrightarrow> F \<in> program"
by (force simp add: constrains_def st_set_def)

lemma constrains_empty2 [iff]: "(F \<in> A co 0) \<longleftrightarrow> (A=0 & F \<in> program)"
by (force simp add: constrains_def st_set_def)

lemma constrains_state [iff]: "(F \<in> state co B) \<longleftrightarrow> (state\<subseteq>B & F \<in> program)"
apply (cut_tac F = F in Acts_type)
apply (force simp add: constrains_def st_set_def)
done

lemma constrains_state2 [iff]: "F \<in> A co state \<longleftrightarrow> (F \<in> program & st_set(A))"
apply (cut_tac F = F in Acts_type)
apply (force simp add: constrains_def st_set_def)
done

text\<open>monotonic in 2nd argument\<close>
lemma constrains_weaken_R:
    "[| F \<in> A co A'; A'\<subseteq>B' |] ==> F \<in> A co B'"
apply (unfold constrains_def, blast)
done

text\<open>anti-monotonic in 1st argument\<close>
lemma constrains_weaken_L:
    "[| F \<in> A co A'; B\<subseteq>A |] ==> F \<in> B co A'"
apply (unfold constrains_def st_set_def, blast)
done

lemma constrains_weaken:
   "[| F \<in> A co A'; B\<subseteq>A; A'\<subseteq>B' |] ==> F \<in> B co B'"
apply (drule constrains_weaken_R)
apply (drule_tac [2] constrains_weaken_L, blast+)
done

subsection\<open>Constrains and Union\<close>

lemma constrains_Un:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<union> B) co (A' \<union> B')"
by (auto simp add: constrains_def st_set_def, force)

lemma constrains_UN:
     "[|!!i. i \<in> I ==> F \<in> A(i) co A'(i); F \<in> program |]
      ==> F \<in> (\<Union>i \<in> I. A(i)) co (\<Union>i \<in> I. A'(i))"
by (force simp add: constrains_def st_set_def)

lemma constrains_Un_distrib:
     "(A \<union> B) co C = (A co C) \<inter> (B co C)"
by (force simp add: constrains_def st_set_def)

lemma constrains_UN_distrib:
   "i \<in> I ==> (\<Union>i \<in> I. A(i)) co B = (\<Inter>i \<in> I. A(i) co B)"
by (force simp add: constrains_def st_set_def)

subsection\<open>Constrains and Intersection\<close>

lemma constrains_Int_distrib: "C co (A \<inter> B) = (C co A) \<inter> (C co B)"
by (force simp add: constrains_def st_set_def)

lemma constrains_INT_distrib:
     "x \<in> I ==> A co (\<Inter>i \<in> I. B(i)) = (\<Inter>i \<in> I. A co B(i))"
by (force simp add: constrains_def st_set_def)

lemma constrains_Int:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<inter> B) co (A' \<inter> B')"
by (force simp add: constrains_def st_set_def)

lemma constrains_INT [rule_format]:
     "[| \<forall>i \<in> I. F \<in> A(i) co A'(i); F \<in> program|]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) co (\<Inter>i \<in> I. A'(i))"
apply (case_tac "I=0")
 apply (simp add: Inter_def)
apply (erule not_emptyE)
apply (auto simp add: constrains_def st_set_def, blast)
apply (drule bspec, assumption, force)
done

(* The rule below simulates the HOL's one for (\<Inter>z. A i) co (\<Inter>z. B i) *)
lemma constrains_All:
"[| \<forall>z. F:{s \<in> state. P(s, z)} co {s \<in> state. Q(s, z)}; F \<in> program |]==>
    F:{s \<in> state. \<forall>z. P(s, z)} co {s \<in> state. \<forall>z. Q(s, z)}"
by (unfold constrains_def, blast)

lemma constrains_imp_subset:
  "[| F \<in> A co A' |] ==> A \<subseteq> A'"
by (unfold constrains_def st_set_def, force)

text\<open>The reasoning is by subsets since "co" refers to single actions
  only.  So this rule isn't that useful.\<close>

lemma constrains_trans: "[| F \<in> A co B; F \<in> B co C |] ==> F \<in> A co C"
by (unfold constrains_def st_set_def, auto, blast)

lemma constrains_cancel:
"[| F \<in> A co (A' \<union> B); F \<in> B co B' |] ==> F \<in> A co (A' \<union> B')"
apply (drule_tac A = B in constrains_imp_subset)
apply (blast intro: constrains_weaken_R)
done

subsection\<open>The Unless Operator\<close>

lemma unless_type: "A unless B \<subseteq> program"
by (force simp add: unless_def constrains_def)

lemma unlessI: "[| F \<in> (A-B) co (A \<union> B) |] ==> F \<in> A unless B"
apply (unfold unless_def)
apply (blast dest: constrainsD2)
done

lemma unlessD: "F :A unless B ==> F \<in> (A-B) co (A \<union> B)"
by (unfold unless_def, auto)

subsection\<open>The Operator \<^term>\<open>initially\<close>\<close>

lemma initially_type: "initially(A) \<subseteq> program"
by (unfold initially_def, blast)

lemma initiallyI: "[| F \<in> program; Init(F)\<subseteq>A |] ==> F \<in> initially(A)"
by (unfold initially_def, blast)

lemma initiallyD: "F \<in> initially(A) ==> Init(F)\<subseteq>A"
by (unfold initially_def, blast)

subsection\<open>The Operator \<^term>\<open>stable\<close>\<close>

lemma stable_type: "stable(A)\<subseteq>program"
by (unfold stable_def constrains_def, blast)

lemma stableI: "F \<in> A co A ==> F \<in> stable(A)"
by (unfold stable_def, assumption)

lemma stableD: "F \<in> stable(A) ==> F \<in> A co A"
by (unfold stable_def, assumption)

lemma stableD2: "F \<in> stable(A) ==> F \<in> program & st_set(A)"
by (unfold stable_def constrains_def, auto)

lemma stable_state [simp]: "stable(state) = program"
by (auto simp add: stable_def constrains_def dest: Acts_type [THEN subsetD])

lemma stable_unless: "stable(A)= A unless 0"
by (auto simp add: unless_def stable_def)

subsection\<open>Union and Intersection with \<^term>\<open>stable\<close>\<close>

lemma stable_Un:
    "[| F \<in> stable(A); F \<in> stable(A') |] ==> F \<in> stable(A \<union> A')"
apply (unfold stable_def)
apply (blast intro: constrains_Un)
done

lemma stable_UN:
     "[|!!i. i\<in>I ==> F \<in> stable(A(i)); F \<in> program |]
      ==> F \<in> stable (\<Union>i \<in> I. A(i))"
apply (unfold stable_def)
apply (blast intro: constrains_UN)
done

lemma stable_Int:
    "[| F \<in> stable(A);  F \<in> stable(A') |] ==> F \<in> stable (A \<inter> A')"
apply (unfold stable_def)
apply (blast intro: constrains_Int)
done

lemma stable_INT:
     "[| !!i. i \<in> I ==> F \<in> stable(A(i)); F \<in> program |]
      ==> F \<in> stable (\<Inter>i \<in> I. A(i))"
apply (unfold stable_def)
apply (blast intro: constrains_INT)
done

lemma stable_All:
    "[|\<forall>z. F \<in> stable({s \<in> state. P(s, z)}); F \<in> program|]
     ==> F \<in> stable({s \<in> state. \<forall>z. P(s, z)})"
apply (unfold stable_def)
apply (rule constrains_All, auto)
done

lemma stable_constrains_Un:
     "[| F \<in> stable(C); F \<in> A co (C \<union> A') |] ==> F \<in> (C \<union> A) co (C \<union> A')"
apply (unfold stable_def constrains_def st_set_def, auto)
apply (blast dest!: bspec)
done

lemma stable_constrains_Int:
     "[| F \<in> stable(C); F \<in>  (C \<inter> A) co A' |] ==> F \<in> (C \<inter> A) co (C \<inter> A')"
by (unfold stable_def constrains_def st_set_def, blast)

(* [| F \<in> stable(C); F  \<in> (C \<inter> A) co A |] ==> F \<in> stable(C \<inter> A) *)
lemmas stable_constrains_stable = stable_constrains_Int [THEN stableI]

subsection\<open>The Operator \<^term>\<open>invariant\<close>\<close>

lemma invariant_type: "invariant(A) \<subseteq> program"
apply (unfold invariant_def)
apply (blast dest: stable_type [THEN subsetD])
done

lemma invariantI: "[| Init(F)\<subseteq>A;  F \<in> stable(A) |] ==> F \<in> invariant(A)"
apply (unfold invariant_def initially_def)
apply (frule stable_type [THEN subsetD], auto)
done

lemma invariantD: "F \<in> invariant(A) ==> Init(F)\<subseteq>A & F \<in> stable(A)"
by (unfold invariant_def initially_def, auto)

lemma invariantD2: "F \<in> invariant(A) ==> F \<in> program & st_set(A)"
apply (unfold invariant_def)
apply (blast dest: stableD2)
done

text\<open>Could also say
      \<^term>\<open>invariant(A) \<inter> invariant(B) \<subseteq> invariant (A \<inter> B)\<close>\<close>
lemma invariant_Int:
  "[| F \<in> invariant(A);  F \<in> invariant(B) |] ==> F \<in> invariant(A \<inter> B)"
apply (unfold invariant_def initially_def)
apply (simp add: stable_Int, blast)
done

subsection\<open>The Elimination Theorem\<close>

(** The "free" m has become universally quantified!
 Should the premise be !!m instead of \<forall>m ? Would make it harder
 to use in forward proof. **)

text\<open>The general case is easier to prove than the special case!\<close>
lemma "elimination":
    "[| \<forall>m \<in> M. F \<in> {s \<in> A. x(s) = m} co B(m); F \<in> program  |]
     ==> F \<in> {s \<in> A. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
by (auto simp add: constrains_def st_set_def, blast)

text\<open>As above, but for the special case of A=state\<close>
lemma elimination2:
     "[| \<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} co B(m); F \<in> program  |]
     ==> F:{s \<in> state. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
by (rule UNITY.elimination, auto)

subsection\<open>The Operator \<^term>\<open>strongest_rhs\<close>\<close>

lemma constrains_strongest_rhs:
    "[| F \<in> program; st_set(A) |] ==> F \<in> A co (strongest_rhs(F,A))"
by (auto simp add: constrains_def strongest_rhs_def st_set_def
              dest: Acts_type [THEN subsetD])

lemma strongest_rhs_is_strongest:
     "[| F \<in> A co B; st_set(B) |] ==> strongest_rhs(F,A) \<subseteq> B"
by (auto simp add: constrains_def strongest_rhs_def st_set_def)

ML \<open>
fun simp_of_act def = def RS @{thm def_act_simp};
fun simp_of_set def = def RS @{thm def_set_simp};
\<close>

end


(* Title:  Pair_Digraph.thy
   Author: Lars Noschinski, TU München
*)

theory Pair_Digraph
imports
  Digraph
  Arc_Walk
begin

section {* Digraphs without Parallel Arcs *}

text {*
  If no parallel arcs are desired, arcs can be accurately described as pairs of
  This is the natural representation for Digraphs without multi-arcs.
  and @{term "head G"}, making it easier to deal with multiple related graphs
  and to modify a graph by adding edges.

  This theory introduces such a specialisation of digraphs.
*}

record 'a pair_pre_digraph = pverts :: "'a set" parcs :: "'a rel"

definition with_proj :: "'a pair_pre_digraph \<Rightarrow> ('a, 'a \<times> 'a) pre_digraph" where
  "with_proj G = \<lparr> verts = pverts G, arcs = parcs G, tail = fst, head = snd \<rparr>"

declare [[coercion with_proj]]

primrec pawalk_verts :: "'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> 'a list" where
  "pawalk_verts u [] = [u]" |
  "pawalk_verts u (e # es) = fst e # pawalk_verts (snd e) es"

fun pcas :: "'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "pcas u [] v = (u = v)" |
  "pcas u (e # es) v = (fst e = u \<and> pcas (snd e) es v)"

lemma with_proj_simps[simp]:
  "verts (with_proj G) = pverts G"
  "arcs (with_proj G) = parcs G"
  "arcs_ends (with_proj G) = parcs G"
  "tail (with_proj G) = fst"
  "head (with_proj G) = snd"
  by (auto simp: with_proj_def arcs_ends_conv)

lemma cas_with_proj_eq: "pre_digraph.cas (with_proj G) = pcas"
proof (unfold fun_eq_iff, intro allI)
  fix u es v show "pre_digraph.cas (with_proj G) u es v = pcas u es v"
    by (induct es arbitrary: u) (auto simp:  pre_digraph.cas.simps)
qed

lemma awalk_verts_with_proj_eq: "pre_digraph.awalk_verts (with_proj G) = pawalk_verts"
proof (unfold fun_eq_iff, intro allI)
  fix u es show "pre_digraph.awalk_verts (with_proj G) u es = pawalk_verts u es"
    by (induct es arbitrary: u) (auto simp: pre_digraph.awalk_verts.simps)
qed

locale pair_pre_digraph = fixes G :: "'a pair_pre_digraph"
begin

lemmas [simp] = cas_with_proj_eq awalk_verts_with_proj_eq

end

locale pair_wf_digraph = pair_pre_digraph +
  assumes arc_fst_in_verts: "\<And>e. e \<in> parcs G \<Longrightarrow> fst e \<in> pverts G"
  assumes arc_snd_in_verts: "\<And>e. e \<in> parcs G \<Longrightarrow> snd e \<in> pverts G"
begin

lemma in_arcsD1: "(u,v) \<in> parcs G \<Longrightarrow> u \<in> pverts G"
  and in_arcsD2: "(u,v) \<in> parcs G \<Longrightarrow> v \<in> pverts G"
  by (auto dest: arc_fst_in_verts arc_snd_in_verts)

lemmas wellformed' = in_arcsD1 in_arcsD2

end

locale pair_fin_digraph = pair_wf_digraph +
  assumes pair_finite_verts: "finite (pverts G)"
    and pair_finite_arcs: "finite (parcs G)"

locale pair_pseudo_graph = pair_fin_digraph  +
  assumes pair_sym_arcs: "symmetric G"

locale pair_digraph = pair_fin_digraph  +
  assumes pair_no_loops: "e \<in> parcs G \<Longrightarrow> fst e \<noteq> snd e"

locale pair_graph = pair_digraph + pair_pseudo_graph

sublocale pair_pre_digraph \<subseteq> pre_digraph "with_proj G"
  where "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales auto

sublocale pair_wf_digraph \<subseteq> wf_digraph "with_proj G"
  where "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales (auto simp: arc_fst_in_verts arc_snd_in_verts)

sublocale pair_fin_digraph \<subseteq> fin_digraph "with_proj G"
  where "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  using pair_finite_verts pair_finite_arcs by unfold_locales auto

sublocale pair_pseudo_graph \<subseteq> pseudo_graph "with_proj G"
  where "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  using pair_sym_arcs by unfold_locales auto

sublocale pair_digraph \<subseteq> digraph "with_proj G"
  where "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  using pair_no_loops by unfold_locales (auto simp: arc_to_ends_def)

sublocale pair_graph \<subseteq> graph "with_proj G"
  where "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales auto

lemma wf_digraph_wp_iff: "wf_digraph (with_proj G) = pair_wf_digraph G" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L then interpret wf_digraph "with_proj G" .
  show ?R using wellformed by unfold_locales auto
next
  assume ?R then interpret pair_wf_digraph G .
  show ?L by unfold_locales
qed

lemma (in pair_fin_digraph) pair_fin_digraph[intro!]: "pair_fin_digraph G" by default

context pair_digraph begin

lemma pair_digraph[intro!]: "pair_digraph G" by default

lemma no_loops':
  "(u,v) \<in> parcs G \<Longrightarrow> u \<noteq> v"
  by (auto dest: no_loops)

end

lemma (in pair_fin_digraph) apath_succ_decomp:
  assumes "apath u p v"
  assumes "(x,y) \<in> set p"
  assumes "y \<noteq> v"
  shows "\<exists>p1 z p2. p = p1 @ (x,y) # (y,z) # p2 \<and> x \<noteq> z \<and> y \<noteq> z"
proof -
  from `(x,y) \<in> set p` obtain p1 p2 where p_decomp: "p = p1 @ (x,y) # p2"
    by (metis (no_types) in_set_conv_decomp_first)
  from p_decomp `apath u p v` `y \<noteq> v` have "p2 \<noteq> []" "awalk y p2 v"
    by (auto simp: apath_def awalk_Cons_iff)
  then obtain z p2' where p2_decomp: "p2 = (y,z) # p2'"
    by atomize_elim (cases p2, auto simp: awalk_Cons_iff)
  then have "x \<noteq> z \<and> y \<noteq> z" using p_decomp p2_decomp `apath u p v`
    by (auto simp: apath_append_iff apath_simps hd_in_awalk_verts)
  with p_decomp p2_decomp have "p = p1 @ (x,y) # (y,z) # p2' \<and> x \<noteq> z \<and> y \<noteq> z"
    by auto
  then show ?thesis by blast
qed

context pair_pseudo_graph begin

lemma pair_pseudo_graph[intro]: "pair_pseudo_graph G" by default

lemma arcs_symmetric:
  "(a,b) \<in> parcs G \<Longrightarrow> (b,a) \<in> parcs G"
  using sym_arcs by (auto simp: symmetric_def elim: symE)

end

lemma (in pair_graph) pair_graph[intro]: "pair_graph G" by default

subsection {* Path reversal for Pair Digraphs *}

text {* This definition is only meaningful in @{term Pair_Digraph} *}

primrec rev_path :: "('a \<times> 'a) awalk \<Rightarrow> ('a \<times> 'a) awalk" where
  "rev_path [] = []" |
  "rev_path (e # es) = rev_path es @ [(snd e, fst e)]"

lemma rev_path_append[simp]: "rev_path (p @ q) = rev_path q @ rev_path p"
  by (induct p) auto

lemma rev_path_rev_path[simp]:
  "rev_path (rev_path p) = p"
  by (induct p) auto

lemma rev_path_empty[simp]:
  "rev_path p = [] \<longleftrightarrow> p = []"
  by (induct p) auto

lemma rev_path_eq: "rev_path p = rev_path q \<longleftrightarrow> p = q"
  by (metis rev_path_rev_path)

lemma (in pair_pseudo_graph)
  assumes "awalk u p v"
  shows awalk_verts_rev_path: "awalk_verts v (rev_path p) = rev (awalk_verts u p)"
    and awalk_rev_path': "awalk v (rev_path p) u"
using assms
proof (induct p arbitrary: u)
  case Nil case 1 then show ?case by auto
next
  case Nil case 2 then show ?case by (auto simp: awalk_Nil_iff)
next
  case (Cons e es) case 1
  with Cons have walks: "awalk v (rev_path es) (snd e)"
        "awalk (snd e) [(snd e, fst e)] u"
      and verts: "awalk_verts v (rev_path es) = rev (awalk_verts (snd e) es)"
    by (auto simp: awalk_simps intro: arcs_symmetric)

  from walks have "awalk v (rev_path es @ [(snd e, fst e)]) u"
    by simp
  moreover
  have "tl (awalk_verts (awlast v (rev_path es)) [(snd e, fst e)]) = [fst e]"
    by auto
  ultimately
  show ?case using 1 verts by (auto simp: awalk_verts_append)
next
  case (Cons e es) case 2
  with Cons have "awalk v (rev_path es) (snd e)"
    by (auto simp: awalk_Cons_iff)
  moreover
  have "rev_path (e # es) = rev_path es @ [(snd e, fst e)]"
    by auto
  moreover
  from Cons 2 have "awalk (snd e) [(snd e, fst e)] u"
    by (auto simp: awalk_simps intro: arcs_symmetric)
  ultimately show "awalk v (rev_path (e # es)) u"
    by simp
qed

lemma (in pair_pseudo_graph) awalk_rev_path[simp]:
  "awalk v (rev_path p) u = awalk u p v" (is "?L = ?R")
by (metis awalk_rev_path' rev_path_rev_path)

lemma (in pair_pseudo_graph) apath_rev_path[simp]:
  "apath v (rev_path p) u = apath u p v"
by (auto simp: awalk_verts_rev_path apath_def)

subsection {* Subdivisions *}

text {* subdivide an arc in araph *}
fun subdivide :: "'a pair_pre_digraph \<Rightarrow> 'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> 'a pair_pre_digraph" where
  "subdivide G (u,v) w = \<lparr>
    pverts = pverts G \<union> {w},
    parcs = (parcs G - {(u,v),(v,u)}) \<union> {(u,w), (w,u), (w, v), (v, w)}\<rparr>"

declare subdivide.simps[simp del]

inductive subdivision :: "'a pair_pre_digraph \<Rightarrow> 'a pair_pre_digraph \<Rightarrow> bool"
  for G where
    base: "subdivision G G"
  | divide: "\<And>e w H. \<lbrakk>e \<in> parcs H; w \<notin> pverts H; subdivision G H\<rbrakk>
      \<Longrightarrow> subdivision G (subdivide H e w)"

text {* subdivide an arc in a path *}
fun sd_path :: "'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> ('a \<times> 'a) awalk" where
    "sd_path _ _ [] = []"
  | "sd_path (u,v) w (e # es) = (if e = (u,v)
                                 then [(u,w),(w,v)]
                                 else if e = (v,u)
                                 then [(v,w),(w,u)]
                                 else [e]) @ sd_path (u,v) w es"

text {* contract an arc in a path  *}
fun co_path :: "'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> ('a \<times> 'a) awalk" where
    "co_path _ _ [] = []"
  | "co_path _ _ [e] = [e]"
  | "co_path (u,v) w (e1 # e2 # es) = (if e1 = (u,w) \<and> e2 = (w,v)
      then (u,v) # co_path (u,v) w es
      else if e1 = (v,w) \<and> e2 = (w,u)
      then (v,u) # co_path (u,v) w es
      else e1 # co_path (u,v) w (e2 # es))"

lemma co_path_simps[simp]:
  "\<lbrakk>e1 \<noteq> (fst e, w); e1 \<noteq> (snd e,w)\<rbrakk> \<Longrightarrow> co_path e w (e1 # es) = e1 # co_path e w es"
  "\<lbrakk>e1 = (fst e, w); e2 = (w, snd e)\<rbrakk> \<Longrightarrow> co_path e w (e1 # e2 # es) = e # co_path e w es"
  "\<lbrakk>e1 = (snd e, w); e2 = (w, fst e)\<rbrakk>
    \<Longrightarrow> co_path e w (e1 # e2 # es) = (snd e, fst e) # co_path e w es"
  "\<lbrakk>e1 \<noteq> (fst e, w) \<or> e2 \<noteq> (w, snd e); e1 \<noteq> (snd e, w) \<or> e2 \<noteq> (w, fst e)\<rbrakk>
    \<Longrightarrow> co_path e w (e1 # e2 # es) = e1 # co_path e w (e2 # es)"
  apply (cases es)
  apply (case_tac [!] e)
  apply (case_tac [!] "fst e = snd e")
  apply auto
  done

lemma co_path_nonempty[simp]: "co_path e w p = [] \<longleftrightarrow> p = []"
  by (cases e) (cases p rule: list_exhaust_NSC, auto)

declare co_path.simps(3)[simp del]

lemma verts_subdivide[simp]: "pverts (subdivide G e w) = pverts G \<union> {w}"
  by (cases e) (auto simp: subdivide.simps)

lemma arcs_subdivide[simp]:
  shows "parcs (subdivide G (u,v) w) = (parcs G - {(u,v),(v,u)}) \<union> {(u,w), (w,u), (w, v), (v, w)}"
  by (auto simp: subdivide.simps)

lemmas subdivide_simps = verts_subdivide arcs_subdivide

lemma sd_path_induct[case_names empty pass sd sdrev]:
  assumes A: "P e []"
    and B: "\<And>e' es. e' \<noteq> e \<Longrightarrow> e' \<noteq> (snd e , fst e) \<Longrightarrow> P e es \<Longrightarrow> P e (e' # es)"
      "\<And>es. P e es \<Longrightarrow> P e (e # es)"
      "\<And>es. fst e \<noteq> snd e \<Longrightarrow> P e es \<Longrightarrow> P e ((snd e, fst e) # es)"
  shows "P e es"
  by (induct es) (rule A, metis B pair_collapse)

lemma co_path_induct[case_names empty single co corev pass]:
  fixes e :: "'a \<times> 'a"
    and w :: "'a"
    and p :: "('a \<times> 'a) awalk"
  assumes Nil: "P e w []"
    and ConsNil:"\<And>e'. P e w [e']"
    and ConsCons1: "\<And>e1 e2 es. e1 = (fst e, w) \<and> e2 = (w, snd e) \<Longrightarrow> P e w es \<Longrightarrow>
            P e w (e1 # e2 # es)"
    and ConsCons2: "\<And>e1 e2 es. \<not>(e1 = (fst e, w) \<and> e2 = (w, snd e)) \<and>
            e1 = (snd e, w) \<and> e2 = (w, fst e) \<Longrightarrow> P e w es \<Longrightarrow>
            P e w (e1 # e2 # es)"
    and ConsCons3: "\<And>e1 e2 es.
            \<not> (e1 = (fst e, w) \<and> e2 = (w, snd e)) \<Longrightarrow>
             \<not> (e1 = (snd e, w) \<and> e2 = (w, fst e)) \<Longrightarrow> P e w (e2 # es) \<Longrightarrow>
            P e w (e1 # e2 # es)"
  shows "P e w p"
proof (induct p rule: length_induct)
  case (1 p) then show ?case
  proof (cases p rule: list_exhaust_NSC)
    case (Cons_Cons e1 e2 es)
    then have "P e w es" "P e w (e2 # es)"using 1 by auto
    then show ?thesis unfolding Cons_Cons by (blast intro: ConsCons1 ConsCons2 ConsCons3)
  qed (auto intro: Nil ConsNil)
qed

lemma co_sd_id:
  assumes "(u,w) \<notin> set p" "(v,w) \<notin> set p"
  shows "co_path (u,v) w (sd_path (u,v) w p) = p"
using assms by (induct p) auto

lemma sd_path_id:
  assumes "(x,y) \<notin> set p" "(y,x) \<notin> set p"
  shows "sd_path (x,y) w p = p"
using assms by (induct p) auto

lemma (in pair_pseudo_graph) pair_pseudo_graph_subdivide:
  assumes props: "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_pseudo_graph (subdivide G e w)" (is "pair_pseudo_graph ?sG")
proof
  obtain u v where [simp]: "e = (u,v)" by (cases e) auto
  {
    show "finite (pverts ?sG)" "finite (parcs ?sG)" by auto
    have "\<And>a b. (a, b) \<in> parcs (subdivide G e w) \<Longrightarrow> (b, a) \<in> parcs (subdivide G e w)"
      unfolding `e = _` arcs_subdivide
      by (elim UnE, rule UnI1, rule_tac [2] UnI2) (blast intro: arcs_symmetric)+
    then show "symmetric ?sG"
      unfolding symmetric_def with_proj_simps by (rule symI)
  next
    fix e' assume "e' \<in> parcs ?sG"
    then show "fst e' \<in> pverts ?sG" "snd e' \<in> pverts ?sG"
      using props by (auto dest: wellformed)
  }
qed

lemma (in pair_graph) pair_graph_subdivide:
  assumes "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_graph (subdivide G e w)" (is "pair_graph ?sG")
proof -
  interpret PPG: pair_pseudo_graph "subdivide G e w"
    using assms by (rule pair_pseudo_graph_subdivide)
  from assms show ?thesis
    by unfold_locales (cases e, auto dest: wellformed no_loops)
qed

lemma (in pair_graph) pair_graph_subdivision:
  assumes "subdivision G H"
  shows "pair_graph H"
using assms
by (induct rule: subdivision.induct) (blast intro: pair_graph.pair_graph_subdivide divide)+

lemma arcs_subdivideD:
  assumes "x \<in> parcs (subdivide G e w)" "fst x \<noteq> w" "snd x \<noteq> w"
  shows "x \<in> parcs G"
using assms by (cases e) auto

context pair_pseudo_graph begin

lemma
  assumes path: "apath u p v"
  assumes elems: "e \<in> parcs G" "w \<notin> pverts G"
  shows apath_sd_path: "pre_digraph.apath (subdivide G e w) u (sd_path e w p) v" (is ?A)
    and set_awalk_verts_sd_path: "set (awalk_verts u (sd_path e w p))
      \<subseteq> set (awalk_verts u p) \<union> {w}" (is ?B)
proof -
  obtain x y where e_conv: "e = (x,y)" by (cases e) auto
  def sG \<equiv> "subdivide G e w"
  interpret S: pair_pseudo_graph sG
    unfolding sG_def using elems by (rule pair_pseudo_graph_subdivide)

  have ev_sG: "S.awalk_verts = awalk_verts"
    by (auto simp: fun_eq_iff pre_digraph.awalk_verts_conv)
  have w_sG: "{(x,w), (y,w), (w,x), (w,y)} \<subseteq> parcs sG"
    by (auto simp: sG_def e_conv)

  from path have "S.apath u (sd_path (x,y) w p) v"
    and "set (S.awalk_verts u (sd_path (x,y) w p)) \<subseteq> set (awalk_verts u p) \<union> {w}"
  proof (induct p arbitrary: u rule: sd_path_induct)
    case empty case 1
    moreover have "pverts sG = pverts G \<union> {w}" by (simp add: sG_def)
    ultimately show ?case by (auto simp: apath_Nil_iff S.apath_Nil_iff)
  next
    case empty case 2 then show ?case by simp
  next
    case (pass e' es)
    { case 1
      then have "S.apath (snd e') (sd_path (x,y) w es) v" "u \<noteq> w" "fst e' = u"
          "u \<notin> set (S.awalk_verts (snd e') (sd_path (x,y) w es))"
        using pass elems by (fastforce simp: apath_Cons_iff)+
      moreover then have "e' \<in> parcs sG"
        using 1 pass by (auto simp: e_conv sG_def S.apath_Cons_iff apath_Cons_iff)
      ultimately show ?case using pass by (auto simp: S.apath_Cons_iff) }
    note case1 = this
    { case 2 with pass 2 show ?case by (simp add: apath_Cons_iff) blast }
  next
    { fix u es a b
      assume A: "apath u ((a,b) # es) v"
        and ab: "(a,b) = (x,y) \<or> (a,b) = (y,x)"
        and hyps: "\<And>u. apath u es v \<Longrightarrow> S.apath u (sd_path (x, y) w es) v"
          "\<And>u. apath u es v \<Longrightarrow> set (awalk_verts u (sd_path (x, y) w es)) \<subseteq> set (awalk_verts u es) \<union> {w}"

      from ab A have "(x,y) \<notin> set es" "(y,x) \<notin> set es"
        by (auto simp: apath_Cons_iff dest!: awalkI_apath dest: awalk_verts_arc1 awalk_verts_arc2)
      then have ev_sd: "set (S.awalk_verts b (sd_path (x,y) w es)) = set (awalk_verts b es)"
        by (simp add: sd_path_id)

      from A ab have [simp]: "x \<noteq> y"
        by (simp add: apath_Cons_iff) (metis awalkI_apath awalk_verts_non_Nil awhd_of_awalk hd_in_set NOMATCH_def)

      from A have "S.apath b (sd_path (x,y) w es) v" "u = a" "u \<noteq> w"
        using ab hyps elems by (auto simp: apath_Cons_iff wellformed')
      moreover
      then have "S.awalk u (sd_path (x, y) w ((a, b) # es)) v "
        using ab w_sG by (auto simp: S.apath_def S.awalk_simps S.wellformed')
      then have "u \<notin> set (S.awalk_verts w ((w,b) # sd_path (x,y) w es))"
        using ab `u \<noteq> w` ev_sd A by (auto simp: apath_Cons_iff S.awalk_def)
      moreover
      have "w \<notin> set (awalk_verts b (sd_path (x, y) w es))"
        using ab ev_sd A elems by (auto simp: awalk_Cons_iff apath_def)
      ultimately
      have path: "S.apath u (sd_path (x, y) w ((a, b) # es)) v "
        using ab hyps w_sG `u = a` by (auto simp: S.apath_Cons_iff ) }
    note path = this
    { case (sd es)
      { case 1 with sd show ?case by (intro path) auto }
      { case 2 show ?case using 2 sd
          by (auto simp: apath_Cons_iff) } }
    { case (sdrev es)
      { case 1 with sdrev show ?case by (intro path) auto }
      { case 2 show ?case using 2 sdrev
          by (auto simp: apath_Cons_iff) } }
  qed
  then show ?A ?B unfolding sG_def e_conv .
qed

lemma
  assumes elems: "e \<in> parcs G" "w \<notin> pverts G" "u \<in> pverts G" "v \<in> pverts G"
  assumes path: "pre_digraph.apath (subdivide G e w) u p v"
  shows apath_co_path: "apath u (co_path e w p) v" (is ?thesis_path)
    and set_awalk_verts_co_path: "set (awalk_verts u (co_path e w p)) = set (awalk_verts u p) - {w}" (is ?thesis_set)
proof -
  obtain x y where e_conv: "e = (x,y)" by (cases e) auto
  interpret S: pair_pseudo_graph "subdivide G e w"
    using elems(1,2) by (rule pair_pseudo_graph_subdivide)

  have e_w: "fst e \<noteq> w" "snd e \<noteq> w" using elems by auto

  have "S.apath u p v" "u \<noteq> w" using elems path by auto
  then have co_path: "apath u (co_path e w p) v
    \<and> set (awalk_verts u (co_path e w p)) = set (awalk_verts u p) - {w}"
  proof (induction p arbitrary: u rule: co_path_induct)
    case empty with elems show ?case
      by (simp add: apath_Nil_iff S.apath_Nil_iff)
  next
    case (single e') with elems show ?case
     by (auto simp: apath_Cons_iff S.apath_Cons_iff apath_Nil_iff S.apath_Nil_iff
        dest: arcs_subdivideD)
  next
    case (co e1 e2 es)
    then have "apath u (co_path e w (e1 # e2 # es)) v" using co e_w elems
      by (auto simp: apath_Cons_iff S.apath_Cons_iff)
    moreover
    have "set (awalk_verts u (co_path e w (e1 # e2 # es))) = set (awalk_verts u (e1 # e2 # es)) - {w}"
      using co e_w by (auto simp: apath_Cons_iff S.apath_Cons_iff)
    ultimately
    show ?case by fast
  next
    case (corev e1 e2 es)
    have "apath u (co_path e w (e1 # e2 # es)) v" using corev(1-3) e_w(1) elems(1)
      by (auto simp: apath_Cons_iff S.apath_Cons_iff  intro: arcs_symmetric)
    moreover
    have "set (awalk_verts u (co_path e w (e1 # e2 # es))) = set (awalk_verts u (e1 # e2 # es)) - {w}"
      using corev e_w by (auto simp: apath_Cons_iff S.apath_Cons_iff)
    ultimately
    show ?case by fast
  next
    case (pass e1 e2 es)
    have "fst e1 \<noteq> w" using elems pass.prems by (auto simp: S.apath_Cons_iff)
    have "snd e1 \<noteq> w"
    proof
      assume "snd e1 = w"
      then have "e1 \<notin> parcs G" using elems by auto
      then have "e1 \<in> parcs (subdivide G e w) - parcs G"
        using pass by (auto simp: S.apath_Cons_iff)
      then have "e1 = (x,w) \<or> e1 = (y,w)"
        using `fst e1 \<noteq> w` e_w by (auto simp add: e_conv)
      moreover
      have "fst e2 = w" using `snd e1 = w` pass.prems by (auto simp: S.apath_Cons_iff)
      then have "e2 \<notin> parcs G" using elems by auto
      then have "e2 \<in> parcs (subdivide G e w) - parcs G"
        using pass by (auto simp: S.apath_Cons_iff)
      then have "e2 = (w,x) \<or> e2 = (w,y)"
        using `fst e2 = w` e_w by (cases e2) (auto simp add: e_conv)
      ultimately
      have "e1 = (x,w) \<and> e2 = (w,x) \<or> e1 = (y,w) \<and> e2 = (w,y)"
        using pass.hyps[simplified e_conv] by auto
      then show False
        using pass.prems by (cases es) (auto simp: S.apath_Cons_iff)
    qed
    then have "e1 \<in> parcs G"
      using `fst e1 \<noteq> w` pass.prems by (auto simp: S.apath_Cons_iff dest: arcs_subdivideD)

    have ih: "apath (snd e1) (co_path e w (e2 # es)) v \<and> set (awalk_verts (snd e1) (co_path e w (e2 # es))) = set (awalk_verts (snd e1) (e2 # es)) - {w}"
      using pass.prems `snd e1 \<noteq> w` by (intro pass.IH) (auto simp: apath_Cons_iff S.apath_Cons_iff)
    then have "fst e1 \<notin> set (awalk_verts (snd e1) (co_path e w (e2 # es)))" "fst e1 = u"
      using pass.prems by (clarsimp simp: S.apath_Cons_iff)+
    then have "apath u (co_path e w (e1 # e2 # es)) v"
      using ih pass `e1 \<in> parcs G` by (auto simp: apath_Cons_iff S.apath_Cons_iff)[]
    moreover
    have "set (awalk_verts u (co_path e w (e1 # e2 # es))) = set (awalk_verts u (e1 # e2 # es)) - {w}"
      using pass.hyps ih `fst e1 \<noteq> w` by auto
    ultimately show ?case by fast
  qed
  then show ?thesis_set ?thesis_path by blast+
qed

end

end


theory Worklist
imports "~~/src/HOL/Library/While_Combinator" RTranCl Quasi_Order
begin

definition
  worklist_aux :: "('s \<Rightarrow> 'a \<Rightarrow> 'a list) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 's)
    \<Rightarrow> 'a list * 's \<Rightarrow> ('a list * 's)option"
where
"worklist_aux succs f =
 while_option
   (%(ws,s). ws \<noteq> [])
   (%(ws,s). case ws of x#ws' \<Rightarrow> (succs s x @ ws', f x s))"

definition worklist :: "('s \<Rightarrow> 'a \<Rightarrow> 'a list) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 's)
    \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 's option" where
"worklist succs f ws s =
  (case worklist_aux succs f (ws,s) of
     None \<Rightarrow> None | Some(ws,s) \<Rightarrow> Some s)"

lemma worklist_aux_Nil: "worklist_aux succs f ([],s) = Some([],s)"
by(simp add: worklist_aux_def while_option_unfold)

lemma worklist_aux_Cons:
 "worklist_aux succs f (x#ws',s) = worklist_aux succs f (succs s x @ ws', f x s)"
by(simp add: worklist_aux_def while_option_unfold)

lemma worklist_aux_unfold[code]:
 "worklist_aux succs f (ws,s) =
 (case ws of [] \<Rightarrow> Some([],s)
  | x#ws' \<Rightarrow> worklist_aux succs f (succs s x @ ws', f x s))"
by(simp add: worklist_aux_Nil worklist_aux_Cons split: list.split)

definition
  worklist_tree_aux :: "('a \<Rightarrow> 'a list) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 's)
    \<Rightarrow> 'a list * 's \<Rightarrow> ('a list * 's)option"
where
"worklist_tree_aux succs = worklist_aux (%s. succs)"

lemma worklist_tree_aux_unfold[code]:
"worklist_tree_aux succs f (ws,s) =
 (case ws of [] \<Rightarrow> Some([],s) |
  x#ws' \<Rightarrow> worklist_tree_aux succs f (succs x @ ws', f x s))"
by(simp add: worklist_tree_aux_def worklist_aux_Nil worklist_aux_Cons split: list.split)

abbreviation Rel :: "('a \<Rightarrow> 'a list) \<Rightarrow> ('a * 'a)set" where
"Rel f == {(x,y). y : set(f x)}"

lemma Image_Rel_set:
  "(Rel succs)^* `` set(succs x) = (Rel succs)^+ `` {x}"
by(auto simp add: trancl_unfold_left)

lemma RTranCl_conv:
  "g [succs]\<rightarrow>* h \<longleftrightarrow> (g,h) : ((Rel succs)^*)" (is "?L = ?R")
proof-
  have "?L \<Longrightarrow> ?R"
    apply(erule RTranCl_induct)
    apply blast
    apply (auto elim: rtrancl_into_rtrancl)
    done
  moreover
  have "?R \<Longrightarrow> ?L"
    apply(erule converse_rtrancl_induct)
    apply(rule RTranCl.refl)
    apply (auto elim: RTranCl.succs)
    done
  ultimately show ?thesis by blast
qed

lemma worklist_end_empty:
  "worklist_aux succs f (ws,s) = Some(ws',s') \<Longrightarrow> ws' = []"
unfolding worklist_aux_def
by (drule while_option_stop) simp

theorem worklist_tree_aux_Some_foldl:
assumes "worklist_tree_aux succs f (ws,s) = Some(ws',s')"
shows "EX rs. set rs = ((Rel succs)^*) `` (set ws) &
              s' = foldl (%s x. f x s) s rs"
proof -
  let ?b = "%(ws,s). ws \<noteq> []"
  let ?c = "%(ws,s). case ws of x#ws' \<Rightarrow> (succs x @ ws', f x s)"
  let ?Q = "% ws' s' done.
    s' = foldl (%x s. f s x) s done &
      ((Rel succs)^*) `` (set ws) =
          set done Un ((Rel succs)^*) `` set ws'"
  let ?P = "%(ws,s). EX done. ?Q ws s done"
  have 0: "while_option ?b ?c (ws,s) = Some(ws',s')"
    using assms by(simp add: worklist_tree_aux_def worklist_aux_def)
  from while_option_stop[OF 0] have "ws' = []" by simp
  have init: "?P (ws,s)"
    apply auto
    apply(rule_tac x = "[]" in exI)
    apply simp
    done
  { fix ws s
    assume "?P (ws,s)"
    then obtain "done" where "?Q ws s done" by blast
    assume "?b(ws,s)"
    then obtain x ws' where "ws = x # ws'" by(auto simp: neq_Nil_conv)
    then have "?Q (succs x @ ws') (f x s) (done @ [x])"
      using `?Q ws s done`
      apply simp
      apply(erule thin_rl)+
      apply (auto simp add: Image_Un Image_Rel_set)
      apply (blast elim: rtranclE intro: rtrancl_into_trancl1)
      done
    hence "?P(?c(ws,s))" using `ws=x#ws'`
      by(simp only: split_conv list.cases) blast
  }
  then have "?P(ws',s')"
    using while_option_rule[where P="?P", OF _ 0 init]
    by auto
  then show ?thesis using `ws'=[]` by auto
qed

definition "worklist_tree succs f ws s =
  (case worklist_tree_aux succs f (ws,s) of
     None \<Rightarrow> None | Some(ws,s) \<Rightarrow> Some s)"

theorem worklist_tree_Some_foldl:
  "worklist_tree succs f ws s = Some s' \<Longrightarrow>
   EX rs. set rs = ((Rel succs)^*) `` (set ws) &
              s' = foldl (%s x. f x s) s rs"
by(simp add: worklist_tree_def worklist_tree_aux_Some_foldl split:option.splits prod.splits)

lemma invariant_succs:
assumes "invariant I succs"
and "ALL x:S. I x"
shows "ALL x: (Rel succs)^* `` S. I x"
proof-
  { fix x y have "(x,y) : (Rel succs)^* \<Longrightarrow> I x \<Longrightarrow> I y"
    proof(induct rule:rtrancl_induct)
      case base thus ?case .
    next
      case step with assms(1) show ?case by(auto simp:invariant_def)
    qed
  } with assms(2) show ?thesis by blast
qed

lemma worklist_tree_aux_rule:
assumes "worklist_tree_aux succs f (ws,s) = Some(ws',s')"
and "invariant I succs"
and "ALL x : set ws. I x"
and "!!s. P [] s s"
and "!!r x ws s. I x \<Longrightarrow> \<forall>x \<in> set ws. I x \<Longrightarrow> P ws (f x s) r \<Longrightarrow> P (x#ws) s r"
shows "\<exists>rs. set rs = ((Rel succs)^* ) `` (set ws) \<and> P rs s s'"
proof-
  let ?R = "(Rel succs)\<^sup>* `` set ws"
  from worklist_tree_aux_Some_foldl[OF assms(1)] obtain rs where
    rs: "set rs = ?R" "s' = foldl (%s x. f x s) s rs" by blast
  { fix xs have "(ALL x : set xs. I x) \<Longrightarrow> P xs s (foldl (%s x. f x s) s xs)"
    proof(induct xs arbitrary: s)
      case Nil show ?case using assms(4) by simp
    next
      case Cons thus ?case using assms(5) by simp
    qed
  }
  with invariant_succs[OF assms(2,3)] show ?thesis by (metis rs)
qed

lemma worklist_tree_aux_rule2:
assumes "worklist_tree_aux succs f (ws,s) = Some(ws',s')"
and "invariant I succs"
and "ALL x : set ws. I x"
and "S s" and "!!x s. I x \<Longrightarrow> S s \<Longrightarrow> S(f x s)"
and "!!s. P [] s s"
and "!!r x ws s. I x \<Longrightarrow> \<forall>x \<in> set ws. I x \<Longrightarrow> S s
  \<Longrightarrow> P ws (f x s) r \<Longrightarrow> P (x#ws) s r"
shows "\<exists>rs. set rs = ((Rel succs)^* ) `` (set ws) \<and> P rs s s'"
proof-
  let ?R = "(Rel succs)\<^sup>* `` set ws"
  from worklist_tree_aux_Some_foldl[OF assms(1)] obtain rs where
    rs: "set rs = ?R" "s' = foldl (%s x. f x s) s rs" by blast
  { fix xs have "(ALL x : set xs. I x) \<Longrightarrow> S s \<Longrightarrow> P xs s (foldl (%s x. f x s) s xs)"
    proof(induct xs arbitrary: s)
      case Nil show ?case using assms(6) by simp
    next
      case Cons thus ?case using assms(5,7) by simp
    qed
  }
  with invariant_succs[OF assms(2,3)] assms(4) show ?thesis by (metis rs)
qed

lemma worklist_tree_rule:
assumes "worklist_tree succs f ws s = Some(s')"
and "invariant I succs"
and "ALL x : set ws. I x"
and "!!s. P [] s s"
and "!!r x ws s. I x \<Longrightarrow> \<forall>x \<in> set ws. I x \<Longrightarrow> P ws (f x s) r \<Longrightarrow> P (x#ws) s r"
shows "EX rs. set rs = ((Rel succs)^*) `` (set ws) \<and> P rs s s'"
proof-
  obtain ws' where "worklist_tree_aux succs f (ws,s) = Some(ws',s')" using assms(1)
    by(simp add: worklist_tree_def split: option.split_asm prod.split_asm)
  from worklist_tree_aux_rule[where P=P,OF this assms(2-5)] show ?thesis by blast
qed

lemma worklist_tree_rule2:
assumes "worklist_tree succs f ws s = Some(s')"
and "invariant I succs"
and "ALL x : set ws. I x"
and "S s" and "!!x s. I x \<Longrightarrow> S s \<Longrightarrow> S(f x s)"
and "!!s. P [] s s"
and "!!r x ws s. I x \<Longrightarrow> \<forall>x \<in> set ws. I x \<Longrightarrow> S s
  \<Longrightarrow> P ws (f x s) r \<Longrightarrow> P (x#ws) s r"
shows "EX rs. set rs = ((Rel succs)^*) `` (set ws) \<and> P rs s s'"
proof-
  obtain ws' where "worklist_tree_aux succs f (ws,s) = Some(ws',s')" using assms(1)
    by(simp add: worklist_tree_def split: option.split_asm prod.split_asm)
  from worklist_tree_aux_rule2[where P=P and S=S,OF this assms(2-7)]
  show ?thesis by blast
qed

lemma worklist_tree_aux_state_inv:
assumes "worklist_tree_aux succs f (ws,s) = Some(ws',s')"
and "I s"
and "!!x s. I s \<Longrightarrow> I(f x s)"
shows "I s'"
proof-
  from worklist_tree_aux_rule[where P="%ws s s'. I s \<longrightarrow> I s'" and I="%x. True",
    OF assms(1)] assms(2-3)
  show ?thesis by(auto simp: invariant_def)
qed

lemma worklist_tree_state_inv:
  "worklist_tree succs f ws s = Some(s')
   \<Longrightarrow> I s \<Longrightarrow> (!!x s. I s \<Longrightarrow> I(f x s)) \<Longrightarrow> I s'"
unfolding worklist_tree_def
by(auto intro: worklist_tree_aux_state_inv split: option.splits)

locale set_modulo = quasi_order +
fixes empty :: "'s"
and insert_mod :: "'a => 's => 's"
and set_of :: "'s => 'a set"
and I :: "'a => bool"
and S :: "'s => bool"
assumes set_of_empty: "set_of empty = {}"
and set_of_insert_mod: "I x \<Longrightarrow> S s \<and> (\<forall>x \<in> set_of s. I x)
  \<Longrightarrow>
  set_of(insert_mod x s) = insert x (set_of s) \<or>
  (EX y : set_of s. x \<preceq> y) \<and> set_of (insert_mod x s) = set_of s"
and S_empty: "S empty"
and S_insert_mod: "S s \<Longrightarrow> S (insert_mod x s)"
begin

definition insert_mod2 :: "('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 's \<Rightarrow> 's" where
"insert_mod2 P f x s = (if P x then insert_mod (f x) s else s)"

definition "SI s = (S s \<and> (\<forall>x \<in> set_of s. I x))"

lemma SI_empty: "SI empty"
by(simp add: SI_def S_empty set_of_empty)

lemma SI_insert_mod:
  "I x \<Longrightarrow> SI s \<Longrightarrow> SI (insert_mod x s)"
apply(simp add: SI_def S_insert_mod)
by (metis insertE set_of_insert_mod)

lemma SI_insert_mod2: "(!!x. inv0 x \<Longrightarrow> I (f x)) \<Longrightarrow>
  inv0 x \<Longrightarrow> SI s \<Longrightarrow> SI (insert_mod2 P f x s)"
by (metis insert_mod2_def SI_insert_mod)

definition worklist_tree_coll_aux ::
  "('b \<Rightarrow> 'b list) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 's \<Rightarrow> 's option"
where
"worklist_tree_coll_aux succs P f = worklist_tree succs (insert_mod2 P f)"

definition worklist_tree_coll ::
  "('b \<Rightarrow> 'b list) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 's option"
where
"worklist_tree_coll succs P f ws = worklist_tree_coll_aux succs P f ws empty"

lemma worklist_tree_coll_aux_equiv:
assumes "worklist_tree_coll_aux succs P f ws s = Some s'"
and "invariant inv0 succs"
and "\<forall>x \<in> set ws. inv0 x"
and "!!x. inv0 x \<Longrightarrow> I(f x)"
and "SI s"
shows "set_of s' =\<^sub>\<preceq>
  f ` {x : (Rel succs)^* `` (set ws). P x} \<union> set_of s"
apply(insert assms(1))
unfolding worklist_tree_coll_aux_def
apply(drule worklist_tree_rule2[where I = inv0 and S = SI and
  P = "%ws s s'. SI s \<longrightarrow> set_of s' =\<^sub>\<preceq> f ` {x : set ws. P x} Un set_of s",
  OF _ assms(2,3,5)])
   apply(simp add: SI_insert_mod2 assms(4))
  apply(clarsimp)
 apply(clarsimp simp add: insert_mod2_def split: split_if_asm)
  apply(frule assms(4))
  apply(frule SI_def[THEN iffD1])
  apply(frule (1) set_of_insert_mod)
  apply (simp add: SI_insert_mod)
  apply(erule disjE)
   prefer 2
   apply(rule seteq_qle_trans)
    apply assumption
   apply (simp add: "defs")
   apply blast
  apply(rule seteq_qle_trans)
   apply assumption
  apply (simp add: "defs")
  apply blast
 apply(rule seteq_qle_trans)
  apply assumption
 apply (simp add: "defs")
 apply blast
using assms(5)
apply auto
done

lemma worklist_tree_coll_equiv:
  "worklist_tree_coll succs P f ws = Some s' \<Longrightarrow> invariant inv0 succs
   \<Longrightarrow> \<forall>x \<in> set ws. inv0 x \<Longrightarrow> (!!x. inv0 x \<Longrightarrow> I(f x))
   \<Longrightarrow> set_of s' =\<^sub>\<preceq> f ` {x : (Rel succs)^* `` (set ws). P x}"
unfolding worklist_tree_coll_def
apply(drule (2) worklist_tree_coll_aux_equiv)
apply(auto simp: set_of_empty SI_empty)
done

lemma worklist_tree_coll_aux_subseteq:
  "worklist_tree_coll_aux succs P f ws t\<^sub>0 = Some t \<Longrightarrow>
  invariant inv0 succs \<Longrightarrow>  ALL g : set ws. inv0 g \<Longrightarrow>
  (!!x. inv0 x \<Longrightarrow> I(f x)) \<Longrightarrow> SI t\<^sub>0 \<Longrightarrow>
  set_of t \<subseteq> set_of t\<^sub>0 \<union> f ` {h : (Rel succs)^* `` set ws. P h}"
unfolding worklist_tree_coll_aux_def
apply(drule worklist_tree_rule2[where I = inv0 and S = SI and P =
  "%ws t t'. set_of t' \<subseteq> set_of t \<union> f ` {g \<in> set ws. P g}"])
      apply assumption
     apply assumption
    apply assumption
   apply(simp add: SI_insert_mod2)
  apply clarsimp
 apply (clarsimp simp: insert_mod2_def split: split_if_asm)
  using set_of_insert_mod
  apply(simp add: SI_def image_def)
  apply(blast)
 apply blast
apply blast
done

lemma worklist_tree_coll_subseteq:
  "worklist_tree_coll succs P f ws = Some t \<Longrightarrow>
  invariant inv0 succs \<Longrightarrow>  ALL g : set ws. inv0 g \<Longrightarrow>
  (!!x. inv0 x \<Longrightarrow> I(f x)) \<Longrightarrow>
  set_of t \<subseteq> f ` {h : (Rel succs)^* `` set ws. P h}"
unfolding worklist_tree_coll_def
apply(drule (1) worklist_tree_coll_aux_subseteq)
apply(auto simp: set_of_empty SI_empty)
done

lemma worklist_tree_coll_inv:
  "worklist_tree_coll succs P f ws = Some s \<Longrightarrow> S s"
unfolding worklist_tree_coll_def worklist_tree_coll_aux_def
apply(drule worklist_tree_state_inv[where I = S])
apply (auto simp: S_empty insert_mod2_def S_insert_mod)
done

end

end