section \<open>Error monad\<close>

theory Error_Monad
imports Monad_Plus
begin

subsection \<open>Type definition\<close>

tycondef 'a\<cdot>'e error = Err (lazy "'e") | Ok (lazy "'a")

lemma coerce_error_abs [simp]: "coerce\<cdot>(error_abs\<cdot>x) = error_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: error_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_error)
done

lemma coerce_Err [simp]: "coerce\<cdot>(Err\<cdot>x) = Err\<cdot>(coerce\<cdot>x)"
unfolding Err_def by simp

lemma coerce_Ok [simp]: "coerce\<cdot>(Ok\<cdot>m) = Ok\<cdot>(coerce\<cdot>m)"
unfolding Ok_def by simp

lemma fmapU_error_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>'a error) = \<bottom>"
  "fmapU\<cdot>f\<cdot>(Err\<cdot>e) = Err\<cdot>e"
  "fmapU\<cdot>f\<cdot>(Ok\<cdot>x) = Ok\<cdot>(f\<cdot>x)"
unfolding fmapU_error_def error_map_def fix_const
apply simp
apply (simp add: Err_def)
apply (simp add: Ok_def)
done

subsection \<open>Monad class instance\<close>

instantiation error :: ("domain") "{monad, functor_plus}"
begin

definition
  "returnU = Ok"

fixrec bindU_error :: "udom\<cdot>'a error \<rightarrow> (udom \<rightarrow> udom\<cdot>'a error) \<rightarrow> udom\<cdot>'a error"
  where "bindU_error\<cdot>(Err\<cdot>e)\<cdot>f = Err\<cdot>e"
  | "bindU_error\<cdot>(Ok\<cdot>x)\<cdot>f = f\<cdot>x"

lemma bindU_error_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>'a error)"
by fixrec_simp

fixrec plusU_error :: "udom\<cdot>'a error \<rightarrow> udom\<cdot>'a error \<rightarrow> udom\<cdot>'a error"
  where "plusU_error\<cdot>(Err\<cdot>e)\<cdot>f = f"
  | "plusU_error\<cdot>(Ok\<cdot>x)\<cdot>f = Ok\<cdot>x"

lemma plusU_error_strict [simp]: "plusU\<cdot>(\<bottom> :: udom\<cdot>'a error) = \<bottom>"
by fixrec_simp

instance proof
  fix f g :: "udom \<rightarrow> udom" and r :: "udom\<cdot>'a error"
  show "fmapU\<cdot>f\<cdot>(fmapU\<cdot>g\<cdot>r) = fmapU\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>r"
    by (induct r rule: error.induct) simp_all
next
  fix f :: "udom \<rightarrow> udom" and r :: "udom\<cdot>'a error"
  show "fmapU\<cdot>f\<cdot>r = bindU\<cdot>r\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct r rule: error.induct)
       (simp_all add: returnU_error_def)
next
  fix f :: "udom \<rightarrow> udom\<cdot>'a error" and x :: "udom"
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>f = f\<cdot>x"
    by (simp add: returnU_error_def)
next
  fix r :: "udom\<cdot>'a error" and f g :: "udom \<rightarrow> udom\<cdot>'a error"
  show "bindU\<cdot>(bindU\<cdot>r\<cdot>f)\<cdot>g = bindU\<cdot>r\<cdot>(\<Lambda> x. bindU\<cdot>(f\<cdot>x)\<cdot>g)"
    by (induct r rule: error.induct)
       simp_all
next
  fix f :: "udom \<rightarrow> udom" and a b :: "udom\<cdot>'a error"
  show "fmapU\<cdot>f\<cdot>(plusU\<cdot>a\<cdot>b) = plusU\<cdot>(fmapU\<cdot>f\<cdot>a)\<cdot>(fmapU\<cdot>f\<cdot>b)"
    by (induct a rule: error.induct) simp_all
next
  fix a b c :: "udom\<cdot>'a error"
  show "plusU\<cdot>(plusU\<cdot>a\<cdot>b)\<cdot>c = plusU\<cdot>a\<cdot>(plusU\<cdot>b\<cdot>c)"
    by (induct a rule: error.induct) simp_all
qed

end

subsection \<open>Transfer properties to polymorphic versions\<close>

lemma fmap_error_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>'e error) = \<bottom>"
  "fmap\<cdot>f\<cdot>(Err\<cdot>e :: 'a\<cdot>'e error) = Err\<cdot>e"
  "fmap\<cdot>f\<cdot>(Ok\<cdot>x :: 'a\<cdot>'e error) = Ok\<cdot>(f\<cdot>x)"
unfolding fmap_def [where 'f="'e error"]
by (simp_all add: coerce_simp)

lemma return_error_def: "return = Ok"
unfolding return_def returnU_error_def
by (simp add: coerce_simp eta_cfun)

lemma bind_error_simps [simp]:
  "bind\<cdot>(\<bottom> :: 'a\<cdot>'e error)\<cdot>f = \<bottom>"
  "bind\<cdot>(Err\<cdot>e :: 'a\<cdot>'e error)\<cdot>f = Err\<cdot>e"
  "bind\<cdot>(Ok\<cdot>x :: 'a\<cdot>'e error)\<cdot>f = f\<cdot>x"
unfolding bind_def
by (simp_all add: coerce_simp)

lemma join_error_simps [simp]:
  "join\<cdot>\<bottom> = (\<bottom> :: 'a\<cdot>'e error)"
  "join\<cdot>(Err\<cdot>e) = Err\<cdot>e"
  "join\<cdot>(Ok\<cdot>x) = x"
unfolding join_def by simp_all

lemma fplus_error_simps [simp]:
  "fplus\<cdot>\<bottom>\<cdot>r = (\<bottom> :: 'a\<cdot>'e error)"
  "fplus\<cdot>(Err\<cdot>e)\<cdot>r = r"
  "fplus\<cdot>(Ok\<cdot>x)\<cdot>r = Ok\<cdot>x"
unfolding fplus_def
by (simp_all add: coerce_simp)

end


(*
  File:         PAC_Checker_Relation.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory PAC_Checker_Relation
  imports PAC_Checker WB_Sort "Native_Word.Uint64"
begin

section \<open>Various Refinement Relations\<close>

text \<open>When writing this, it was not possible to share the definition with the IsaSAT version.\<close>
definition uint64_nat_rel :: "(uint64 \<times> nat) set" where
 \<open>uint64_nat_rel = br nat_of_uint64 (\<lambda>_. True)\<close>

abbreviation uint64_nat_assn where
  \<open>uint64_nat_assn \<equiv> pure uint64_nat_rel\<close>

instantiation uint32 :: hashable
begin
definition hashcode_uint32 :: \<open>uint32 \<Rightarrow> uint32\<close> where
  \<open>hashcode_uint32 n = n\<close>

definition def_hashmap_size_uint32 :: \<open>uint32 itself \<Rightarrow> nat\<close> where
  \<open>def_hashmap_size_uint32 = (\<lambda>_. 16)\<close>
  \<comment> \<open>same as @{typ nat}\<close>
instance
  by standard (simp add: def_hashmap_size_uint32_def)
end

instantiation uint64 :: hashable
begin
definition hashcode_uint64 :: \<open>uint64 \<Rightarrow> uint32\<close> where
  \<open>hashcode_uint64 n = (uint32_of_nat (nat_of_uint64 ((n) AND ((2 :: uint64)^32 -1))))\<close>

definition def_hashmap_size_uint64 :: \<open>uint64 itself \<Rightarrow> nat\<close> where
  \<open>def_hashmap_size_uint64 = (\<lambda>_. 16)\<close>
  \<comment> \<open>same as @{typ nat}\<close>
instance
  by standard (simp add: def_hashmap_size_uint64_def)
end

lemma word_nat_of_uint64_Rep_inject[simp]: \<open>nat_of_uint64 ai = nat_of_uint64 bi \<longleftrightarrow> ai = bi\<close>
  by transfer (simp add: word_unat_eq_iff)

instance uint64 :: heap
  by standard (auto simp: inj_def exI[of _ nat_of_uint64])

instance uint64 :: semiring_numeral
  by standard

lemma nat_of_uint64_012[simp]: \<open>nat_of_uint64 0 = 0\<close> \<open>nat_of_uint64 2 = 2\<close> \<open>nat_of_uint64 1 = 1\<close>
  by (transfer, auto)+

definition uint64_of_nat_conv where
  [simp]: \<open>uint64_of_nat_conv (x :: nat) = x\<close>

lemma less_upper_bintrunc_id: \<open>n < 2 ^b \<Longrightarrow> n \<ge> 0 \<Longrightarrow> take_bit b n = n\<close> for n :: int
  by (rule take_bit_int_eq_self)

lemma nat_of_uint64_uint64_of_nat_id: \<open>n < 2^64 \<Longrightarrow> nat_of_uint64 (uint64_of_nat n) = n\<close>
  unfolding uint64_of_nat_def
  apply simp
  apply transfer
  apply (subst unat_eq_nat_uint)
  apply transfer
  by (auto simp: less_upper_bintrunc_id)

lemma [sepref_fr_rules]:
  \<open>(return o uint64_of_nat, RETURN o uint64_of_nat_conv) \<in> [\<lambda>a. a < 2 ^64]\<^sub>a nat_assn\<^sup>k \<rightarrow> uint64_nat_assn\<close>
  by sepref_to_hoare
   (sep_auto simp: uint64_nat_rel_def br_def nat_of_uint64_uint64_of_nat_id)

definition string_rel :: \<open>(String.literal \<times> string) set\<close> where
  \<open>string_rel = {(x, y). y = String.explode x}\<close>

abbreviation string_assn :: \<open>string \<Rightarrow> String.literal \<Rightarrow> assn\<close> where
  \<open>string_assn \<equiv> pure string_rel\<close>

lemma eq_string_eq:
  \<open>((=), (=)) \<in> string_rel \<rightarrow> string_rel \<rightarrow> bool_rel\<close>
 by (auto intro!: frefI simp: string_rel_def String.less_literal_def
    less_than_char_def rel2p_def literal.explode_inject)

lemmas eq_string_eq_hnr =
   eq_string_eq[sepref_import_param]

definition string2_rel :: \<open>(string \<times> string) set\<close> where
  \<open>string2_rel \<equiv> \<langle>Id\<rangle>list_rel\<close>

abbreviation string2_assn :: \<open>string \<Rightarrow> string \<Rightarrow> assn\<close> where
  \<open>string2_assn \<equiv> pure string2_rel\<close>

abbreviation monom_rel where
  \<open>monom_rel \<equiv> \<langle>string_rel\<rangle>list_rel\<close>

abbreviation monom_assn where
  \<open>monom_assn \<equiv> list_assn string_assn\<close>

abbreviation monomial_rel where
  \<open>monomial_rel \<equiv> monom_rel \<times>\<^sub>r int_rel\<close>

abbreviation monomial_assn where
  \<open>monomial_assn \<equiv> monom_assn \<times>\<^sub>a int_assn\<close>

abbreviation poly_rel where
  \<open>poly_rel \<equiv> \<langle>monomial_rel\<rangle>list_rel\<close>

abbreviation poly_assn where
  \<open>poly_assn \<equiv> list_assn monomial_assn\<close>

lemma poly_assn_alt_def:
  \<open>poly_assn = pure poly_rel\<close>
  by (simp add: list_assn_pure_conv)

abbreviation polys_assn where
  \<open>polys_assn \<equiv> hm_fmap_assn uint64_nat_assn poly_assn\<close>

lemma string_rel_string_assn:
  \<open>(\<up> ((c, a) \<in> string_rel)) = string_assn a c\<close>
  by (auto simp: pure_app_eq)

lemma single_valued_string_rel:
   \<open>single_valued string_rel\<close>
   by (auto simp: single_valued_def string_rel_def)

lemma IS_LEFT_UNIQUE_string_rel:
   \<open>IS_LEFT_UNIQUE string_rel\<close>
   by (auto simp: IS_LEFT_UNIQUE_def single_valued_def string_rel_def
     literal.explode_inject)

lemma IS_RIGHT_UNIQUE_string_rel:
   \<open>IS_RIGHT_UNIQUE string_rel\<close>
   by (auto simp: single_valued_def string_rel_def
     literal.explode_inject)

lemma single_valued_monom_rel: \<open>single_valued monom_rel\<close>
  by (rule list_rel_sv)
    (auto intro!: frefI simp: string_rel_def
    rel2p_def single_valued_def p2rel_def)

lemma single_valued_monomial_rel:
  \<open>single_valued monomial_rel\<close>
  using single_valued_monom_rel
  by (auto intro!: frefI simp:
    rel2p_def single_valued_def p2rel_def)

lemma single_valued_monom_rel': \<open>IS_LEFT_UNIQUE monom_rel\<close>
  unfolding IS_LEFT_UNIQUE_def inv_list_rel_eq string2_rel_def
  by (rule list_rel_sv)+
   (auto intro!: frefI simp: string_rel_def
    rel2p_def single_valued_def p2rel_def literal.explode_inject)

lemma single_valued_monomial_rel':
  \<open>IS_LEFT_UNIQUE monomial_rel\<close>
  using single_valued_monom_rel'
  unfolding IS_LEFT_UNIQUE_def inv_list_rel_eq
  by (auto intro!: frefI simp:
    rel2p_def single_valued_def p2rel_def)

lemma [safe_constraint_rules]:
  \<open>Sepref_Constraints.CONSTRAINT single_valued string_rel\<close>
  \<open>Sepref_Constraints.CONSTRAINT IS_LEFT_UNIQUE string_rel\<close>
  by (auto simp: CONSTRAINT_def single_valued_def
    string_rel_def IS_LEFT_UNIQUE_def literal.explode_inject)

lemma eq_string_monom_hnr[sepref_fr_rules]:
  \<open>(uncurry (return oo (=)), uncurry (RETURN oo (=))) \<in> monom_assn\<^sup>k *\<^sub>a monom_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
  using single_valued_monom_rel' single_valued_monom_rel
  unfolding list_assn_pure_conv
  by sepref_to_hoare
   (sep_auto simp: list_assn_pure_conv string_rel_string_assn
       single_valued_def IS_LEFT_UNIQUE_def
     dest!: mod_starD
     simp flip: inv_list_rel_eq)

definition term_order_rel' where
  [simp]: \<open>term_order_rel' x y = ((x, y) \<in> term_order_rel)\<close>

lemma term_order_rel[def_pat_rules]:
  \<open>(\<in>)$(x,y)$term_order_rel \<equiv> term_order_rel'$x$y\<close>
  by auto

lemma term_order_rel_alt_def:
  \<open>term_order_rel = lexord (p2rel char.lexordp)\<close>
  by (auto simp: p2rel_def char.lexordp_conv_lexord var_order_rel_def intro!: arg_cong[of _ _ lexord])

instantiation char :: linorder
begin
  definition less_char where [symmetric, simp]: "less_char = PAC_Polynomials_Term.less_char"
  definition less_eq_char where [symmetric, simp]: "less_eq_char = PAC_Polynomials_Term.less_eq_char"
instance
  apply standard
  using char.linorder_axioms
  by (auto simp: class.linorder_def class.order_def class.preorder_def
       less_eq_char_def less_than_char_def class.order_axioms_def
       class.linorder_axioms_def p2rel_def less_char_def)
end

instantiation list :: (linorder) linorder
begin
  definition less_list where  "less_list = lexordp (<)"
  definition less_eq_list where "less_eq_list = lexordp_eq"

instance
proof standard
  have [dest]: \<open>\<And>x y :: 'a :: linorder list. (x, y) \<in> lexord {(x, y). x < y} \<Longrightarrow>
           lexordp_eq y x \<Longrightarrow> False\<close>
    by (metis lexordp_antisym lexordp_conv_lexord lexordp_eq_conv_lexord)
  have [simp]: \<open>\<And>x y :: 'a :: linorder list. lexordp_eq x y \<Longrightarrow>
           \<not> lexordp_eq y x \<Longrightarrow>
           (x, y) \<in> lexord {(x, y). x < y}\<close>
    using lexordp_conv_lexord lexordp_conv_lexordp_eq by blast
  show
   \<open>(x < y) = Restricted_Predicates.strict (\<le>) x y\<close>
   \<open>x \<le> x\<close>
   \<open>x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z\<close>
   \<open>x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y\<close>
   \<open>x \<le> y \<or> y \<le> x\<close>
   for x y z :: \<open>'a :: linorder list\<close>
    by (auto simp: less_list_def less_eq_list_def List.lexordp_def
    lexordp_conv_lexord lexordp_into_lexordp_eq lexordp_antisym
    antisym_def lexordp_eq_refl lexordp_eq_linear intro: lexordp_eq_trans
    dest: lexordp_eq_antisym)
qed

end

lemma term_order_rel'_alt_def_lexord:
    \<open>term_order_rel' x y = ord_class.lexordp x y\<close> and
  term_order_rel'_alt_def:
    \<open>term_order_rel' x y \<longleftrightarrow> x < y\<close>
proof -
  show
    \<open>term_order_rel' x y = ord_class.lexordp x y\<close>
    \<open>term_order_rel' x y \<longleftrightarrow> x < y\<close>
    unfolding less_than_char_of_char[symmetric, abs_def]
    by (auto simp: lexordp_conv_lexord less_eq_list_def
         less_list_def lexordp_def var_order_rel_def
         rel2p_def term_order_rel_alt_def p2rel_def)
qed

lemma list_rel_list_rel_order_iff:
  assumes \<open>(a, b) \<in> \<langle>string_rel\<rangle>list_rel\<close> \<open>(a', b') \<in> \<langle>string_rel\<rangle>list_rel\<close>
  shows \<open>a < a' \<longleftrightarrow> b < b'\<close>
proof
  have H: \<open>(a, b) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow>
       (a, cs) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow> b = cs\<close> for cs
     using single_valued_monom_rel' IS_RIGHT_UNIQUE_string_rel
     unfolding string2_rel_def
     by (subst (asm)list_rel_sv_iff[symmetric])
       (auto simp: single_valued_def)
  assume \<open>a < a'\<close>
  then consider
    u u' where \<open>a' = a @ u # u'\<close> |
    u aa v w aaa where \<open>a = u @ aa # v\<close> \<open>a' = u @ aaa # w\<close> \<open>aa < aaa\<close>
    by (subst (asm) less_list_def)
     (auto simp: lexord_def List.lexordp_def
      list_rel_append1 list_rel_split_right_iff)
  then show \<open>b < b'\<close>
  proof cases
    case 1
    then show \<open>b < b'\<close>
      using assms
      by (subst less_list_def)
        (auto simp: lexord_def List.lexordp_def
        list_rel_append1 list_rel_split_right_iff dest: H)
  next
    case 2
    then obtain u' aa' v' w' aaa' where
       \<open>b = u' @ aa' # v'\<close> \<open>b' = u' @ aaa' # w'\<close>
       \<open>(aa, aa') \<in> string_rel\<close>
       \<open>(aaa, aaa') \<in> string_rel\<close>
      using assms
      by (smt list_rel_append1 list_rel_split_right_iff single_valued_def single_valued_monom_rel)
    with \<open>aa < aaa\<close> have \<open>aa' < aaa'\<close>
      by (auto simp: string_rel_def less_literal.rep_eq less_list_def
        lexordp_conv_lexord lexordp_def char.lexordp_conv_lexord
          simp flip: less_char_def PAC_Polynomials_Term.less_char_def)
    then show \<open>b < b'\<close>
      using \<open>b = u' @ aa' # v'\<close> \<open>b' = u' @ aaa' # w'\<close>
      by (subst less_list_def)
        (fastforce simp: lexord_def List.lexordp_def
        list_rel_append1 list_rel_split_right_iff)
  qed
next
  have H: \<open>(a, b) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow>
       (a', b) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow> a = a'\<close> for a a' b
     using single_valued_monom_rel'
     by (auto simp: single_valued_def IS_LEFT_UNIQUE_def
       simp flip: inv_list_rel_eq)
  assume \<open>b < b'\<close>
  then consider
    u u' where \<open>b' = b @ u # u'\<close> |
    u aa v w aaa where \<open>b = u @ aa # v\<close> \<open>b' = u @ aaa # w\<close> \<open>aa < aaa\<close>
    by (subst (asm) less_list_def)
     (auto simp: lexord_def List.lexordp_def
      list_rel_append1 list_rel_split_right_iff)
  then show \<open>a < a'\<close>
  proof cases
    case 1
    then show \<open>a < a'\<close>
      using assms
      by (subst less_list_def)
        (auto simp: lexord_def List.lexordp_def
        list_rel_append2 list_rel_split_left_iff dest: H)
  next
    case 2
    then obtain u' aa' v' w' aaa' where
       \<open>a = u' @ aa' # v'\<close> \<open>a' = u' @ aaa' # w'\<close>
       \<open>(aa', aa) \<in> string_rel\<close>
       \<open>(aaa', aaa) \<in> string_rel\<close>
      using assms
      by (auto simp: lexord_def List.lexordp_def
        list_rel_append2 list_rel_split_left_iff dest: H)
    with \<open>aa < aaa\<close> have \<open>aa' < aaa'\<close>
      by (auto simp: string_rel_def less_literal.rep_eq less_list_def
        lexordp_conv_lexord lexordp_def char.lexordp_conv_lexord
          simp flip: less_char_def PAC_Polynomials_Term.less_char_def)
    then show \<open>a < a'\<close>
      using \<open>a = u' @ aa' # v'\<close> \<open>a' = u' @ aaa' # w'\<close>
      by (subst less_list_def)
        (fastforce simp: lexord_def List.lexordp_def
        list_rel_append1 list_rel_split_right_iff)
  qed
qed

lemma string_rel_le[sepref_import_param]:
  shows \<open>((<), (<)) \<in> \<langle>string_rel\<rangle>list_rel \<rightarrow>  \<langle>string_rel\<rangle>list_rel \<rightarrow> bool_rel\<close>
  by (auto intro!: fun_relI simp: list_rel_list_rel_order_iff)

(* TODO Move *)
lemma [sepref_import_param]:
  assumes \<open>CONSTRAINT IS_LEFT_UNIQUE R\<close>  \<open>CONSTRAINT IS_RIGHT_UNIQUE R\<close>
  shows \<open>(remove1, remove1) \<in> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel\<close>
  apply (intro fun_relI)
  subgoal premises p for x y xs ys
    using p(2) p(1) assms
    by (induction xs ys rule: list_rel_induct)
      (auto simp: IS_LEFT_UNIQUE_def single_valued_def)
  done

instantiation pac_step :: (heap, heap, heap) heap
begin

instance
proof standard
  obtain f :: \<open>'a \<Rightarrow> nat\<close> where
    f: \<open>inj f\<close>
    by blast
  obtain g :: \<open>nat \<times> nat \<times> nat \<times> nat \<times> nat \<Rightarrow> nat\<close> where
    g: \<open>inj g\<close>
    by blast
  obtain h :: \<open>'b \<Rightarrow> nat\<close> where
    h: \<open>inj h\<close>
    by blast
  obtain i :: \<open>'c \<Rightarrow> nat\<close> where
    i: \<open>inj i\<close>
    by blast
  have [iff]: \<open>g a = g b \<longleftrightarrow> a = b\<close>\<open>h a'' = h b'' \<longleftrightarrow> a'' = b''\<close>  \<open>f a' = f b' \<longleftrightarrow> a' = b'\<close>
    \<open>i a''' = i b''' \<longleftrightarrow> a''' = b'''\<close>  for a b a' b' a'' b'' a''' b'''
    using f g h i unfolding inj_def by blast+
  let ?f = \<open>\<lambda>x :: ('a, 'b, 'c) pac_step.
     g (case x of
        Add a b c d \<Rightarrow>     (0, i a,  i b,  i c, f d)
      | Del a  \<Rightarrow>          (1, i a,    0,   0,   0)
      | Mult a b c d \<Rightarrow>    (2, i a, f b, i c, f d)
      | Extension a b c \<Rightarrow> (3, i a, f c, 0, h b))\<close>
   have \<open>inj ?f\<close>
     apply (auto simp: inj_def)
     apply (case_tac x; case_tac y)
     apply auto
     done
   then show \<open>\<exists>f :: ('a, 'b, 'c) pac_step \<Rightarrow> nat. inj f\<close>
     by blast
qed

end

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weakening
  imports Weak_Bisimulation
begin

locale weak = env +
  assumes weaken: "\<Psi> \<hookrightarrow> \<Psi> \<otimes> \<Psi>'"
begin

lemma entWeaken:
  fixes \<Psi> :: 'b
  and   \<phi> :: 'c

  assumes "\<Psi> \<turnstile> \<phi>"

  shows "\<Psi> \<otimes> \<Psi>' \<turnstile> \<phi>"
using assms weaken
by(auto simp add: AssertionStatImp_def)

lemma assertWeaken:
  fixes \<Psi>  :: 'b
  and   \<Psi>' :: 'b

  shows "\<Psi> \<hookrightarrow> \<Psi> \<otimes> \<Psi>'"
by(auto simp add: AssertionStatImp_def entWeaken)

lemma frameWeaken:
  fixes F :: "'b frame"
  and   G :: "'b frame"

  shows "F \<hookrightarrow>\<^sub>F F \<otimes>\<^sub>F G"
proof -
  obtain A\<^sub>F \<Psi>\<^sub>F where FrF: "F = \<langle>A\<^sub>F, \<Psi>\<^sub>F\<rangle>" and "A\<^sub>F \<sharp>* F" and  "A\<^sub>F \<sharp>* G"
    by(rule_tac F=F and C="(F, G)" in freshFrame) auto
  obtain A\<^sub>G \<Psi>\<^sub>G where FrG: "G = \<langle>A\<^sub>G, \<Psi>\<^sub>G\<rangle>" and "A\<^sub>G \<sharp>* F" and  "A\<^sub>G \<sharp>* G" and "A\<^sub>G \<sharp>* A\<^sub>F" and "A\<^sub>G \<sharp>* \<Psi>\<^sub>F"
    by(rule_tac F=G and C="(F, G, A\<^sub>F, \<Psi>\<^sub>F)" in freshFrame) auto
  from FrG `A\<^sub>F \<sharp>* G` `A\<^sub>G \<sharp>* A\<^sub>F` have "A\<^sub>F \<sharp>* \<Psi>\<^sub>G" by auto
  have "\<Psi>\<^sub>F \<hookrightarrow> \<Psi>\<^sub>F \<otimes> \<Psi>\<^sub>G" by(rule weaken)
  hence "\<langle>A\<^sub>G, \<Psi>\<^sub>F\<rangle> \<hookrightarrow>\<^sub>F \<langle>A\<^sub>G, \<Psi>\<^sub>F \<otimes> \<Psi>\<^sub>G\<rangle>" by(rule_tac frameImpResChainPres) auto
  with `A\<^sub>G \<sharp>* \<Psi>\<^sub>F` have "\<langle>\<epsilon>, \<Psi>\<^sub>F\<rangle> \<hookrightarrow>\<^sub>F \<langle>A\<^sub>G, \<Psi>\<^sub>F \<otimes> \<Psi>\<^sub>G\<rangle>" using frameResFreshChain
    by(rule_tac FrameStatImpTrans) (auto simp add: FrameStatEq_def)
  with FrF FrG `A\<^sub>G \<sharp>* A\<^sub>F` `A\<^sub>G \<sharp>* \<Psi>\<^sub>F` `A\<^sub>F \<sharp>* \<Psi>\<^sub>G` show ?thesis
    by(force simp add: frameChainAppend intro: frameImpResChainPres)
qed

lemma unitAssertWeaken:
  fixes \<Psi> :: 'b

  shows "\<one> \<hookrightarrow> \<Psi>"
proof -
  have "\<one> \<hookrightarrow> \<one> \<otimes> \<Psi>" by(rule assertWeaken)
  moreover have "\<one> \<otimes> \<Psi> \<hookrightarrow> \<Psi>" by(metis Identity AssertionStatEq_def Commutativity AssertionStatEqTrans)
  ultimately show ?thesis by(rule AssertionStatImpTrans)
qed

lemma unitFrameWeaken:
  fixes F :: "'b frame"

  shows "\<langle>\<epsilon>, \<one>\<rangle> \<hookrightarrow>\<^sub>F F"
proof -
  have "\<langle>\<epsilon>, \<one>\<rangle> \<hookrightarrow>\<^sub>F ((\<langle>\<epsilon>, \<one>\<rangle>) \<otimes>\<^sub>F F)" by(rule frameWeaken)
  moreover obtain A\<^sub>F \<Psi>\<^sub>F where FrF: "F = \<langle>A\<^sub>F, \<Psi>\<^sub>F\<rangle>"
    by(rule_tac F=F and C="()" in freshFrame) auto
  hence "(\<langle>\<epsilon>, \<one>\<rangle>) \<otimes>\<^sub>F F \<simeq>\<^sub>F F"
    by simp (metis frameIntIdentity frameIntCommutativity FrameStatEqTrans FrameStatEqSym)
  ultimately show ?thesis by(metis FrameStatImpTrans FrameStatEq_def)
qed

lemma insertAssertionWeaken:
  fixes F :: "'b frame"
  and   \<Psi> :: 'b

  shows "\<langle>\<epsilon>, \<Psi>\<rangle> \<hookrightarrow>\<^sub>F insertAssertion F \<Psi>"
proof -
  have "\<langle>\<epsilon>, \<Psi>\<rangle> \<hookrightarrow>\<^sub>F (\<langle>\<epsilon>, \<Psi>\<rangle>) \<otimes>\<^sub>F F" by(rule frameWeaken)
  thus ?thesis by simp
qed

lemma frameImpStatEq:
  fixes A\<^sub>F  :: "name list"
  and   \<Psi>  :: 'b
  and   \<Psi>' :: 'b
  and   \<phi>  :: 'c

  assumes "(\<langle>A\<^sub>F, \<Psi>\<rangle>) \<turnstile>\<^sub>F \<phi>"
  and     "\<Psi> \<simeq> \<Psi>'"

  shows "(\<langle>A\<^sub>F, \<Psi>'\<rangle>) \<turnstile>\<^sub>F \<phi>"
proof -
  obtain p::"name prm" where "(p \<bullet> A\<^sub>F) \<sharp>* \<phi>" and "(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>'"
                         and "distinctPerm p" and S: "set p \<subseteq> set A\<^sub>F \<times> set(p \<bullet> A\<^sub>F)"
    by(rule_tac c="(\<phi>, \<Psi>, \<Psi>')" in name_list_avoiding) auto
  from `(\<langle>A\<^sub>F, \<Psi>\<rangle>) \<turnstile>\<^sub>F \<phi>` `(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>` S have "(\<langle>(p \<bullet> A\<^sub>F), p \<bullet> \<Psi>\<rangle>) \<turnstile>\<^sub>F \<phi>" by(simp add: frameChainAlpha)
  hence "(p \<bullet> \<Psi>) \<turnstile> \<phi>" using `(p \<bullet> A\<^sub>F) \<sharp>* \<phi>` by(rule frameImpE)
  moreover from `\<Psi> \<simeq> \<Psi>'` have "(p \<bullet> \<Psi>) \<simeq> (p \<bullet> \<Psi>')" by(rule AssertionStatEqClosed)
  ultimately have "(p \<bullet> \<Psi>') \<turnstile> \<phi>" by(simp add: AssertionStatEq_def AssertionStatImp_def)
  hence "(\<langle>(p \<bullet> A\<^sub>F), p \<bullet> \<Psi>'\<rangle>) \<turnstile>\<^sub>F \<phi>" using `(p \<bullet> A\<^sub>F) \<sharp>* \<phi>`
    by(rule_tac frameImpI) auto
  with `(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>'` S show ?thesis by(simp add: frameChainAlpha)
qed

  assumes "\<Psi> \<rhd> P \<longmapsto>\<tau> \<prec> P'"

  shows "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame P') \<Psi>"
proof(auto simp add: FrameStatImp_def)
  fix \<phi> :: 'c
  obtain A\<^sub>P \<Psi>\<^sub>P where FrP: "extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" and "A\<^sub>P \<sharp>* P" and "A\<^sub>P \<sharp>* \<phi>" and "A\<^sub>P \<sharp>* \<Psi>" and "distinct A\<^sub>P"
    by(rule_tac C="(P, \<phi>, \<Psi>)" in freshFrame) auto
  with `\<Psi> \<rhd> P \<longmapsto>\<tau> \<prec> P'` obtain \<Psi>' A\<^sub>P' \<Psi>\<^sub>P' where FrP': "extractFrame P' = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>" and "\<Psi>\<^sub>P \<otimes> \<Psi>' \<simeq> \<Psi>\<^sub>P'"
                                              and "A\<^sub>P' \<sharp>* P'" and "A\<^sub>P' \<sharp>* \<phi>"  and "A\<^sub>P' \<sharp>* \<Psi>"
    by(rule_tac C="(\<Psi>, \<phi>)" in expandTauFrame) auto
  assume "insertAssertion (extractFrame P) \<Psi> \<turnstile>\<^sub>F \<phi>"
  with FrP `A\<^sub>P \<sharp>* \<phi>` `A\<^sub>P \<sharp>* \<Psi>` have "\<Psi> \<otimes> \<Psi>\<^sub>P \<turnstile> \<phi>" by(auto dest: frameImpE)
  hence "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<turnstile> \<phi>" by(rule entWeaken)
  hence "\<Psi> \<otimes> \<Psi>\<^sub>P' \<turnstile> \<phi>" using `\<Psi>\<^sub>P \<otimes> \<Psi>' \<simeq> \<Psi>\<^sub>P'`
    by(rule_tac statEqEnt, auto) (metis Associativity compositionSym AssertionStatEqTrans AssertionStatEqSym Commutativity)
  with `A\<^sub>P' \<sharp>* \<phi>` `A\<^sub>P' \<sharp>* \<Psi>` FrP' show "insertAssertion (extractFrame P') \<Psi> \<turnstile>\<^sub>F \<phi>"
    by(force intro: frameImpI)
qed

lemma weakenTransition:
  fixes \<Psi>  :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   Rs :: "('a, 'b, 'c) residual"
  and   \<Psi>' :: 'b

  assumes "\<Psi> \<rhd> P \<longmapsto> Rs"

  shows "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto> Rs"
using assms
proof(nominal_induct avoiding: \<Psi>' rule: semantics.strong_induct)
  case(cInput \<Psi> M K xvec N Tvec P \<Psi>')
  from `\<Psi> \<turnstile> M \<leftrightarrow> K` have "\<Psi> \<otimes> \<Psi>' \<turnstile> M \<leftrightarrow> K" by(rule entWeaken)
  thus ?case using `distinct xvec` `set xvec \<subseteq> (supp N)` `length xvec = length Tvec`
    by(rule Input)
next
  case(Output \<Psi> M K N P \<Psi>')
  from `\<Psi> \<turnstile> M \<leftrightarrow> K` have "\<Psi> \<otimes> \<Psi>' \<turnstile> M \<leftrightarrow> K" by(rule entWeaken)
  thus ?case by(rule semantics.Output)
next
  case(Case \<Psi> P Rs \<phi> Cs \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto> Rs" by(rule Case)
  moreover note `(\<phi>, P) mem Cs`
  moreover from `\<Psi> \<turnstile> \<phi>` have "\<Psi> \<otimes> \<Psi>' \<turnstile> \<phi>" by(rule entWeaken)
  ultimately show ?case using `guarded P`
    by(rule semantics.Case)
next
  case(cPar1 \<Psi> \<Psi>\<^sub>Q P \<alpha> P' Q A\<^sub>Q \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<rhd> P \<longmapsto>\<alpha> \<prec> P'" by(rule cPar1)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>Q \<rhd> P \<longmapsto>\<alpha> \<prec> P'"
    by(metis statEqTransition Composition Associativity Commutativity AssertionStatEqTrans)
  thus ?case using `extractFrame Q = \<langle>A\<^sub>Q, \<Psi>\<^sub>Q\<rangle>` `bn \<alpha> \<sharp>* Q` `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>Q \<sharp>* \<Psi>'` `A\<^sub>Q \<sharp>* P` `A\<^sub>Q \<sharp>* \<alpha>`
    by(rule_tac Par1) auto
next
  case(cPar2 \<Psi> \<Psi>\<^sub>P Q \<alpha> Q' P A\<^sub>P \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<rhd> Q \<longmapsto>\<alpha> \<prec> Q'" by(rule cPar2)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<rhd> Q \<longmapsto>\<alpha> \<prec> Q'"
    by(metis statEqTransition Composition Associativity Commutativity AssertionStatEqTrans)
  thus ?case using `extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>` `bn \<alpha> \<sharp>* P` `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>'` `A\<^sub>P \<sharp>* Q` `A\<^sub>P \<sharp>* \<alpha>`
    by(rule_tac Par2) auto
next
  case(cComm1 \<Psi> \<Psi>\<^sub>Q P M N P' A\<^sub>P \<Psi>\<^sub>P Q K xvec Q' A\<^sub>Q \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<rhd> P \<longmapsto>M\<lparr>N\<rparr> \<prec> P'" by(rule cComm1)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>Q \<rhd> P \<longmapsto>M\<lparr>N\<rparr> \<prec> P'"
    by(metis statEqTransition Composition Associativity Commutativity AssertionStatEqTrans)
  moreover note `extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>`
  moreover have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<rhd> Q \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q'" by(rule cComm1)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<rhd> Q \<longmapsto>K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q'"
    by(metis statEqTransition Composition Associativity Commutativity AssertionStatEqTrans)
  moreover note `extractFrame Q = \<langle>A\<^sub>Q, \<Psi>\<^sub>Q\<rangle>`
  moreover from `\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>Q \<turnstile> M \<leftrightarrow> K` have "(\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<turnstile> M \<leftrightarrow> K" by(rule entWeaken)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>Q \<turnstile> M \<leftrightarrow> K" by(metis statEqEnt Composition Associativity Commutativity AssertionStatEqTrans)
  ultimately show ?case using `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>'` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* Q` `A\<^sub>P \<sharp>* M` `A\<^sub>P \<sharp>* A\<^sub>Q`
                              `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>Q \<sharp>* \<Psi>'` `A\<^sub>Q \<sharp>* P` `A\<^sub>Q \<sharp>* Q` `A\<^sub>Q \<sharp>* K` `xvec \<sharp>* P`
    by(rule_tac Comm1) (assumption | auto)+
next
  case(cComm2 \<Psi> \<Psi>\<^sub>Q P M xvec N P' A\<^sub>P \<Psi>\<^sub>P Q K Q' A\<^sub>Q \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<rhd> P \<longmapsto>M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'" by(rule cComm2)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>Q \<rhd> P \<longmapsto>M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'"
    by(metis statEqTransition Composition Associativity Commutativity AssertionStatEqTrans)
  moreover note `extractFrame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>`
  moreover have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<rhd> Q \<longmapsto>K\<lparr>N\<rparr> \<prec> Q'" by(rule cComm2)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<rhd> Q \<longmapsto>K\<lparr>N\<rparr> \<prec> Q'"
    by(metis statEqTransition Composition Associativity Commutativity AssertionStatEqTrans)
  moreover note `extractFrame Q = \<langle>A\<^sub>Q, \<Psi>\<^sub>Q\<rangle>`
  moreover from `\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>Q \<turnstile> M \<leftrightarrow> K` have "(\<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<turnstile> M \<leftrightarrow> K" by(rule entWeaken)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>Q \<turnstile> M \<leftrightarrow> K" by(metis statEqEnt Composition Associativity Commutativity AssertionStatEqTrans)
  ultimately show ?case using `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>'` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* Q` `A\<^sub>P \<sharp>* M` `A\<^sub>P \<sharp>* A\<^sub>Q`
                              `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>Q \<sharp>* \<Psi>'` `A\<^sub>Q \<sharp>* P` `A\<^sub>Q \<sharp>* Q` `A\<^sub>Q \<sharp>* K` `xvec \<sharp>* Q`
    by(rule_tac Comm2) (assumption | auto)+
next
  case(cOpen \<Psi> P M xvec yvec N P' x \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto>M\<lparr>\<nu>*(xvec@yvec)\<rparr>\<langle>N\<rangle> \<prec> P'" by(rule cOpen)
  thus ?case using `x \<in> supp N` `x \<sharp> \<Psi>` `x \<sharp> \<Psi>'` `x \<sharp> M` `x \<sharp> xvec` `x \<sharp> yvec`
    by(rule_tac Open) auto
next
  case(cScope \<Psi> P \<alpha> P' x \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto>\<alpha> \<prec> P'" by(rule cScope)
  thus ?case using `x \<sharp> \<Psi>` `x \<sharp> \<Psi>'` `x \<sharp> \<alpha>` by(rule_tac Scope) auto
next
  case(Bang \<Psi> P Rs \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<parallel> !P\<longmapsto> Rs" by(rule Bang)
  thus ?case using `guarded P` by(rule semantics.Bang)
qed

end

end


theory TwoColouringEx
  imports Rule FOLoG
begin

abbreviation cast_ruleschema_rule :: "ruleschema \<Rightarrow> rule" where
"cast_ruleschema_rule rs \<equiv> (rs, cond.T)"

declare [[coercion_enabled]]
declare [[coercion cast_ruleschema_rule]]

definition init :: ruleschema where
"init = \<lparr>rule_ty = Mapping [(0,Lty)],
         rule_lhs = \<lparr>nodes = Mapping [(1, \<lparr>node_mark = RuleMarkNode_None, node_label= Var 0 # [], node_rooted=False\<rparr>)]
                   ,edges = Mapping.empty\<rparr>,
         rule_rhs = \<lparr>nodes = Mapping [(1, \<lparr>node_mark = RuleMarkNode_Red, node_label= Var 0 # [] , node_rooted=False\<rparr>)]
               ,edges = Mapping.empty\<rparr>,
         rule_interf = {1}\<rparr>"

definition unmark :: rule where
"unmark = (\<lparr>rule_ty = Mapping [(0, Lty)],
           rule_lhs = \<lparr>nodes = Mapping [(1, \<lparr>node_mark = RuleMarkNode_Any, node_label= Var 0 # [] , node_rooted=False\<rparr>)]
                 ,edges = Mapping.empty\<rparr>,
           rule_rhs = \<lparr>nodes = Mapping[(1, \<lparr>node_mark = RuleMarkNode_None, node_label= Var 0 # [], node_rooted=False\<rparr>)]
                 ,edges = Mapping.empty\<rparr>,
           rule_interf = {1}\<rparr>, cond.T)"

definition col_blue_1 :: ruleschema where
"col_blue_1 = \<lparr>rule_ty = Mapping [(0, Lty), (1, Lty), (2, Lty)]
            ,rule_lhs = \<lparr>nodes = Mapping
                                 [(1, \<lparr>node_mark = RuleMarkNode_Red , node_label = [Var 0], node_rooted = False\<rparr>)
                                 ,(2, \<lparr>node_mark = RuleMarkNode_None, node_label = [Var 1], node_rooted = False\<rparr>)]
                        ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
            ,rule_rhs = \<lparr>nodes = Mapping
                                 [(1, \<lparr>node_mark = RuleMarkNode_Red , node_label = [Var 0], node_rooted = False\<rparr>)
                                 ,(2, \<lparr>node_mark = RuleMarkNode_Blue, node_label = [Var 1], node_rooted = False\<rparr>)]
                        ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
            ,rule_interf = {1,2}\<rparr>"

definition col_blue_2 :: ruleschema where
"col_blue_2 = \<lparr>rule_ty = Mapping [(0, Lty), (1, Lty), (2, Lty)]
            ,rule_lhs = \<lparr>nodes = Mapping
                                 [(1, \<lparr>node_mark = RuleMarkNode_Red , node_label = [Var 0], node_rooted = False\<rparr>)
                                 ,(2, \<lparr>node_mark = RuleMarkNode_None, node_label = [Var 1], node_rooted = False\<rparr>)]
                        ,edges = Mapping [(1, \<lparr>edge_src = 2, edge_trg = 1, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
            ,rule_rhs = \<lparr>nodes = Mapping
                                 [(1, \<lparr>node_mark = RuleMarkNode_Red , node_label = [Var 0], node_rooted = False\<rparr>)
                                 ,(2, \<lparr>node_mark = RuleMarkNode_Blue, node_label = [Var 1], node_rooted = False\<rparr>)]
                        ,edges = Mapping [(1, \<lparr>edge_src = 2, edge_trg = 1, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
            ,rule_interf = {1,2}\<rparr>"

definition col_red_1 :: ruleschema where
"col_red_1 = \<lparr>rule_ty = Mapping [(0, Lty), (1, Lty), (2, Lty)]
           ,rule_lhs = \<lparr>nodes = Mapping
                                [(1, \<lparr>node_mark = RuleMarkNode_Blue , node_label = [Var 0], node_rooted = False\<rparr>)
                                ,(2, \<lparr>node_mark = RuleMarkNode_None, node_label = [Var 1], node_rooted = False\<rparr>)]
                       ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
           ,rule_rhs = \<lparr>nodes = Mapping
                                [(1, \<lparr>node_mark = RuleMarkNode_Blue , node_label = [Var 0], node_rooted = False\<rparr>)
                                ,(2, \<lparr>node_mark = RuleMarkNode_Red, node_label = [Var 1], node_rooted = False\<rparr>)]
                       ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
           ,rule_interf = {1,2}\<rparr>"

definition col_red_2 :: ruleschema where
"col_red_2 = \<lparr>rule_ty = Mapping [(0, Lty), (1, Lty), (2, Lty)]
           ,rule_lhs = \<lparr>nodes = Mapping
                                [(1, \<lparr>node_mark = RuleMarkNode_Blue , node_label = [Var 0], node_rooted = False\<rparr>)
                                ,(2, \<lparr>node_mark = RuleMarkNode_None, node_label = [Var 1], node_rooted = False\<rparr>)]
                       ,edges = Mapping [(1, \<lparr>edge_src = 2, edge_trg = 1, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
           ,rule_rhs = \<lparr>nodes = Mapping
                                [(1, \<lparr>node_mark = RuleMarkNode_Blue , node_label = [Var 0], node_rooted = False\<rparr>)
                                ,(2, \<lparr>node_mark = RuleMarkNode_Red, node_label = [Var 1], node_rooted = False\<rparr>)]
                       ,edges = Mapping [(1, \<lparr>edge_src = 2, edge_trg = 1, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
           ,rule_interf = {1,2}\<rparr>"

definition ill_blue :: ruleschema where
"ill_blue = \<lparr>rule_ty = Mapping [(0, Lty), (1, Lty), (2, Lty)]
            ,rule_lhs = \<lparr>nodes = Mapping
                                 [(1, \<lparr>node_mark = RuleMarkNode_Blue, node_label = [Var 0], node_rooted = False\<rparr>)
                                 ,(2, \<lparr>node_mark = RuleMarkNode_Blue, node_label = [Var 1], node_rooted = False\<rparr>)]
                        ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
            ,rule_rhs = \<lparr>nodes = Mapping
                                 [(1, \<lparr>node_mark = RuleMarkNode_Blue, node_label = [Var 0], node_rooted = False\<rparr>)
                                 ,(2, \<lparr>node_mark = RuleMarkNode_Blue, node_label = [Var 1], node_rooted = False\<rparr>)]
                        ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
            ,rule_interf = {1,2}\<rparr>"

definition ill_red :: ruleschema where
"ill_red = \<lparr>rule_ty = Mapping [(0, Lty), (1, Lty), (2, Lty)]
           ,rule_lhs = \<lparr>nodes = Mapping
                                [(1, \<lparr>node_mark = RuleMarkNode_Red, node_label = [Var 0], node_rooted = False\<rparr>)
                                ,(2, \<lparr>node_mark = RuleMarkNode_Red, node_label = [Var 1], node_rooted = False\<rparr>)]
                       ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
           ,rule_rhs = \<lparr>nodes = Mapping
                                [(1, \<lparr>node_mark = RuleMarkNode_Red, node_label = [Var 0], node_rooted = False\<rparr>)
                                ,(2, \<lparr>node_mark = RuleMarkNode_Red, node_label = [Var 1], node_rooted = False\<rparr>)]
                       ,edges = Mapping [(1, \<lparr>edge_src = 1, edge_trg = 2, edge_mark = RuleMarkEdge_None, edge_label = [Var 2]\<rparr>)]\<rparr>
           ,rule_interf = {1,2}\<rparr>"

lemma "wf_ruleschema ill_red"
  by (simp add: ill_red_def)

lemma "wf_ruleschema ill_blue"
  by (simp add: ill_blue_def)

lemma "wf_ruleschema col_red"
  by (simp add: col_red_def)

lemma "wf_ruleschema col_blue"
  by (simp add: col_blue_def)

definition twocolouring :: com where
"twocolouring \<equiv> (RuleApp init ;; RuleSet {col_blue :: rule, col_red:: rule}!)! ;;
  IF RuleSet {ill_blue :: rule, ill_red :: rule} THEN RuleApp unmark! ELSE Skip"

abbreviation c :: "form" where
"c == (\<lceil>\<forall> 0 : Node\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil>) \<lceil>\<and>\<rceil>
      (\<lceil>\<forall> 0 : Edge\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None)"

abbreviation d :: form where
"d == (\<lceil>\<forall> 0 : Node\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red  \<lceil>\<or>\<rceil>\<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue) \<lceil>\<and>\<rceil>
      \<lceil>\<not>\<rceil>(\<lceil>\<exists> 0 : Edge\<rceil> (\<lceil>src \<langle>0\<rangle>\<rceil> \<lceil>\<noteq>\<rceil> \<lceil>trg \<langle>0\<rangle>\<rceil>) \<lceil>\<and>\<rceil>
                     \<lceil>mark \<lceil>src \<langle>0\<rangle>\<rceil>\<rceil> \<lceil>=\<rceil> \<lceil>mark \<lceil>trg \<langle>0\<rangle>\<rceil>\<rceil>)"

abbreviation e :: form where
"e == (\<lceil>\<forall> 0 : Node\<rceil> (\<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue) \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil>) \<lceil>\<and>\<rceil>
      (\<lceil>\<forall> 0 : Edge\<rceil>  \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None)"

abbreviation f :: form where
"f == (\<lceil>\<forall> 0 : Node\<rceil> (\<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<or>\<rceil>
        \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil>) \<lceil>\<and>\<rceil>
      (\<lceil>\<forall> 0 : Edge\<rceil>  \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None)"

section \<open>SLP proofs\<close>

lemma "eval g undefined (Slp f (init:: rule)  \<lceil>\<longleftrightarrow>\<rceil>
  ((\<lceil>\<exists>0: Node\<rceil> (\<lceil>\<forall>1: Node\<rceil> (\<langle>1\<rangle> \<lceil>=\<rceil> \<langle>0\<rangle>
    \<lceil>\<or>\<rceil> ((\<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<or>\<rceil> \<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None)\<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>1\<rangle>\<rceil>))
  \<lceil>\<and>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil>)) \<lceil>\<and>\<rceil> (\<lceil>\<forall>1: Edge\<rceil> (\<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None))))"
  apply code_simp
  by auto

value "Slp f (col_blue_1::rule)"
value "Slp f (col_blue_2::rule)"
value "Slp f (col_red_1::rule)"
(*
lemma "eval g undefined ((Slp f (col_blue_1:: rule) \<lceil>\<or>\<rceil> Slp f (col_blue_2:: rule)) \<lceil>\<longleftrightarrow>\<rceil>
  (Slp f (col_red_1:: rule) \<lceil>\<or>\<rceil>  Slp f (col_red_2:: rule)))"
  apply code_simp
  apply auto
     apply (smt (z3))
  apply (smt (z3))
   apply (smt (z3))
  by (smt (z3)) *)

(*

lemma "eval g undefined (Slp f (col_blue:: rule) \<lceil>\<longleftrightarrow>\<rceil> Slp f (col_red:: rule))"
   apply code_simp
   apply auto
  oops

  oops

lemma "eval g undefined (((\<lceil>\<exists>0: Node\<rceil> (\<lceil>\<exists>1: Node\<rceil> ((\<lceil>\<forall>2: Node\<rceil> (\<langle>2\<rangle> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<or>\<rceil> \<langle>2\<rangle> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<or>\<rceil>
    ((\<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>2\<rangle>\<rceil>)))
  \<lceil>\<and>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<and>\<rceil> \<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil> \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>1\<rangle>\<rceil>
  \<lceil>\<and>\<rceil> (\<lceil>\<exists>3: Edge\<rceil> ((\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle>) \<lceil>\<or>\<rceil> (\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle>)) )))) \<lceil>\<and>\<rceil> (\<lceil>\<forall>4:Edge\<rceil> (\<lceil>mark \<langle>4\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None)))  \<lceil>\<longrightarrow>\<rceil>  Slp f (col_blue:: rule))"
  apply code_simp
  apply auto
   apply (erule notE)
   apply (smt (z3) conv_mark_node.elims mark_eq_node.simps(12) mark_eq_node.simps(15) mark_eq_node.simps(23) mark_eq_node.simps(24) mark_eq_node.simps(26) rulemark_node.distinct(13))
  apply (erule notE)
  apply (rule spec)
  oops

  text \<open>
    Slp f col_blue implies rule
  \<close>
*)
lemma x[simp]:"mark_eq_node (conv_mark_node HostMarkNode_Red) RuleMarkNode_Red"
  by simp

lemma xxx: "\<And>e. \<forall>e\<in>Mapping.keys (edges g).
            (\<exists>y. Mapping.lookup (nodes g) (edge_trg (the (Mapping.lookup (edges g) e))) = Some y) \<and>
            (\<exists>y. Mapping.lookup (nodes g) (edge_src (the (Mapping.lookup (edges g) e))) = Some y) \<Longrightarrow>
         edge_src (the (Mapping.lookup (edges g) e)) \<in> Mapping.keys (nodes g) \<Longrightarrow>
         edge_trg (the (Mapping.lookup (edges g) e)) \<in> Mapping.keys (nodes g) \<Longrightarrow>
         \<forall>e\<in>Mapping.keys (edges g). mark_eq_edge (conv_mark_edge (edge_mark (the (Mapping.lookup (edges g) e)))) RuleMarkEdge_None \<Longrightarrow>
         \<forall>n\<in>Mapping.keys (nodes g).
            mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Blue \<longrightarrow>
            (\<forall>na\<in>Mapping.keys (nodes g).
                mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) na)))) RuleMarkNode_Red \<longrightarrow>
                n = na \<or>
                na = n \<or>
                (\<exists>nb\<in>Mapping.keys (nodes g).
                    nb \<noteq> na \<and>
                    nb \<noteq> n \<and>
                    (\<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_Red \<and>
                     \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_Blue \<and>
                     \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_None \<or>
                     node_rooted (the (Mapping.lookup (nodes g) nb)))) \<or>
                node_rooted (the (Mapping.lookup (nodes g) na)) \<or>
                node_rooted (the (Mapping.lookup (nodes g) n)) \<or>
                (\<forall>e\<in>Mapping.keys (edges g). edge_src (the (Mapping.lookup (edges g) e)) = n \<longrightarrow> edge_trg (the (Mapping.lookup (edges g) e)) \<noteq> na)) \<Longrightarrow>
         \<forall>n\<in>Mapping.keys (nodes g).
            \<forall>na\<in>Mapping.keys (nodes g).
               mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) na)))) RuleMarkNode_Blue \<longrightarrow>
               mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Red \<longrightarrow>
               n = na \<or>
               na = n \<or>
               (\<exists>nb\<in>Mapping.keys (nodes g).
                   nb \<noteq> n \<and>
                   nb \<noteq> na \<and>
                   (\<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_Red \<and>
                    \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_Blue \<and>
                    \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_None \<or>
                    node_rooted (the (Mapping.lookup (nodes g) nb)))) \<or>
               node_rooted (the (Mapping.lookup (nodes g) n)) \<or>
               node_rooted (the (Mapping.lookup (nodes g) na)) \<or>
               (\<forall>e\<in>Mapping.keys (edges g). edge_src (the (Mapping.lookup (edges g) e)) = n \<longrightarrow> edge_trg (the (Mapping.lookup (edges g) e)) \<noteq> na) \<Longrightarrow>
         mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (edge_trg (the (Mapping.lookup (edges g) e))))))) RuleMarkNode_Blue \<Longrightarrow>
         mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (edge_src (the (Mapping.lookup (edges g) e))))))) RuleMarkNode_Red \<Longrightarrow>
         \<forall>n\<in>Mapping.keys (nodes g).
            n = edge_src (the (Mapping.lookup (edges g) e)) \<or>
            n = edge_trg (the (Mapping.lookup (edges g) e)) \<or>
            (mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Red \<or>
             mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Blue \<or>
             mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_None) \<and>
            \<not> node_rooted (the (Mapping.lookup (nodes g) n)) \<Longrightarrow>
         \<not> node_rooted (the (Mapping.lookup (nodes g) (edge_src (the (Mapping.lookup (edges g) e))))) \<Longrightarrow>
         \<not> node_rooted (the (Mapping.lookup (nodes g) (edge_trg (the (Mapping.lookup (edges g) e))))) \<Longrightarrow> e \<in> Mapping.keys (edges g) \<Longrightarrow> False"
proof -
  fix e :: nat
  assume a1: "mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (edge_trg (the (Mapping.lookup (edges g) e))))))) RuleMarkNode_Blue"
  assume a2: "mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (edge_src (the (Mapping.lookup (edges g) e))))))) RuleMarkNode_Red"
  assume a3: "edge_trg (the (Mapping.lookup (edges g) e)) \<in> Mapping.keys (nodes g)"
  assume a4: "\<not> node_rooted (the (Mapping.lookup (nodes g) (edge_src (the (Mapping.lookup (edges g) e)))))"
  assume a5: "\<not> node_rooted (the (Mapping.lookup (nodes g) (edge_trg (the (Mapping.lookup (edges g) e)))))"
  assume a6: "edge_src (the (Mapping.lookup (edges g) e)) \<in> Mapping.keys (nodes g)"
  assume a7: "\<forall>n\<in>Mapping.keys (nodes g). \<forall>na\<in>Mapping.keys (nodes g). mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) na)))) RuleMarkNode_Blue \<longrightarrow> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Red \<longrightarrow> n = na \<or> na = n \<or> (\<exists>nb\<in>Mapping.keys (nodes g). nb \<noteq> n \<and> nb \<noteq> na \<and> (\<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_Red \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_Blue \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) nb)))) RuleMarkNode_None \<or> node_rooted (the (Mapping.lookup (nodes g) nb)))) \<or> node_rooted (the (Mapping.lookup (nodes g) n)) \<or> node_rooted (the (Mapping.lookup (nodes g) na)) \<or> (\<forall>e\<in>Mapping.keys (edges g). edge_src (the (Mapping.lookup (edges g) e)) = n \<longrightarrow> edge_trg (the (Mapping.lookup (edges g) e)) \<noteq> na)"
  assume a8: "\<forall>n\<in>Mapping.keys (nodes g). n = edge_src (the (Mapping.lookup (edges g) e)) \<or> n = edge_trg (the (Mapping.lookup (edges g) e)) \<or> (mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Red \<or> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Blue \<or> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_None) \<and> \<not> node_rooted (the (Mapping.lookup (nodes g) n))"
  assume a9: "e \<in> Mapping.keys (edges g)"
  obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"\<forall>x0 x1. (\<exists>v2. v2 \<in> Mapping.keys (nodes g) \<and> v2 \<noteq> x1 \<and> v2 \<noteq> x0 \<and> (\<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) v2)))) RuleMarkNode_Red \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) v2)))) RuleMarkNode_Blue \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) v2)))) RuleMarkNode_None \<or> node_rooted (the (Mapping.lookup (nodes g) v2)))) = (nn x0 x1 \<in> Mapping.keys (nodes g) \<and> nn x0 x1 \<noteq> x1 \<and> nn x0 x1 \<noteq> x0 \<and> (\<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (nn x0 x1))))) RuleMarkNode_Red \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (nn x0 x1))))) RuleMarkNode_Blue \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (nn x0 x1))))) RuleMarkNode_None \<or> node_rooted (the (Mapping.lookup (nodes g) (nn x0 x1)))))"
    by moura
  then have f10: "\<forall>n. n \<notin> Mapping.keys (nodes g) \<or> (\<forall>na. (na \<notin> Mapping.keys (nodes g) \<or> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) na)))) RuleMarkNode_Blue \<or> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) n)))) RuleMarkNode_Red) \<or> n = na \<or> na = n \<or> nn na n \<in> Mapping.keys (nodes g) \<and> nn na n \<noteq> n \<and> nn na n \<noteq> na \<and> (\<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (nn na n))))) RuleMarkNode_Red \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (nn na n))))) RuleMarkNode_Blue \<and> \<not> mark_eq_node (conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (nn na n))))) RuleMarkNode_None \<or> node_rooted (the (Mapping.lookup (nodes g) (nn na n)))) \<or> node_rooted (the (Mapping.lookup (nodes g) n)) \<or> node_rooted (the (Mapping.lookup (nodes g) na)) \<or> (\<forall>nb. (nb \<notin> Mapping.keys (edges g) \<or> edge_src (the (Mapping.lookup (edges g) nb)) \<noteq> n) \<or> edge_trg (the (Mapping.lookup (edges g) nb)) \<noteq> na))"
    using a7 by (simp add: Ball_def_raw Bex_def_raw)
  have "conv_mark_node (node_mark (the (Mapping.lookup (nodes g) (edge_trg (the (Mapping.lookup (edges g) e)))))) \<noteq> RuleMarkNode_Green"
    using a1 by force
  then show False
    using f10 a9 a8 a6 a5 a4 a3 a2 a1 by (smt (z3) conv_mark_node.elims mark_eq_node.simps(12) mark_eq_node.simps(15) mark_eq_node.simps(16) mark_eq_node.simps(23) rulemark_node.distinct(13))
qed

lemma "\<lbrakk>wf_ruleschema col_blue_1; wf_ruleschema col_blue_2; wf_graph g\<rbrakk>
  \<Longrightarrow> eval g undefined ((Slp f (col_blue_1:: rule) \<lceil>\<or>\<rceil> Slp f (col_blue_2:: rule))  \<lceil>\<longleftrightarrow>\<rceil>
  (\<lceil>\<exists>0: Node\<rceil> (\<lceil>\<exists>1: Node\<rceil> ((\<lceil>\<forall>2: Node\<rceil> (\<langle>2\<rangle> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<or>\<rceil> \<langle>2\<rangle> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<or>\<rceil>
    ((\<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>2\<rangle>\<rceil>)))
  \<lceil>\<and>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<and>\<rceil> \<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil> \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>1\<rangle>\<rceil>
  \<lceil>\<and>\<rceil> (\<lceil>\<exists>3: Edge\<rceil> ((\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle>) \<lceil>\<or>\<rceil> (\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle>)) )))) \<lceil>\<and>\<rceil> (\<lceil>\<forall>4:Edge\<rceil> (\<lceil>mark \<langle>4\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None)))"
  apply code_simp
  apply safe
  apply auto
     apply (metis (no_types, lifting))
    apply (metis (no_types, hide_lams))
   apply (rule xxx)
              apply blast+
  apply (rule xxx)
             apply blast+
  by (metis (no_types, hide_lams))+

(*
lemma "eval g undefined (Slp f (col_red:: rule)  \<lceil>\<longrightarrow>\<rceil>
  (\<lceil>\<exists>0: Node\<rceil> (\<lceil>\<exists>1: Node\<rceil> ((\<lceil>\<forall>2: Node\<rceil> (\<langle>2\<rangle> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<or>\<rceil> \<langle>2\<rangle> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<or>\<rceil>
    ((\<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>2\<rangle>\<rceil>)))
  \<lceil>\<and>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<and>\<rceil> \<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil> \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>1\<rangle>\<rceil>
  \<lceil>\<and>\<rceil> (\<lceil>\<exists>3: Edge\<rceil> ((\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle>) \<lceil>\<or>\<rceil> (\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle>)) )))) \<lceil>\<and>\<rceil> (\<lceil>\<forall>4:Edge\<rceil> (\<lceil>mark \<langle>4\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None)))"
  apply code_simp
  by auto

lemma "eval g undefined (Slp f (col_red:: rule)  \<lceil>\<longleftrightarrow>\<rceil>
  ((\<lceil>\<exists>0: Node\<rceil>
    (\<lceil>\<exists>1: Node\<rceil>
      ((\<lceil>\<forall>2: Node\<rceil> (\<langle>2\<rangle> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<or>\<rceil> \<langle>2\<rangle> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<or>\<rceil>
        ((\<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<or>\<rceil> \<lceil>mark \<langle>2\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>2\<rangle>\<rceil>) ))
  \<lceil>\<and>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<and>\<rceil> \<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil> \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>1\<rangle>\<rceil>
  \<lceil>\<and>\<rceil> (\<lceil>\<exists>3: Edge\<rceil> ((\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle>) \<lceil>\<or>\<rceil> (\<lceil>src \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<and>\<rceil> \<lceil>trg \<langle>3\<rangle>\<rceil> \<lceil>=\<rceil> \<langle>0\<rangle>)) )))) \<lceil>\<and>\<rceil> (\<lceil>\<forall>4:Edge\<rceil> (\<lceil>mark \<langle>4\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None))))"
  apply code_simp
  apply auto
  oops
 *)

lemma "eval g undefined (Slp f (unmark :: rule)  \<lceil>\<longleftrightarrow>\<rceil>
  (\<lceil>\<exists>1: Node\<rceil> ((\<lceil>\<forall>0: Node\<rceil> (\<langle>0\<rangle> \<lceil>=\<rceil> \<langle>1\<rangle> \<lceil>\<or>\<rceil>
    ((\<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue \<lceil>\<or>\<rceil> \<lceil>mark \<langle>0\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>0\<rangle>\<rceil>)))
  \<lceil>\<and>\<rceil> \<lceil>mark \<langle>1\<rangle>\<rceil> \<lceil>=\<rceil>\<triangleright>\<^sub>V RuleMarkNode_None \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>1\<rangle>\<rceil>)) \<lceil>\<and>\<rceil> (\<lceil>\<forall>4:Edge\<rceil> (\<lceil>mark \<langle>4\<rangle>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>E RuleMarkEdge_None)))"
  apply code_simp
  by auto

lemma c_impl_f : "eval g undefined (c \<lceil>\<longrightarrow>\<rceil> f)"
  by clarsimp

(* section \<open>Proof of Fail output\<close> *)
(*
lemma "eval g undefined (Fail (RuleSet {col_blue::rule, col_red::rule}) \<lceil>\<longleftrightarrow>\<rceil>
  (\<lceil>\<not>\<rceil>(\<lceil>\<exists> x: Edge\<rceil> ((((\<lceil>mark \<lceil>src \<langle>x\<rangle>\<rceil>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<lceil>src \<langle>x\<rangle>\<rceil>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue) \<lceil>\<and>\<rceil> \<lceil>mark \<lceil>src \<langle>x\<rangle>\<rceil>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) \<lceil>\<or>\<rceil>
                     ((\<lceil>mark \<lceil>trg \<langle>x\<rangle>\<rceil>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Red \<lceil>\<or>\<rceil> \<lceil>mark \<lceil>trg \<langle>x\<rangle>\<rceil>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_Blue) \<lceil>\<and>\<rceil> \<lceil>mark \<lceil>src \<langle>x\<rangle>\<rceil>\<rceil> \<lceil>=\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None) ) \<lceil>\<and>\<rceil>
  \<lceil>unrooted \<lceil>src \<langle>x\<rangle>\<rceil>\<rceil> \<lceil>\<and>\<rceil> \<lceil>unrooted \<lceil>trg \<langle>x\<rangle>\<rceil>\<rceil>) )))"
  apply auto
  oops

lemma "eval g undefined (Fail (RuleApp init ;; RuleSet {col_blue::rule, col_red::rule}!) \<lceil>\<longleftrightarrow>\<rceil>
  (\<lceil>\<not>\<rceil>(\<lceil>\<exists> x : Node\<rceil> (\<lceil>mark \<langle>x\<rangle>\<rceil> \<lceil>=\<rceil>  \<triangleright>\<^sub>V RuleMarkNode_None \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>x\<rangle>\<rceil>))))"
  apply auto
  sorry

lemma "eval g undefined (Fail (RuleApp unmark) \<lceil>\<longleftrightarrow>\<rceil> (\<lceil>\<not>\<rceil>(\<lceil>\<exists>x:Node\<rceil> (\<lceil>mark \<langle>x\<rangle>\<rceil> \<lceil>\<noteq>\<rceil> \<triangleright>\<^sub>V RuleMarkNode_None \<lceil>\<and>\<rceil> \<lceil>unrooted \<langle>x\<rangle>\<rceil>))))"
  apply (simp add: unmark_def)
  apply (rule conjI)
   apply (rule disjI1)
   apply (simp add: set_to_list_def)
   apply (rule someI2_ex)
  apply (metis empty_set list.simps(15))
  apply (induct g rule: eval.induct)

lemma "\<turnstile> {c} twocolouring {c \<lceil>\<or>\<rceil> d}"
  apply (simp add: twocolouring_def)
  apply (rule Cons [where ?c' = f and ?d' = "c \<lceil>\<or>\<rceil> d"])
    apply auto
  apply (rule Comp [where ?e = e])
\<comment> \<open>subtree I\<close>
   apply (rule Cons [where ?c' = f and d'="f \<lceil>\<and>\<rceil> Fail (RuleApp init ;; RuleSet {col_blue::rule, col_red::rule}!)"])
     apply auto
    prefer 2
  oops
 *)

(*     prefer 2
    using c_impl_f apply blast
     prefer 2
    apply auto
  apply (rule Comp [where ?e = e])
     apply (rule Cons [where ?c' = f and ?d' = "f \<lceil>\<and>\<rceil> Fail (RuleApp init ;; RuleSet {col_blue::rule, col_red::rule}!)"])
       prefer 2
       apply auto
      prefer 2
    apply (simp add: dom_def)
    oops

 *)end


theory ResourcedDenotational
imports "Abstract-Denotational-Props" "CValue-Nominal" "C-restr"
begin

type_synonym CEnv = "var \<Rightarrow> (C \<rightarrow> CValue)"

interpretation semantic_domain
  "\<Lambda> f . \<Lambda> r. CFn\<cdot>(\<Lambda> v. (f\<cdot>(v))|\<^bsub>r\<^esub>)"
  "\<Lambda> x y. (\<Lambda> r. (x\<cdot>r \<down>CFn y|\<^bsub>r\<^esub>)\<cdot>r)"
  "\<Lambda> b r. CB\<cdot>b"
  "\<Lambda> scrut v1 v2 r. CB_project\<cdot>(scrut\<cdot>r)\<cdot>(v1\<cdot>r)\<cdot>(v2\<cdot>r)"
  "C_case".

notation ESem_syn ("\<N>\<lbrakk> _ \<rbrakk>\<^bsub>_\<^esub>"  [60,60] 60)
notation EvalHeapSem_syn  ("\<^bold>\<N>\<lbrakk> _ \<^bold>\<rbrakk>\<^bsub>_\<^esub>"  [0,0] 110)
notation HSem_syn ("\<N>\<lbrace>_\<rbrace>_"  [60,60] 60)
notation AHSem_bot ("\<N>\<lbrace>_\<rbrace>"  [60] 60)

text \<open>
Here we re-state the simplification rules, cleaned up by beta-reducing the locale parameters.
\<close>

lemma CESem_simps:
  "\<N>\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub>  = (\<Lambda> (C\<cdot>r). CFn\<cdot>(\<Lambda> v. (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>)|\<^bsub>r\<^esub>))"
  "\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>     = (\<Lambda> (C\<cdot>r). ((\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<down>CFn \<rho> x|\<^bsub>r\<^esub>)\<cdot>r)"
  "\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>       = (\<Lambda> (C\<cdot>r). (\<rho>  x) \<cdot> r)"
  "\<N>\<lbrakk> Bool b \<rbrakk>\<^bsub>\<rho>\<^esub>      = (\<Lambda> (C\<cdot>r). CB\<cdot>(Discr b))"
  "\<N>\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<rho>\<^esub>  = (\<Lambda> (C\<cdot>r). CB_project\<cdot>((\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r))"
  "\<N>\<lbrakk> Let as body \<rbrakk>\<^bsub>\<rho>\<^esub> = (\<Lambda> (C \<cdot> r). (\<N>\<lbrakk>body\<rbrakk>\<^bsub>\<N>\<lbrace>as\<rbrace>\<rho>\<^esub>) \<cdot> r)"
  by (auto simp add: eta_cfun)

lemma CESem_bot[simp]:"(\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<sigma>\<^esub>)\<cdot>\<bottom> = \<bottom>"
  by (nominal_induct e arbitrary: \<sigma> rule: exp_strong_induct) auto

lemma CHSem_bot[simp]:"((\<N>\<lbrace> \<Gamma> \<rbrace>) x)\<cdot>\<bottom> = \<bottom>"
  by (cases "x \<in> domA \<Gamma>") (auto simp add: lookup_HSem_heap lookup_HSem_other)

text \<open>
Sometimes we do not care much about the resource usage and just want a simpler formula.
\<close>

lemma CESem_simps_no_tick:
  "(\<N>\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> CFn\<cdot>(\<Lambda> v. (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>)|\<^bsub>r\<^esub>)"
  "(\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r    \<sqsubseteq> ((\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<down>CFn \<rho> x|\<^bsub>r\<^esub>)\<cdot>r"
  "\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>         \<sqsubseteq> \<rho> x"
  "(\<N>\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> CB_project\<cdot>((\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r)"
  "\<N>\<lbrakk> Let as body \<rbrakk>\<^bsub>\<rho>\<^esub>   \<sqsubseteq>  \<N>\<lbrakk>body\<rbrakk>\<^bsub>\<N>\<lbrace>as\<rbrace>\<rho>\<^esub>"
  apply -
  apply (rule below_trans[OF monofun_cfun_arg[OF below_C]], simp)
  apply (rule below_trans[OF monofun_cfun_arg[OF below_C]], simp)
  apply (rule cfun_belowI, rule below_trans[OF monofun_cfun_arg[OF below_C]], simp)
  apply (rule below_trans[OF monofun_cfun_arg[OF below_C]], simp)
  apply (rule cfun_belowI, rule below_trans[OF monofun_cfun_arg[OF below_C]], simp)
  done

lemma CELam_no_restr: "(\<N>\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> CFn\<cdot>(\<Lambda> v. (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>))"
proof-
  have "(\<N>\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<sqsubseteq> CFn\<cdot>(\<Lambda> v. (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>)|\<^bsub>r\<^esub>)" by (rule CESem_simps_no_tick)
  also have "\<dots> \<sqsubseteq> CFn\<cdot>(\<Lambda> v. (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>))"
    by (intro cont2cont monofun_LAM below_trans[OF C_restr_below] monofun_cfun_arg below_refl fun_upd_mono)
  finally show ?thesis by this (intro cont2cont)
qed

lemma CEApp_no_restr: "(\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r    \<sqsubseteq> ((\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<down>CFn \<rho> x)\<cdot>r"
proof-
  have "(\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r  \<sqsubseteq> ((\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r \<down>CFn \<rho> x|\<^bsub>r\<^esub>)\<cdot>r" by (rule CESem_simps_no_tick)
  also have "\<rho> x|\<^bsub>r\<^esub> \<sqsubseteq> \<rho> x" by (rule C_restr_below)
  finally show ?thesis by this (intro cont2cont)
qed

end