theory Term imports
  Main Unify
begin

(*
Hints: Define separate constructors for variables and constants that take the
name of the variable or constant as argument. We suggest to use strings
(type string) as variables and constants and not to use subscripting for keys
in cryptographic operations.
*)

(* 5. (a) *)

datatype msg =
    Cons string
    | Var string
    | Hash msg
    | Pair msg msg
    | Sym_encrypt msg msg
    | Public_key_encrypt msg msg
    | Signature msg msg

inductive is_var :: "msg \<Rightarrow> bool" where
  "is_var (Var _)"

(* 5. (b) *)

datatype symbol =
  SCons string | SHash | SPair | SSym_encrypt | SPublic_key_encrypt | SSignature

fun arity :: "(symbol \<Rightarrow> nat)" where
  "arity (SCons _) = 0"
| "arity SHash = 1"
| "arity _ = 2"

(* 5. (c) *)

fun embed :: "msg \<Rightarrow> (symbol, string) term " where
  "embed (Cons s) = Fun (SCons s) []"
| "embed (Var s) = Unify.Var s"
| "embed (Hash m) = Fun SHash [embed m]"
| "embed (Pair m1 m2) = Fun SPair [embed m1, embed m2]"
| "embed (Sym_encrypt m1 m2) = Fun SSym_encrypt [embed m1, embed m2]"
| "embed (Public_key_encrypt m1 m2) = Fun SPublic_key_encrypt [embed m1, embed m2]"
| "embed (Signature m1 m2) = Fun SSignature [embed m1, embed m2]"

fun msg_of_term :: "(symbol, string) term \<Rightarrow> msg" where
  "msg_of_term (Unify.Var s) = Var s"
| "msg_of_term (Fun (SCons s) []) = Cons s"
| "msg_of_term (Fun SHash [t]) = Hash (msg_of_term t)"
| "msg_of_term (Fun SPair [t1, t2]) = Pair (msg_of_term t1) (msg_of_term t2)"
| "msg_of_term (Fun SSym_encrypt [t1, t2]) = Sym_encrypt (msg_of_term t1) (msg_of_term t2)"
| "msg_of_term (Fun SPublic_key_encrypt [t1, t2]) = Public_key_encrypt (msg_of_term t1) (msg_of_term t2)"
| "msg_of_term (Fun SSignature [t1, t2]) = Signature (msg_of_term t1) (msg_of_term t2)"
| "msg_of_term _ = undefined"

(* Three properties of embedding *)

lemma wf_term_embed [simp]: "wf_term arity (embed msg)"
proof (induction msg)
  case (Cons s)
  have "(length [] = arity (SCons s)) \<and> (\<forall>t\<in>(set []). wf_term arity t)" by simp
  then have "wf_term arity (Fun (SCons s) [])" by (simp add: wf_term.intros(2))
  then show ?case by simp
next
  case (Var x)
  then show ?case by (simp add: wf_term.intros(1))
next
  case (Hash m)
  have "length [embed m] = arity SHash" by simp
  then show ?case using Hash.IH wf_term.simps by fastforce
next
  case (Pair msg1 msg2)
  have "length [embed msg1, embed msg2] = arity SPair" by simp
  then show ?case
    by (metis Pair.IH(1) Pair.IH(2) embed.simps(4) list.discI list.set_cases set_ConsD wf_term.simps)
next
  case (Sym_encrypt msg1 msg2)
  have "length [embed msg1, embed msg2] = arity SSym_encrypt" by simp
  then show ?case
    by (metis Sym_encrypt.IH(1) Sym_encrypt.IH(2) embed.simps(5) list.discI list.set_cases set_ConsD wf_term.simps)
next
  case (Public_key_encrypt msg1 msg2)
  have "length [embed msg1, embed msg2] = arity SPublic_key_encrypt" by simp
  then show ?case
    by (metis Public_key_encrypt.IH(1) Public_key_encrypt.IH(2) embed.simps(6) list.discI list.set_cases set_ConsD wf_term.simps)
next
  case (Signature msg1 msg2)
  have "length [embed msg1, embed msg2] = arity SSignature" by simp
  then show ?case
    by (metis Signature.IH(1) Signature.IH(2) embed.simps(7) list.discI list.set_cases set_ConsD wf_term.simps)
qed

lemma msg_of_term_embed [simp]: "msg_of_term (embed msg) = msg"
  by (induction msg) simp_all

lemma embed_msg_of_term [simp]:
  "wf_term arity t \<Longrightarrow> embed (msg_of_term t) = t"
proof (induction t)
  case (Var x)
  then show ?case by simp
next
  case (Fun x1a x2)
  then show ?case
  proof (cases x1a)
    case (SCons x1)
    then show ?thesis
      by (metis Fun.prems arity.simps(1) embed.simps(1) length_0_conv msg_of_term.simps(2) term.distinct(1) term.inject(2) wf_term.simps)
  next
    case SHash
    then show ?thesis
      by (metis Fun.IH Fun.prems One_nat_def Suc_length_conv arity.simps(2) embed.simps(3) length_0_conv list.set_intros(1) msg_of_term.simps(3) term.distinct(1) term.inject(2) wf_term.simps)
  next
    case SPair
    have "length x2 = arity SPair" using Fun.prems SPair wf_term.cases by fastforce
    then have "length x2 = 2" by simp
    then obtain x2a x2b where "x2 = [x2a, x2b]"
      by (metis (no_types, lifting) One_nat_def Suc_1 Suc_length_conv length_0_conv)
    then show ?thesis
      by (metis Fun.IH Fun.prems SPair embed.simps(4) insert_iff list.set(2) msg_of_term.simps(4) term.distinct(1) term.inject(2) wf_term.cases)
  next
    case SSym_encrypt
    have "length x2 = arity SSym_encrypt" using Fun.prems SSym_encrypt wf_term.cases by fastforce
    then have "length x2 = 2" by simp
    then obtain x2a x2b where "x2 = [x2a, x2b]"
      by (metis (no_types, lifting) One_nat_def Suc_1 Suc_length_conv length_0_conv)
    then show ?thesis
      by (metis Fun.IH Fun.prems SSym_encrypt embed.simps(5) insert_iff list.set(2) msg_of_term.simps(5) term.distinct(1) term.inject(2) wf_term.cases)
  next
    case SPublic_key_encrypt
    have "length x2 = arity SPublic_key_encrypt" using Fun.prems SPublic_key_encrypt wf_term.cases by fastforce
    then have "length x2 = 2" by simp
    then obtain x2a x2b where "x2 = [x2a, x2b]"
      by (metis (no_types, lifting) One_nat_def Suc_1 Suc_length_conv length_0_conv)
    then show ?thesis
      by (metis Fun.IH Fun.prems SPublic_key_encrypt embed.simps(6) insert_iff list.set(2) msg_of_term.simps(6) term.distinct(1) term.inject(2) wf_term.cases)
  next
    case SSignature
    have "length x2 = arity SSignature" using Fun.prems SSignature wf_term.cases by fastforce
    then have "length x2 = 2" by simp
    then obtain x2a x2b where "x2 = [x2a, x2b]"
      by (metis (no_types, lifting) One_nat_def Suc_1 Suc_length_conv length_0_conv)
    then show ?thesis
      by (metis Fun.IH Fun.prems SSignature embed.simps(7) insert_iff list.set(2) msg_of_term.simps(7) term.distinct(1) term.inject(2) wf_term.cases)
  qed
qed

(* Some properties *)

lemma wf_subst_embed [simp]: "wf_subst arity (embed \<circ> \<sigma>)"
  by (simp add: wf_subst_def)

lemma msg_of_term_inject:
  "\<lbrakk> wf_term arity t1; wf_term arity t2 \<rbrakk> \<Longrightarrow> msg_of_term t1 = msg_of_term t2 \<longleftrightarrow> t1 = t2 "
  using embed_msg_of_term by fastforce

(* 5. (d) *)

fun m_fv :: "msg \<Rightarrow> string set" where
  "m_fv (Cons s) = {}"
| "m_fv (Var s) = {s}"
| "m_fv (Hash m) = m_fv m"
| "m_fv (Pair m1 m2) = m_fv m1 \<union> m_fv m2"
| "m_fv (Sym_encrypt m1 m2) = m_fv m1 \<union> m_fv m2"
| "m_fv (Public_key_encrypt m1 m2) = m_fv m1 \<union> m_fv m2"
| "m_fv (Signature m1 m2) = m_fv m1 \<union> m_fv m2"

lemma link_fv:
  "m_fv msg = fv (embed msg)"
  by (induction msg) simp_all

lemma "m_fv_finite": "finite (m_fv msg)"
  by (induction msg) auto

type_synonym m_subst = "char list \<Rightarrow> msg"
type_synonym m_eq = "msg \<times> msg"
type_synonym m_eqs = "m_eq list"

fun embed_eq :: "m_eq \<Rightarrow> (symbol, string) equation " where
  "embed_eq (m1, m2) = (embed m1, embed m2)"

fun m_eq_of_eq :: "(symbol, string) equation \<Rightarrow> m_eq" where
  "m_eq_of_eq (a, b) = (msg_of_term a, msg_of_term b)"

fun embed_eqs :: "m_eqs \<Rightarrow> (symbol, string) equations" where
  "embed_eqs [] = []"
| "embed_eqs (eq # U) = (embed_eq eq) # (embed_eqs U)"

fun m_eqs_of_eqs :: "(symbol, string) equations \<Rightarrow> m_eqs" where
  "m_eqs_of_eqs [] = []"
| "m_eqs_of_eqs (eq # U) = (m_eq_of_eq eq) # (m_eqs_of_eqs U)"

fun m_sapply :: "m_subst \<Rightarrow> msg \<Rightarrow> msg"
  where
  "m_sapply \<sigma> (Cons s) = Cons s"
| "m_sapply \<sigma> (Var s) =  \<sigma> s"
| "m_sapply \<sigma> (Hash m) = Hash (m_sapply \<sigma> m)"
| "m_sapply \<sigma> (Pair m1 m2) = Pair (m_sapply \<sigma> m1) (m_sapply \<sigma> m2)"
| "m_sapply \<sigma> (Sym_encrypt m1 m2) = Sym_encrypt (m_sapply \<sigma> m1) (m_sapply \<sigma> m2)"
| "m_sapply \<sigma> (Public_key_encrypt m1 m2) = Public_key_encrypt (m_sapply \<sigma> m1) (m_sapply \<sigma> m2)"
| "m_sapply \<sigma> (Signature m1 m2) = Signature (m_sapply \<sigma> m1) (m_sapply \<sigma> m2)"

lemma link_sapply:
  "m_sapply \<sigma> m = msg_of_term (sapply (embed \<circ> \<sigma>) (embed m))"
  by (induction m) simp_all

lemma "m_sapply_id": "m_sapply Var = id"
proof (rule ext)
  fix msg
  show "m_sapply msg.Var msg = id msg" by (induction msg) auto
qed

fun m_sapply_eq :: "m_subst \<Rightarrow> m_eq \<Rightarrow> m_eq" where
  "m_sapply_eq \<sigma> eq = (m_sapply \<sigma> (fst eq), m_sapply \<sigma> (snd eq))"

lemma link_sapply_eq:
  "m_sapply_eq \<sigma> eq = m_eq_of_eq (sapply_eq (embed \<circ> \<sigma>) (embed_eq eq))"
  by (metis embed_eq.simps fstI link_sapply m_eq_of_eq.simps m_sapply_eq.elims prod.collapse sapply_eq.elims sndI)

fun m_sapply_eqs :: "m_subst \<Rightarrow> m_eqs \<Rightarrow> m_eqs" where
  "m_sapply_eqs \<sigma> [] = []"
| "m_sapply_eqs \<sigma> (eq # U) = (m_sapply_eq \<sigma> eq) # (m_sapply_eqs \<sigma> U)"

lemma link_sapply_eqs:
  "m_sapply_eqs \<sigma> U = m_eqs_of_eqs (sapply_eq_system (embed \<circ> \<sigma>) (embed_eqs U))"
  proof (induction U)
    case Nil
    then show ?case by simp
  next
    case (Cons a U)
    have "m_sapply_eqs \<sigma> (a # U) = (m_sapply_eq \<sigma> a) # (m_sapply_eqs \<sigma> U)" by simp
    moreover have "m_sapply_eq \<sigma> a = m_eq_of_eq (sapply_eq (embed \<circ> \<sigma>) (embed_eq a))"
      using link_sapply_eq by blast
    moreover have "m_sapply_eqs \<sigma> U = m_eqs_of_eqs (sapply_eq_system (embed \<circ> \<sigma>) (embed_eqs U))"
      using Cons.IH by blast
    then show ?case
      by (metis Cons.IH embed_eqs.simps(2) link_sapply_eq m_eqs_of_eqs.simps(2) m_sapply_eqs.simps(2) sapply_eq_system_equiv_def)
  qed

inductive m_unifies :: "m_subst \<Rightarrow> m_eq \<Rightarrow> bool" where
  m_unifies_eq: "(m_sapply \<sigma> u = m_sapply \<sigma> t) \<Longrightarrow> m_unifies \<sigma> (u, t)"

lemma link_unifies:
  "m_unifies \<sigma> eq = unifies (embed \<circ> \<sigma>) (embed_eq eq)"
proof -
  have "\<And>u t. \<lbrakk>msg_of_term ((Term.embed \<circ> \<sigma>) \<cdot> Term.embed u) = msg_of_term ((Term.embed \<circ> \<sigma>) \<cdot> Term.embed t); eq = (u, t)\<rbrakk> \<Longrightarrow> (Term.embed \<circ> \<sigma>) \<cdot> Term.embed u = (Term.embed \<circ> \<sigma>) \<cdot> Term.embed t"
    by (metis embed_msg_of_term wf_subst_embed wf_term_embed wf_term_sapply)
  moreover have "\<And>u t. \<lbrakk>embed_eq eq = (u, t); (Term.embed \<circ> \<sigma>) \<cdot> u = (Term.embed \<circ> \<sigma>) \<cdot> t\<rbrakk> \<Longrightarrow> \<exists>u t. eq = (u, t) \<and> msg_of_term ((Term.embed \<circ> \<sigma>) \<cdot> Term.embed u) = msg_of_term ((Term.embed \<circ> \<sigma>) \<cdot> Term.embed t)"
    by (metis embed_eq.elims old.prod.inject)
  then show ?thesis
    by (metis (no_types, lifting) calculation embed_eq.simps link_sapply m_unifies.simps unifies.cases unifies_eq)
qed

inductive m_unifiess :: "m_subst \<Rightarrow> m_eqs \<Rightarrow> bool" where
  m_unifiess_empty: "m_unifiess \<sigma> []"
| m_unifiess_rec:   "(m_unifiess \<sigma> s) \<and> (m_unifies \<sigma> eq) \<Longrightarrow> m_unifiess \<sigma> (eq # s)"

lemma link_unifiess:
  "m_unifiess \<sigma> U = unifiess (embed \<circ> \<sigma>) (embed_eqs U)"
proof (induction U)
  case Nil
  then show ?case by (simp add: m_unifiess_empty unifiess_empty)
next
  case (Cons a U)
  then show ?case
    by (metis (mono_tags, lifting) embed_eqs.simps(2) link_unifies list.discI list.inject m_unifiess.simps unifiess.simps)
qed

fun lift_subst :: "(symbol, string) subst option \<Rightarrow> m_subst option" where
  "lift_subst None = None"
| "lift_subst (Some \<sigma>) = Some (msg_of_term \<circ> \<sigma>)"

fun m_unify :: "m_eqs \<Rightarrow> m_subst option" where
  "m_unify U = lift_subst (unify (embed_eqs U))"

lemma msg_of_term_var[simp]:
  "msg_of_term \<circ> Unify.Var = msg.Var"
proof (rule ext)
  fix x
  show "(msg_of_term \<circ> term.Var) x = msg.Var x"
  proof (cases x)
    case Nil
    then show ?thesis by simp
  next
    case (Cons a list)
    then show ?thesis by simp
  qed
qed

lemma link_unify_1:
  "m_unify [] = Some Var"
proof -
  have "m_unify [] = lift_subst (unify [])" by simp
  then have "... = lift_subst (Some Unify.Var)" by simp
  then have "... = Some (msg_of_term \<circ> Unify.Var)" by simp
  then show ?thesis by simp
qed

fun m_scomp :: "m_subst \<Rightarrow> m_subst \<Rightarrow> m_subst" (infixl "\<circ>m" 75)
  where
  "m_scomp \<sigma> \<tau> = (\<lambda> x. m_sapply \<sigma> (\<tau>(x)))"

fun m_lifted_comp :: "m_subst option \<Rightarrow> m_subst \<Rightarrow> m_subst option"
  where
  "m_lifted_comp None \<tau> = None"
| "m_lifted_comp (Some \<sigma>) \<tau> = Some (\<sigma> \<circ>m \<tau>)"

(* 5. (e) *)

lemma "m_sapply_comp": "m_sapply \<tau> (m_sapply \<sigma> m) = m_sapply (\<tau> \<circ>m \<sigma>) m"
  by (induction m) auto

lemma embed_eq[simp]:
  "fst (embed_eq eq) = embed (fst eq)"
  "snd (embed_eq eq) = embed (snd eq)"
proof -
  show "fst (embed_eq eq) = embed (fst eq)"
    by (metis embed_eq.simps fstI prod.collapse)
  show "snd (embed_eq eq) = embed (snd eq)"
    by (metis embed_eq.simps prod.collapse sndI)
qed

lemma wf_subst_id:
  assumes "wf_subst arity \<tau>"
  shows "sapply (embed \<circ> msg_of_term \<circ> \<tau>) (embed m) = sapply \<tau> (embed m)"
  by (metis (mono_tags) assms comp_apply embed_msg_of_term wf_subst_def)

lemma link_soundness:
  assumes "unifiess \<tau> (embed_eqs U)"
  and "msg_of_term \<circ> \<tau> = \<sigma>"
  and "wf_subst arity \<tau>"
  shows "m_unifiess \<sigma> U"
  using assms
proof (induction U)
  case Nil
  then show ?case by (simp add: m_unifiess_empty)
next
  case (Cons a U)
  have "unifies \<tau> (embed_eq a)"
    by (metis Cons.prems(1) embed_eqs.simps(2) list.discI list.inject unifiess.cases)
  moreover obtain "wf_term arity (embed (fst a))" and "wf_term arity (embed (snd a))"
    by (metis wf_term_embed)
  then obtain "wf_term arity (sapply \<tau> (embed (fst a)))" and "wf_term arity (sapply \<tau> (embed (snd a)))"
    using assms(3) wf_term_sapply by blast
  moreover have "sapply \<tau> (fst (embed_eq a)) = sapply \<tau> (snd (embed_eq a))"
    using unifies.simps calculation(1) by (metis fst_conv sndI)
  then have "sapply \<tau> (embed (fst a)) = sapply \<tau> (embed (snd a))" by simp

  have "unifies (embed \<circ> \<sigma>) (embed_eq a)"
  proof -
    have "sapply (embed \<circ> \<sigma>) (embed (fst a)) = sapply (embed \<circ> msg_of_term \<circ> \<tau>) (embed (fst a))"
      by (simp add: assms(2) comp_assoc)
    then have "... = sapply \<tau> (embed (fst a))"
      using assms(3) wf_subst_id by blast
    then have "... = sapply \<tau> (embed (snd a))"
      by (simp add: \<open>\<tau> \<cdot> Term.embed (fst a) = \<tau> \<cdot> Term.embed (snd a)\<close>)
    then have "... = sapply (embed \<circ> \<sigma>) (embed (snd a))"
      by (metis assms(2) assms(3) comp_assoc wf_subst_id)
    then show ?thesis
      by (metis \<open>(Term.embed \<circ> \<sigma>) \<cdot> Term.embed (fst a) = (Term.embed \<circ> msg_of_term \<circ> \<tau>) \<cdot> Term.embed (fst a)\<close> \<open>(Term.embed \<circ> msg_of_term \<circ> \<tau>) \<cdot> Term.embed (fst a) = \<tau> \<cdot> Term.embed (fst a)\<close> \<open>\<tau> \<cdot> Term.embed (fst a) = \<tau> \<cdot> Term.embed (snd a)\<close> embed_eq(1) embed_eq(2) prod.collapse unifies_eq)
  qed
  then show ?case
    by (metis Cons.IH Cons.prems(1) assms(2) assms(3) embed_eqs.simps(2) link_unifiess list.inject unifiess.simps)
qed

theorem m_soundness1:
  assumes "m_unify U = Some \<sigma>"
  shows "m_unifiess \<sigma> U"
proof -
  obtain \<tau> where "unify (embed_eqs U) = Some \<tau>"
    using assms by fastforce
  then have "unifiess \<tau> (embed_eqs U)" by (simp add: soundness1)
  moreover have "\<sigma> = msg_of_term \<circ> \<tau>"
    using \<open>unify (embed_eqs U) = Some \<tau>\<close> assms by auto
  moreover have "wf_eqs arity (embed_eqs U)"
  proof (induction U)
    case Nil
    then show ?case
      by (simp add: wf_eqs.intros(1))
  next
    case (Cons a U)
    obtain "wf_term arity (embed (fst a))" and "wf_term arity (embed (snd a))" by simp
    then show ?case
      by (metis Cons.IH embed_eq(1) embed_eq(2) embed_eqs.simps(2) wf_eq_def wf_eqs.simps wf_term_embed)
  qed
  then have "wf_subst arity \<tau>"
    using \<open>unify (embed_eqs U) = Some \<tau>\<close> wf_subst_unify by blast
  then show ?thesis
    using calculation(1) calculation(2) link_soundness by auto
qed

(* 5. (f) *)

fun m_fv_eq :: "m_eq \<Rightarrow> string set" where
  "m_fv_eq eq = (m_fv (fst eq)) \<union> (m_fv (snd eq))"

lemma link_fv_eq:
  "m_fv_eq eq = fv_eq (embed_eq eq)"
proof -
  have "m_fv_eq eq = (m_fv (fst eq)) \<union> (m_fv (snd eq))" by simp
  then have "... = (fv (fst (embed_eq eq))) \<union> (fv (snd (embed_eq eq)))"
    by (metis embed_eq.simps fstI link_fv prod.collapse sndI)
  then show ?thesis by simp
qed

fun m_fv_eqs :: "m_eqs \<Rightarrow> string set" where
  "m_fv_eqs [] = {}"
| "m_fv_eqs (eq # U) = (m_fv_eq eq) \<union> (m_fv_eqs U)"

lemma def_equiv:
  "m_fv_eqs U = (\<Union>x\<in>(set U). m_fv_eq x)"
proof (induction U)
  case Nil
  then show ?case by auto
next
  case (Cons a U)
  then show ?case by simp
qed

lemma link_fv_eqs:
  "m_fv_eqs U = fv_eq_system (embed_eqs U)"
proof (induction U)
  case Nil
  have "m_fv_eqs [] = (\<Union>x\<in>(set []). m_fv_eq x)" by simp
  then have "... = {}" by auto
  moreover have "embed_eqs [] = []" by simp
  moreover have "fv_eq_system [] = fold (\<union>) (map fv_eq []) {}" by simp
  then have "fold (\<union>) (map fv_eq []) {} = fold (\<union>) [] {}" by simp
  then have "fold (\<union>) [] {} = {}" by simp
  then show ?case
    by simp
next
  case (Cons a U)
  then show ?case
    by (metis embed_eqs.simps(2) fv_eq_system_def_equiv link_fv_eq list.discI list.inject m_fv_eqs.elims)
qed

fun m_sdom :: "m_subst \<Rightarrow> string set"
  where
  "m_sdom \<sigma> = {x. \<sigma> x \<noteq> Var x}"

lemma link_sdom:
  "m_sdom \<sigma> = sdom (embed \<circ> \<sigma>)"
proof -
  have "m_sdom \<sigma> = {x. \<sigma> x \<noteq> msg.Var x}" by auto
  then have "... = {x. (embed \<circ> \<sigma>) x \<noteq> (embed \<circ> msg.Var) x}"
    by (metis comp_apply msg_of_term_embed)
  then show ?thesis by auto
qed

fun m_sran :: "m_subst \<Rightarrow> msg set"
  where
"m_sran \<sigma> = (\<Union>x\<in>m_sdom \<sigma>. {\<sigma> x})"

fun msg_set_of_term_set :: "(symbol, string) term set \<Rightarrow> msg set" where
  "msg_set_of_term_set s = {msg_of_term x | x. x \<in> s}"

lemma msg_set_def:
  "msg_set_of_term_set s = (\<Union>x\<in>s. {msg_of_term x})" by auto

lemma msg_set_def_specific:
  "(\<Union>x\<in>(sdom \<tau>). {msg_of_term (\<tau> x)}) = msg_set_of_term_set (\<Union>x\<in>(sdom \<tau>). {\<tau> x})" by auto

lemma link_sran:
  "m_sran \<sigma> = msg_set_of_term_set (sran (embed \<circ> \<sigma>))"
proof -
  have "m_sran \<sigma> = (\<Union>x\<in>m_sdom \<sigma>. {\<sigma> x})" by simp
  then have "... = (\<Union>x\<in>(sdom (embed \<circ> \<sigma>)). {\<sigma> x})"
    using link_sdom by auto
  then have "... = (\<Union>x\<in>(sdom (embed \<circ> \<sigma>)). {(msg_of_term \<circ> embed \<circ> \<sigma>) x})" by auto
  then have "... = (\<Union>x\<in>(sdom (embed \<circ> \<sigma>)). {msg_of_term ((embed \<circ> \<sigma>) x)})" by simp
  then have "... = msg_set_of_term_set (\<Union>x\<in>(sdom (embed \<circ> \<sigma>)). {(embed \<circ> \<sigma>) x})"
    using msg_set_def_specific by presburger
  then show ?thesis
    using \<open>(\<Union>x\<in>m_sdom \<sigma>. {\<sigma> x}) = (\<Union>x\<in>sdom (Term.embed \<circ> \<sigma>). {\<sigma> x})\<close> by auto
qed

fun m_svran:: "m_subst \<Rightarrow> string set"
  where
"m_svran \<sigma> = (\<Union>t\<in>(m_sran \<sigma>).(m_fv t))"

lemma wf_term_embed_sran:
  assumes "y \<in> sran (embed \<circ> \<sigma>)"
  shows "wf_term arity y"
proof -
  have "y \<in> (\<Union>x\<in>sdom (embed \<circ> \<sigma>). {(embed \<circ> \<sigma>) x})" using assms by auto
  obtain x where "y \<in> {(embed \<circ> \<sigma>) x}" and "x \<in> sdom (embed \<circ> \<sigma>)"
    using \<open>y \<in> (\<Union>x\<in>sdom (Term.embed \<circ> \<sigma>). {(Term.embed \<circ> \<sigma>) x})\<close> by blast
  then have "y = (embed \<circ> \<sigma>) x" by blast
  moreover have "wf_subst arity (embed \<circ> \<sigma>)" by simp
  then show ?thesis by (simp add: calculation)
qed

lemma link_svran:
  "m_svran \<sigma> = svran (embed \<circ> \<sigma>)"
proof -
  have "m_svran \<sigma> = (\<Union>t\<in>(m_sran \<sigma>).(m_fv t))" by simp
  then have "... = (\<Union>t\<in>(msg_set_of_term_set (sran (embed \<circ> \<sigma>))).(m_fv t))"
    using link_sran by auto
  then have "... =  (\<Union>x\<in>(sran (embed \<circ> \<sigma>)).(m_fv (msg_of_term x)))" by fastforce
  then have "... =  (\<Union>x\<in>(sran (embed \<circ> \<sigma>)).(fv ((embed \<circ> msg_of_term) x)))"
    using link_fv by auto
  moreover have "\<forall>x\<in>(sran (embed \<circ> \<sigma>)). wf_term arity x"
    using wf_term_embed_sran by blast
  then show ?thesis
    using \<open>(\<Union>t\<in>m_sran \<sigma>. m_fv t) = (\<Union>t\<in>msg_set_of_term_set (sran (Term.embed \<circ> \<sigma>)). m_fv t)\<close> \<open>(\<Union>t\<in>msg_set_of_term_set (sran (Term.embed \<circ> \<sigma>)). m_fv t) = (\<Union>x\<in>sran (Term.embed \<circ> \<sigma>). m_fv (msg_of_term x))\<close> calculation by auto
qed

lemma wf_embed_eqs:
  "wf_eqs arity (embed_eqs U)"
proof (induction U)
  case Nil
  then show ?case by (simp add: wf_eqs.intros(1))
next
  case (Cons a U)
  obtain "wf_term arity (embed (fst a))" and "wf_term arity (embed (snd a))" by simp
  then have "wf_eq arity (embed_eq a)" by (simp add: wf_eq_def)
  then show ?case by (simp add: Cons.IH wf_eqs.intros(2))
qed

lemma msg_term_tau:
  assumes "unify (embed_eqs U) = Some \<tau>"
  and "\<sigma> = msg_of_term \<circ> \<tau>"
  shows "embed \<circ> msg_of_term \<circ> \<tau> = \<tau>"
proof (rule ext)
  show "(embed \<circ> msg_of_term \<circ> \<tau>) t = \<tau> t" for t
  proof -
    have "wf_eqs arity (embed_eqs U)" by (simp add: wf_embed_eqs)
    have "wf_subst arity \<tau>" using \<open>wf_eqs arity (embed_eqs U)\<close> assms(1) wf_subst_unify by auto
    then have "wf_term arity (\<tau> t)" by (simp add: wf_subst_def)
    then show ?thesis by simp
  qed
qed

lemma embed_sapply:
  "embed (m_sapply \<sigma> u) = (embed \<circ> \<sigma>) \<cdot> (embed u)"
  by (simp add: link_sapply)

lemma m_sapply_embed:
  "embed_eqs (m_sapply_eqs \<sigma> U) = (embed \<circ> \<sigma>) \<cdot> (embed_eqs U)"
proof (induction U)
  case Nil
  then show ?case by simp
next
  case (Cons a U)
  have "embed_eq (m_sapply_eq \<sigma> a) = (embed \<circ> \<sigma>) \<cdot> (embed_eq a)"
  proof -
    obtain u and v where "a = (u, v)" by (meson surj_pair)
    have "embed_eq (m_sapply_eq \<sigma> a) = (embed (m_sapply \<sigma> u), embed (m_sapply \<sigma> v))"
      by (simp add: \<open>a = (u, v)\<close>)
    then have "... = ((embed \<circ> \<sigma>) \<cdot> (embed u), (embed \<circ> \<sigma>) \<cdot> (embed v))" using embed_sapply by blast
    then have "... = (embed \<circ> \<sigma>) \<cdot> (embed u, embed v)" by simp
    then show ?thesis
      using \<open>(Term.embed (m_sapply \<sigma> u), Term.embed (m_sapply \<sigma> v)) = ((Term.embed \<circ> \<sigma>) \<cdot> Term.embed u, (Term.embed \<circ> \<sigma>) \<cdot> Term.embed v)\<close> \<open>a = (u, v)\<close> \<open>embed_eq (m_sapply_eq \<sigma> a) = (Term.embed (m_sapply \<sigma> u), Term.embed (m_sapply \<sigma> v))\<close> embed_eq.simps by presburger
  qed
  then show ?case
    by (metis (no_types, lifting) Cons.IH embed_eqs.elims list.discI list.inject m_sapply_eqs.simps(2) sapply_eq_system_equiv_def)
qed

lemma m_fv_sapply_sdom_svran:
  assumes "x \<in> m_fv (m_sapply \<sigma> m)"
  shows "x \<in> (m_fv m - m_sdom \<sigma>) \<union> m_svran \<sigma>"
  using assms
  by (metis embed_sapply fv_sapply_sdom_svran link_fv link_sdom link_svran)

lemma m_lemma_3:
  assumes "m_unify U = Some \<sigma>"
  shows "m_fv_eqs (m_sapply_eqs \<sigma> U) \<subseteq> m_fv_eqs U"
    and "m_sdom \<sigma> \<subseteq> m_fv_eqs U"
    and "m_svran \<sigma> \<subseteq> m_fv_eqs U"
    and "m_sdom \<sigma> \<inter> m_svran \<sigma> = {}"
proof -
  obtain \<tau> where "unify (embed_eqs U) = Some \<tau>" using assms by fastforce
  moreover have "\<sigma> = msg_of_term \<circ> \<tau>" using \<open>unify (embed_eqs U) = Some \<tau>\<close> assms by auto
  moreover show "m_sdom \<sigma> \<subseteq> m_fv_eqs U"
  proof -
    have "m_sdom \<sigma> = sdom (embed \<circ> msg_of_term \<circ> \<tau>)" using link_sdom
      by (simp add: \<open>\<sigma> = msg_of_term \<circ> \<tau>\<close>)
    then have "... = sdom \<tau>" using calculation msg_term_tau by auto
    then have "... \<subseteq> fv_eq_system (embed_eqs U)" using calculation lemma_3_i_iii by blast
    then show ?thesis using \<open>m_sdom \<sigma> = sdom (Term.embed \<circ> msg_of_term \<circ> \<tau>)\<close> link_fv_eqs by auto
  qed
  moreover show "m_svran \<sigma> \<subseteq> m_fv_eqs U"
  proof -
    have "m_svran \<sigma> = svran (embed \<circ> msg_of_term \<circ> \<tau>)"
      using calculation(2) link_svran by auto
    then have "... = svran \<tau>" using calculation(1) msg_term_tau by auto
    then have "... \<subseteq> fv_eq_system (embed_eqs U)" using calculation lemma_3_i_iii by blast
    then show ?thesis
      using \<open>m_svran \<sigma> = svran (Term.embed \<circ> msg_of_term \<circ> \<tau>)\<close> \<open>svran (Term.embed \<circ> msg_of_term \<circ> \<tau>) = svran \<tau>\<close> link_fv_eqs by blast
  qed
  moreover show "m_fv_eqs (m_sapply_eqs \<sigma> U) \<subseteq> m_fv_eqs U"
  proof -
    have "m_fv_eqs (m_sapply_eqs \<sigma> U) = fv_eq_system (embed_eqs (m_sapply_eqs \<sigma> U))"
      by (simp add: link_fv_eqs)
    moreover have "embed_eqs (m_sapply_eqs \<sigma> U) = (embed \<circ> \<sigma>) \<cdot> (embed_eqs U)"
      by (simp add: m_sapply_embed)
    moreover have "fv_eq_system ((embed \<circ> \<sigma>) \<cdot> (embed_eqs U)) \<subseteq> fv_eq_system (embed_eqs U)"
      by (metis \<open>\<sigma> = msg_of_term \<circ> \<tau>\<close> \<open>unify (embed_eqs U) = Some \<tau>\<close> comp_assoc lemma_3_i_iii msg_term_tau)
    then show ?thesis by (simp add: calculation(2) link_fv_eqs)
  qed
  moreover show "m_sdom \<sigma> \<inter> m_svran \<sigma> = {}"
  proof -
    have "m_sdom \<sigma> \<inter> m_svran \<sigma> =  sdom (embed \<circ> msg_of_term \<circ> \<tau>) \<inter> svran (embed \<circ> msg_of_term \<circ> \<tau>)"
      using calculation(2) link_sdom link_svran by auto
    then have "... = sdom \<tau> \<inter> svran \<tau>" using calculation(1) msg_term_tau by auto
    moreover have "sdom \<tau> \<inter> svran \<tau> = {}"
      by (metis \<open>unify (embed_eqs U) = Some \<tau>\<close> lemma_3_iv)
    then show ?thesis
      using \<open>m_sdom \<sigma> \<inter> m_svran \<sigma> = sdom (Term.embed \<circ> msg_of_term \<circ> \<tau>) \<inter> svran (Term.embed \<circ> msg_of_term \<circ> \<tau>)\<close> calculation by blast
  qed
qed

end


header {* Cancelation of words of generators and their inverses *}

theory Cancelation
imports
  "~~/src/HOL/Proofs/Lambda/Commutation"
begin

text {*
This theory defines cancelation via relations. The one-step relation @{term
"cancels_to_1 a b"} describes that @{term b} is obtained from @{term a} by removing
exactly one pair of generators, while @{term cancels_to} is the reflexive
transitive hull of that relation. Due to confluence, this relation has a normal
form, allowing for the definition of @{term normalize}.
*}

subsection {* Auxiliary results *}

text {* Some lemmas that would be useful in a more general setting are
collected beforehand. *}

subsubsection {* Auxiliary results about relations *}

text {*
These were helpfully provided by Andreas Lochbihler.
*}

theorem lconfluent_confluent:
  "\<lbrakk> wfP (R^--1); \<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow> \<exists>d. R^** b d \<and> R^** c d  \<rbrakk> \<Longrightarrow> confluent R"
by(auto simp add: diamond_def commute_def square_def intro: newman)

lemma confluentD:
  "\<lbrakk> confluent R; R^** a b; R^** a c  \<rbrakk> \<Longrightarrow> \<exists>d. R^** b d \<and> R^** c d"
by(auto simp add: commute_def diamond_def square_def)

lemma tranclp_DomainP: "R^++ a b \<Longrightarrow> DomainP R a"
by(auto elim: converse_tranclpE)

lemma confluent_unique_normal_form:
  "\<lbrakk> confluent R; R^** a b; R^** a c; \<not> DomainP R b; \<not> DomainP R c  \<rbrakk> \<Longrightarrow> b = c"
by(fastforce dest!: confluentD[of R a b c] dest: tranclp_DomainP rtranclpD[where a=b] rtranclpD[where a=c])

subsection {* Definition of the @{term "canceling"} relation *}

type_synonym 'a "g_i" = "(bool \<times> 'a)" (* A generator or its inverse *)
type_synonym 'a "word_g_i" = "'a g_i list" (* A word in the generators or their inverses *)

text {*
These type aliases encode the notion of a ``generator or its inverse''
(@{typ "'a g_i"}) and the notion of a ``word in generators and their inverses''
(@{typ "'a word_g_i"}), which form the building blocks of Free Groups.
*}

definition canceling :: "'a g_i \<Rightarrow> 'a g_i \<Rightarrow> bool"
 where "canceling a b = ((snd a = snd b) \<and> (fst a \<noteq> fst b))"

subsubsection {* Simple results about canceling *}

text {*
A generators cancels with its inverse, either way. The relation is symmetic.
*}

lemma cancel_cancel: "\<lbrakk> canceling a b; canceling b c \<rbrakk> \<Longrightarrow> a = c"
by (auto intro: prod_eqI simp add:canceling_def)

lemma cancel_sym: "canceling a b \<Longrightarrow> canceling b a"
by (simp add:canceling_def)

lemma cancel_sym_neg: "\<not>canceling a b \<Longrightarrow> \<not>canceling b a"
by (rule classical, simp add:canceling_def)

subsection {* Definition of the @{term "cancels_to"} relation *}

text {*
First, we define the function that removes the @{term i}th and @{text "(i+1)"}st
element from a word of generators, together with basic properties.
*}

definition cancel_at :: "nat \<Rightarrow> 'a word_g_i \<Rightarrow> 'a word_g_i"
where "cancel_at i l = take i l @ drop (2+i) l"

lemma cancel_at_length[simp]:
  "1+i < length l \<Longrightarrow> length (cancel_at i l) = length l - 2"
by(auto simp add: cancel_at_def)

lemma cancel_at_nth1[simp]:
  "\<lbrakk> n < i; 1+i < length l  \<rbrakk> \<Longrightarrow> (cancel_at i l) ! n = l ! n"
by(auto simp add: cancel_at_def nth_append)

lemma cancel_at_nth2[simp]:
  assumes "n \<ge> i" and "n < length l - 2"
  shows "(cancel_at i l) ! n = l ! (n + 2)"
proof-
  from `n \<ge> i` and `n < length l - 2`
  have "i = min (length l) i"
    by auto
  with `n \<ge> i` and `n < length l - 2`
  show "(cancel_at i l) ! n = l ! (n + 2)"
    by(auto simp add: cancel_at_def nth_append nth_via_drop)
qed

text {*
Then we can define the relation @{term "cancels_to_1_at i a b"} which specifies
that @{term b} can be obtained by @{term a} by canceling the @{term i}th and
@{text "(i+1)"}st position.

Based on that, we existentially quantify over the position @{text i} to obtain
the relation @{text "cancels_to_1"}, of which @{text "cancels_to"} is the
reflexive and transitive closure.

A word is @{text "canceled"} if it can not be canceled any futher.
*}

definition cancels_to_1_at ::  "nat \<Rightarrow> 'a word_g_i \<Rightarrow> 'a word_g_i \<Rightarrow> bool"
where  "cancels_to_1_at i l1 l2 = (0\<le>i \<and> (1+i) < length l1
                              \<and> canceling (l1 ! i) (l1 ! (1+i))
                              \<and> (l2 = cancel_at i l1))"

definition cancels_to_1 :: "'a word_g_i \<Rightarrow> 'a word_g_i \<Rightarrow> bool"
where "cancels_to_1 l1 l2 = (\<exists>i. cancels_to_1_at i l1 l2)"

definition cancels_to  :: "'a word_g_i \<Rightarrow> 'a word_g_i \<Rightarrow> bool"
where "cancels_to = cancels_to_1^**"

lemma cancels_to_trans [trans]:
  "\<lbrakk> cancels_to a b; cancels_to b c \<rbrakk> \<Longrightarrow> cancels_to a c"
by (auto simp add:cancels_to_def)

definition canceled :: "'a word_g_i \<Rightarrow> bool"
 where "canceled l = (\<not> DomainP cancels_to_1 l)"

(* Alternative view on cancelation, sometimes easier to work with *)
lemma cancels_to_1_unfold:
  assumes "cancels_to_1 x y"
  obtains xs1 x1 x2 xs2
  where "x = xs1 @ x1 # x2 # xs2"
    and "y = xs1 @ xs2"
    and "canceling x1 x2"
proof-
  assume a: "(\<And>xs1 x1 x2 xs2. \<lbrakk>x = xs1 @ x1 # x2 # xs2; y = xs1 @ xs2; canceling x1 x2\<rbrakk> \<Longrightarrow> thesis)"
  from `cancels_to_1 x y`
  obtain i where "cancels_to_1_at i x y"
    unfolding cancels_to_1_def by auto
  hence "canceling (x ! i) (x ! Suc i)"
    and "y = (take i x) @ (drop (Suc (Suc i)) x)"
    and "x = (take i x) @ x ! i # x ! Suc i # (drop (Suc (Suc i)) x)"
    unfolding cancel_at_def and cancels_to_1_at_def by (auto simp add: Cons_nth_drop_Suc)
  with a show thesis by blast
qed

(* And the reverse direction *)
lemma cancels_to_1_fold:
  "canceling x1 x2 \<Longrightarrow> cancels_to_1 (xs1 @ x1 # x2 # xs2) (xs1 @ xs2)"
unfolding cancels_to_1_def and cancels_to_1_at_def and cancel_at_def
by (rule_tac x="length xs1" in exI, auto simp add:nth_append)

subsubsection {* Existence of the normal form *}

text {*
One of two steps to show that we have a normal form is the following lemma,
guaranteeing that by canceling, we always end up at a fully canceled word.
*}

lemma canceling_terminates: "wfP (cancels_to_1^--1)"
proof-
  have "wf (measure length)" by auto
  moreover
  have "{(x, y). cancels_to_1 y x} \<subseteq> measure length"
    by (auto simp add: cancels_to_1_def cancel_at_def cancels_to_1_at_def)
  ultimately
  have "wf {(x, y). cancels_to_1 y x}"
    by(rule wf_subset)
  thus ?thesis by (simp add:wfP_def)
qed

text {*
The next two lemmas prepare for the proof of confluence. It does not matter in
which order we cancel, we can obtain the same result.
*}

lemma canceling_neighbor:
  assumes "cancels_to_1_at i l a" and "cancels_to_1_at (Suc i) l b"
  shows "a = b"
proof-
  from `cancels_to_1_at i l a`
    have "canceling (l ! i) (l ! Suc i)" and "i < length l"
    by (auto simp add: cancels_to_1_at_def)

  from `cancels_to_1_at (Suc i) l b`
    have "canceling (l ! Suc i) (l ! Suc (Suc i))" and "Suc (Suc i) < length l"
    by (auto simp add: cancels_to_1_at_def)

  from `canceling (l ! i) (l ! Suc i)` and `canceling (l ! Suc i) (l ! Suc (Suc i))`
    have "l ! i = l ! Suc (Suc i)" by (rule cancel_cancel)

  from `cancels_to_1_at (Suc i) l b`
    have "b = take (Suc i) l @ drop (Suc (Suc (Suc i))) l"
    by (simp add: cancels_to_1_at_def cancel_at_def)
  also from `i < length l`
  have "\<dots> = take i l @ [l ! i] @ drop (Suc (Suc (Suc i))) l"
    by(auto simp add: take_Suc_conv_app_nth)
  also from `l ! i = l ! Suc (Suc i)`
  have "\<dots> = take i l @ [l ! Suc (Suc i)] @ drop (Suc (Suc (Suc i))) l"
    by simp
  also from `Suc (Suc i) < length l`
  have "\<dots> = take i l @ drop (Suc (Suc i)) l"
    by (simp add: Cons_nth_drop_Suc)
  also from `cancels_to_1_at i l a` have "\<dots> = a"
    by (simp add: cancels_to_1_at_def cancel_at_def)
  finally show "a = b" by(rule sym)
qed

lemma canceling_indep:
  assumes "cancels_to_1_at i l a" and "cancels_to_1_at j l b" and "j > Suc i"
  obtains c where "cancels_to_1_at (j - 2) a c" and "cancels_to_1_at i b c"
proof(atomize_elim)
  from `cancels_to_1_at i l a`
    have "Suc i < length l"
     and "canceling (l ! i) (l ! Suc i)"
     and "a = cancel_at i l"
     and "length a = length l - 2"
     and "min (length l) i = i"
    by (auto simp add:cancels_to_1_at_def)
  from `cancels_to_1_at j l b`
    have "Suc j < length l"
     and "canceling (l ! j) (l ! Suc j)"
     and "b = cancel_at j l"
     and "length b = length l - 2"
    by (auto simp add:cancels_to_1_at_def)

  let ?c = "cancel_at (j - 2) a"
  from `j > Suc i`
  have "Suc (Suc (j - 2)) = j"
    and "Suc (Suc (Suc j - 2)) = Suc j"
    by auto
  with `min (length l) i = i` and `j > Suc i` and `Suc j < length l`
  have "(l ! j) = (cancel_at i l ! (j - 2))"
    and "(l ! (Suc j)) = (cancel_at i l ! Suc (j - 2))"
    by(auto simp add:cancel_at_def simp add:nth_append)

  with `cancels_to_1_at i l a`
    and `cancels_to_1_at j l b`
  have "canceling (a ! (j - 2)) (a ! Suc (j - 2))"
    by(auto simp add:cancels_to_1_at_def)

  with `j > Suc i` and `Suc j < length l` and `length a = length l - 2`
  have "cancels_to_1_at (j - 2) a ?c" by (auto simp add: cancels_to_1_at_def)

  from `length b = length l - 2` and `j > Suc i` and `Suc j < length l`
  have "Suc i < length b" by auto

  moreover from `b = cancel_at j l` and `j > Suc i` and `Suc i < length l`
  have "(b ! i) = (l ! i)" and "(b ! Suc i) = (l ! Suc i)"
    by (auto simp add:cancel_at_def nth_append)
  with `canceling (l ! i) (l ! Suc i)`
  have "canceling (b ! i) (b ! Suc i)" by simp

  moreover from `j > Suc i` and `Suc j < length l`
  have "min i j = i"
    and "min (j - 2) i = i"
    and "min (length l) j = j"
    and "min (length l) i = i"
    and "Suc (Suc (j - 2)) = j"
    by auto
  with `a = cancel_at i l` and `b = cancel_at j l` and `Suc (Suc (j - 2)) = j`
  have "cancel_at (j - 2) a = cancel_at i b"
    by (auto simp add:cancel_at_def take_drop)

  ultimately have "cancels_to_1_at i b (cancel_at (j - 2) a)"
    by (auto simp add:cancels_to_1_at_def)

  with `cancels_to_1_at (j - 2) a ?c`
  show "\<exists>c. cancels_to_1_at (j - 2) a c \<and> cancels_to_1_at i b c" by blast
qed

text {* This is the confluence lemma *}
lemma confluent_cancels_to_1: "confluent cancels_to_1"
proof(rule lconfluent_confluent)
  show "wfP cancels_to_1\<inverse>\<inverse>" by (rule canceling_terminates)
next
  fix a b c
  assume "cancels_to_1 a b"
  then obtain i where "cancels_to_1_at i a b"
    by(simp add: cancels_to_1_def)(erule exE)
  assume "cancels_to_1 a c"
  then obtain j where "cancels_to_1_at j a c"
    by(simp add: cancels_to_1_def)(erule exE)

  show "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d"
  proof (cases "i=j")
    assume "i=j"
    from `cancels_to_1_at i a b`
      have "b = cancel_at i a" by (simp add:cancels_to_1_at_def)
    moreover from `i=j`
      have "\<dots> = cancel_at j a" by (clarify)
    moreover from `cancels_to_1_at j a c`
      have "\<dots> = c" by (simp add:cancels_to_1_at_def)
    ultimately have "b = c" by (simp)
    hence "cancels_to_1\<^sup>*\<^sup>* b b"
      and "cancels_to_1\<^sup>*\<^sup>* c b" by auto
    thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by blast
  next
    assume "i \<noteq> j"
    show ?thesis
    proof (cases "j = Suc i")
      assume "j = Suc i"
        with `cancels_to_1_at i a b` and `cancels_to_1_at j a c`
        have "b = c" by (auto elim: canceling_neighbor)
      hence "cancels_to_1\<^sup>*\<^sup>* b b"
        and "cancels_to_1\<^sup>*\<^sup>* c b" by auto
      thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by blast
    next
      assume "j \<noteq> Suc i"
      show ?thesis
      proof (cases "i = Suc j")
        assume "i = Suc j"
          with `cancels_to_1_at i a b` and `cancels_to_1_at j a c`
          have "c = b" by (auto elim: canceling_neighbor)
        hence "cancels_to_1\<^sup>*\<^sup>* b b"
          and "cancels_to_1\<^sup>*\<^sup>* c b" by auto
        thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by blast
      next
        assume "i \<noteq> Suc j"
        show ?thesis
        proof (cases "i < j")
          assume "i < j"
            with `j \<noteq> Suc i` have "Suc i < j" by auto
          with `cancels_to_1_at i a b` and `cancels_to_1_at j a c`
          obtain d where "cancels_to_1_at (j - 2) b d" and "cancels_to_1_at i c d"
            by(erule canceling_indep)
          hence "cancels_to_1 b d" and "cancels_to_1 c d"
            by (auto simp add:cancels_to_1_def)
          thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by (auto)
        next
          assume "\<not> i < j"
          with `j \<noteq> Suc i` and `i \<noteq> j` and `i \<noteq> Suc j` have "Suc j < i" by auto
          with `cancels_to_1_at i a b` and `cancels_to_1_at j a c`
          obtain d where "cancels_to_1_at (i - 2) c d" and "cancels_to_1_at j b d"
            by -(erule canceling_indep)
          hence "cancels_to_1 b d" and "cancels_to_1 c d"
            by (auto simp add:cancels_to_1_def)
          thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by (auto)
        qed
      qed
    qed
  qed
qed

text {*
And finally, we show that there exists a unique normal form for each word.
*}

(*
lemma inv_rtrcl: "R^**^--1 = R^--1^**" (* Did I overlook this in the standard libs? *)
by (auto simp add:fun_eq_iff intro: dest:rtranclp_converseD intro:rtranclp_converseI)
*)
lemma norm_form_uniq:
  assumes "cancels_to a b"
      and "cancels_to a c"
      and "canceled b"
      and "canceled c"
  shows "b = c"
proof-
  have "confluent cancels_to_1" by (rule confluent_cancels_to_1)
  moreover
  from `cancels_to a b` have "cancels_to_1^** a b" by (simp add: cancels_to_def)
  moreover
  from `cancels_to a c` have "cancels_to_1^** a c" by (simp add: cancels_to_def)
  moreover
  from `canceled b` have "\<not> DomainP cancels_to_1 b" by (simp add: canceled_def)
  moreover
  from `canceled c` have "\<not> DomainP cancels_to_1 c" by (simp add: canceled_def)
  ultimately
  show "b = c"
    by (rule confluent_unique_normal_form)
qed

subsubsection {* Some properties of cancelation *}

text {*
Distributivity rules of cancelation and @{text append}.
*}

lemma cancel_to_1_append:
  assumes "cancels_to_1 a b"
  shows "cancels_to_1 (l@a@l') (l@b@l')"
proof-
  from `cancels_to_1 a b` obtain i where "cancels_to_1_at i a b"
    by(simp add: cancels_to_1_def)(erule exE)
  hence "cancels_to_1_at (length l + i) (l@a@l') (l@b@l')"
    by (auto simp add:cancels_to_1_at_def nth_append cancel_at_def)
  thus "cancels_to_1 (l@a@l') (l@b@l')"
    by (auto simp add: cancels_to_1_def)
qed

lemma cancel_to_append:
  assumes "cancels_to a b"
  shows "cancels_to (l@a@l') (l@b@l')"
using assms
unfolding cancels_to_def
proof(induct)
  case base show ?case by (simp add:cancels_to_def)
next
  case (step b c)
  from `cancels_to_1 b c`
  have "cancels_to_1 (l @ b @ l') (l @ c @ l')" by (rule cancel_to_1_append)
  with `cancels_to_1^** (l @ a @ l') (l @ b @ l')` show ?case
    by (auto simp add:cancels_to_def)
qed

lemma cancels_to_append2:
  assumes "cancels_to a a'"
      and "cancels_to b b'"
  shows "cancels_to (a@b) (a'@b')"
using `cancels_to a a'`
unfolding cancels_to_def
proof(induct)
  case base
  from `cancels_to b b'` have "cancels_to (a@b@[]) (a@b'@[])"
    by (rule cancel_to_append)
  thus ?case unfolding cancels_to_def by simp
next
  case (step ba c)
  from `cancels_to_1 ba c` have "cancels_to_1 ([]@ba@b') ([]@c@b')"
    by(rule cancel_to_1_append)
  with `cancels_to_1^** (a @ b) (ba @ b')`
  show ?case unfolding cancels_to_def by simp
qed

text {*
The empty list is canceled, a one letter word is canceled and a word is
trivially cancled from itself.
*}

lemma empty_canceled[simp]: "canceled []"
by(auto simp add: canceled_def cancels_to_1_def cancels_to_1_at_def)

lemma singleton_canceled[simp]: "canceled [a]"
by(auto simp add: canceled_def cancels_to_1_def cancels_to_1_at_def)

lemma cons_canceled:
  assumes "canceled (a#x)"
  shows   "canceled x"
proof(rule ccontr)
  assume "\<not> canceled x"
  hence "DomainP cancels_to_1 x" by (simp add:canceled_def)
  then obtain x' where "cancels_to_1 x x'" by auto
  then obtain xs1 x1 x2 xs2
    where x: "x = xs1 @ x1 # x2 # xs2"
    and   "canceling x1 x2" by (rule cancels_to_1_unfold)
  hence "cancels_to_1 ((a#xs1) @ x1 # x2 # xs2) ( (a#xs1) @ xs2)"
    by (auto intro:cancels_to_1_fold simp del:append_Cons)
  with x
  have "cancels_to_1 (a#x) (a#xs1 @ xs2)"
    by simp
  hence "\<not> canceled (a#x)" by (auto simp add:canceled_def)
  thus False using `canceled (a#x)` by contradiction
qed

lemma cancels_to_self[simp]: "cancels_to l l"
by (simp add:cancels_to_def)

subsection {* Definition of normalization *}

text {*
Using the THE construct, we can define the normalization function
@{text normalize} as the unique fully cancled word that the argument cancels
to.
*}

definition normalize :: "'a word_g_i \<Rightarrow> 'a word_g_i"
where "normalize l = (THE l'. cancels_to l l' \<and> canceled l')"

text {*
Some obvious properties of the normalize function, and other useful lemmas.
*}

lemma
  shows normalized_canceled[simp]: "canceled (normalize l)"
  and   normalized_cancels_to[simp]: "cancels_to l (normalize l)"
proof-
  let ?Q = "{l'. cancels_to_1^** l l'}"
  have "l \<in> ?Q" by (auto) hence "\<exists>x. x \<in> ?Q" by (rule exI)

  have "wfP cancels_to_1^--1"
    by (rule canceling_terminates)
  hence "\<forall>Q. (\<exists>x. x \<in> Q) \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. cancels_to_1 z y \<longrightarrow> y \<notin> Q)"
    by (simp add:wfP_eq_minimal)
  hence "(\<exists>x. x \<in> ?Q) \<longrightarrow> (\<exists>z\<in>?Q. \<forall>y. cancels_to_1 z y \<longrightarrow> y \<notin> ?Q)"
    by (erule_tac x="?Q" in allE)
  then obtain l' where "l' \<in> ?Q" and minimal: "\<And>y. cancels_to_1 l' y \<Longrightarrow> y \<notin> ?Q"
    by auto

  from `l' \<in> ?Q` have "cancels_to l l'" by (auto simp add: cancels_to_def)

  have "canceled l'"
  proof(rule ccontr)
    assume "\<not> canceled l'" hence "DomainP cancels_to_1 l'" by (simp add: canceled_def)
    then obtain y where "cancels_to_1 l' y" by auto
    with `cancels_to l l'` have "cancels_to l y" by (auto simp add: cancels_to_def)
    from `cancels_to_1 l' y` have "y \<notin> ?Q" by(rule minimal)
    hence "\<not> cancels_to_1^** l y" by auto
    hence "\<not> cancels_to l y" by (simp add: cancels_to_def)
    with `cancels_to l y` show False by contradiction
  qed

  from `cancels_to l l'` and `canceled l'`
  have "cancels_to l l' \<and> canceled l'" by simp
  hence "cancels_to l (normalize l) \<and> canceled (normalize l)"
    unfolding normalize_def
  proof (rule theI)
    fix l'a
    assume "cancels_to l l'a \<and> canceled l'a"
    thus "l'a = l'" using `cancels_to l l' \<and> canceled l'` by (auto elim:norm_form_uniq)
  qed
  thus "canceled (normalize l)" and "cancels_to l (normalize l)" by auto
qed

lemma normalize_discover:
  assumes "canceled l'"
      and "cancels_to l l'"
  shows "normalize l = l'"
proof-
  from `canceled l'` and `cancels_to l l'`
  have "cancels_to l l' \<and> canceled l'" by auto
  thus ?thesis unfolding normalize_def by (auto elim:norm_form_uniq)
qed

text {* Words, related by cancelation, have the same normal form. *}

lemma normalize_canceled[simp]:
  assumes "cancels_to l l'"
  shows   "normalize l = normalize l'"
proof(rule normalize_discover)
  show "canceled (normalize l')" by (rule normalized_canceled)
next
  have "cancels_to l' (normalize l')" by (rule normalized_cancels_to)
  with `cancels_to l l'`
  show "cancels_to l (normalize l')" by (rule cancels_to_trans)
qed

text {* Normalization is idempotent. *}

lemma normalize_idemp[simp]:
  assumes "canceled l"
  shows "normalize l = l"
using assms
by(rule normalize_discover)(rule cancels_to_self)

text {*
This lemma lifts the distributivity results from above to the normalize
function.
*}

lemma normalize_append_cancel_to:
  assumes "cancels_to l1 l1'"
  and     "cancels_to l2 l2'"
  shows "normalize (l1 @ l2) = normalize (l1' @ l2')"
proof(rule normalize_discover)
  show "canceled (normalize (l1' @ l2'))" by (rule normalized_canceled)
next
  from `cancels_to l1 l1'` and `cancels_to l2 l2'`
  have "cancels_to (l1 @ l2) (l1' @ l2')" by (rule cancels_to_append2)
  also
  have "cancels_to (l1' @ l2') (normalize (l1' @ l2'))" by (rule normalized_cancels_to)
  finally
  show "cancels_to (l1 @ l2) (normalize (l1' @ l2'))".
qed

subsection {* Normalization preserves generators *}

text {*
Somewhat obvious, but still required to formalize Free Groups, is the fact that
canceling a word of generators of a specific set (and their inverses) results
in a word in generators from that set.
*}

lemma cancels_to_1_preserves_generators:
  assumes "cancels_to_1 l l'"
      and "l \<in> lists (UNIV \<times> gens)"
  shows "l' \<in> lists (UNIV \<times> gens)"
proof-
  from assms obtain i where "l' = cancel_at i l"
    unfolding cancels_to_1_def and cancels_to_1_at_def by auto
  hence "l' = take i l @ drop (2 + i) l" unfolding cancel_at_def .
  hence "set l' = set (take i l @ drop (2 + i) l)" by simp
  moreover
  have "\<dots> = set (take i l @ drop (2 + i) l)" by auto
  moreover
  have "\<dots> \<subseteq> set (take i l) \<union> set (drop (2 + i) l)" by auto
  moreover
  have "\<dots> \<subseteq> set l" by (auto dest: in_set_takeD in_set_dropD)
  ultimately
  have "set l' \<subseteq> set l" by simp
  thus ?thesis using assms(2) by auto
qed

lemma cancels_to_preserves_generators:
  assumes "cancels_to l l'"
      and "l \<in> lists (UNIV \<times> gens)"
  shows "l' \<in> lists (UNIV \<times> gens)"
using assms unfolding cancels_to_def by (induct, auto dest:cancels_to_1_preserves_generators)

lemma normalize_preserves_generators:
  assumes "l \<in> lists (UNIV \<times> gens)"
    shows "normalize l \<in> lists (UNIV \<times> gens)"
proof-
  have "cancels_to l (normalize l)" by simp
  thus ?thesis using assms by(rule cancels_to_preserves_generators)
qed

text {*
Two simplification lemmas about lists.
*}

lemma empty_in_lists[simp]:
  "[] \<in> lists A" by auto

lemma lists_empty[simp]: "lists {} = {[]}"
  by auto

subsection {* Normalization and renaming generators *}

text {*
Renaming the generators, i.e. mapping them through an injective function, commutes
with normalization. Similarly, replacing generators by their inverses and
vica-versa commutes with normalization. Both operations are similar enough to be
handled at once here.
*}

lemma rename_gens_cancel_at: "cancel_at i (map f l) = map f (cancel_at i l)"
unfolding "cancel_at_def" by (auto simp add:take_map drop_map)

lemma rename_gens_cancels_to_1:
  assumes "inj f"
      and "cancels_to_1 l l'"
    shows "cancels_to_1 (map (map_prod f g) l) (map (map_prod f g) l')"
proof-
  from `cancels_to_1 l l'`
  obtain ls1 l1 l2 ls2
    where "l = ls1 @ l1 # l2 # ls2"
      and "l' = ls1 @ ls2"
      and "canceling l1 l2"
  by (rule cancels_to_1_unfold)

  from `canceling l1 l2`
  have "fst l1 \<noteq> fst l2" and "snd l1 = snd l2"
    unfolding canceling_def by auto
  from `fst l1 \<noteq> fst l2` and `inj f`
  have "f (fst l1) \<noteq> f (fst l2)" by(auto dest!:inj_on_contraD)
  hence "fst (map_prod f g l1) \<noteq> fst (map_prod f g l2)" by auto
  moreover
  from `snd l1 = snd l2`
  have "snd (map_prod f g l1) = snd (map_prod f g l2)" by auto
  ultimately
  have "canceling (map_prod f g (l1)) (map_prod f g (l2))"
    unfolding canceling_def by auto
  hence "cancels_to_1 (map (map_prod f g) ls1 @ map_prod f g l1 # map_prod f g l2 # map (map_prod f g) ls2) (map (map_prod f g) ls1 @ map (map_prod f g) ls2)"
   by(rule cancels_to_1_fold)
  with `l = ls1 @ l1 # l2 # ls2` and `l' = ls1 @ ls2`
  show "cancels_to_1 (map (map_prod f g) l) (map (map_prod f g) l')"
   by simp
qed

lemma rename_gens_cancels_to:
  assumes "inj f"
      and "cancels_to l l'"
    shows "cancels_to (map (map_prod f g) l) (map (map_prod f g) l')"
using `cancels_to l l'`
unfolding cancels_to_def
proof(induct rule:rtranclp_induct)
  case (step x z)
    from `cancels_to_1 x z` and `inj f`
    have "cancels_to_1 (map (map_prod f g) x) (map (map_prod f g) z)"
      by -(rule rename_gens_cancels_to_1)
    with `cancels_to_1^** (map (map_prod f g) l) (map (map_prod f g) x)`
    show "cancels_to_1^** (map (map_prod f g) l) (map (map_prod f g) z)" by auto
qed(auto)

lemma rename_gens_canceled:
  assumes "inj_on g (snd`set l)"
      and "canceled l"
  shows "canceled (map (map_prod f g) l)"
unfolding canceled_def
proof
  (* This statement is needed explicitly later in this proof *)
  have different_images: "\<And> f a b. f a \<noteq> f b \<Longrightarrow> a \<noteq> b" by auto

  assume "DomainP cancels_to_1 (map (map_prod f g) l)"
  then obtain l' where "cancels_to_1 (map (map_prod f g) l) l'" by auto
  then obtain i where "Suc i < length l"
    and "canceling (map (map_prod f g) l ! i) (map (map_prod f g) l ! Suc i)"
    by(auto simp add:cancels_to_1_def cancels_to_1_at_def)
  hence "f (fst (l ! i)) \<noteq> f (fst (l ! Suc i))"
    and "g (snd (l ! i)) = g (snd (l ! Suc i))"
    by(auto simp add:canceling_def)
  from `f (fst (l ! i)) \<noteq> f (fst (l ! Suc i))`
  have "fst (l ! i) \<noteq> fst (l ! Suc i)" by -(erule different_images)
  moreover
  from `Suc i < length l`
  have "snd (l ! i) \<in> snd ` set l" and "snd (l ! Suc i) \<in> snd ` set l" by auto
  with `g (snd (l ! i)) = g (snd (l ! Suc i))`
  have "snd (l ! i) = snd (l ! Suc i)"
    using `inj_on g (image snd (set l))`
    by (auto dest: inj_onD)
  ultimately
  have "canceling (l ! i) (l ! Suc i)" unfolding canceling_def by simp
  with `Suc i < length l`
  have "cancels_to_1_at i l (cancel_at i l)"
    unfolding cancels_to_1_at_def by auto
  hence "cancels_to_1 l (cancel_at i l)"
    unfolding cancels_to_1_def by auto
  hence "\<not>canceled l"
    unfolding canceled_def by auto
  with `canceled l` show False by contradiction
qed

lemma rename_gens_normalize:
  assumes "inj f"
  and "inj_on g (snd ` set l)"
  shows "normalize (map (map_prod f g) l) = map (map_prod f g) (normalize l)"
proof(rule normalize_discover)
  from `inj_on g (image snd (set l))`
  have "inj_on g (image snd (set (normalize l)))"
  proof (rule subset_inj_on)

    have UNIV_snd: "\<And>A. A \<subseteq> UNIV \<times> snd ` A"
      proof fix A and x::"'c\<times>'d" assume "x\<in>A"
        hence "(fst x,snd x)\<in> (UNIV \<times> snd ` A)"
          by -(rule, auto)
        thus "x\<in> (UNIV \<times> snd ` A)" by simp
      qed

    have "l \<in> lists (set l)" by auto
    hence "l \<in> lists (UNIV \<times> snd ` set l)"
      by (rule subsetD[OF lists_mono[OF UNIV_snd], of l "set l"])
    hence "normalize l \<in> lists (UNIV \<times> snd ` set l)"
      by (rule normalize_preserves_generators[of _ "snd ` set l"])
    thus "snd ` set (normalize l) \<subseteq> snd ` set l"
      by (auto simp add: lists_eq_set)
   qed
  thus "canceled (map (map_prod f g) (normalize l))" by(rule rename_gens_canceled,simp)
next
  from `inj f`
  show "cancels_to (map (map_prod f g) l) (map (map_prod f g) (normalize l))"
    by (rule rename_gens_cancels_to, simp)
qed

end


section\<open>Designs\<close>

theory Designs
imports Relations
begin

text \<open>In UTP, in order to explicitly record the termination of a program,
a subset of alphabetized relations is introduced. These relations are called
designs and their alphabet should contain the special boolean observational variable ok.
It is used to record the start and termination of a program.\<close>

subsection\<open>Definitions\<close>

text \<open>In the following, the definitions of designs alphabets, designs and
healthiness (well-formedness) conditions are given. The healthiness conditions of
designs are defined by $H1$, $H2$, $H3$ and $H4$.\<close>

record alpha_d = ok::bool

type_synonym '\<alpha> alphabet_d  = "'\<alpha> alpha_d_scheme alphabet"
type_synonym '\<alpha> relation_d = "'\<alpha> alphabet_d relation"

definition design::"'\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d" ("'(_ \<turnstile> _')")
where " (P \<turnstile> Q) \<equiv> \<lambda> (A, A') .  (ok A \<and> P (A,A')) \<longrightarrow> (ok A' \<and> Q (A,A'))"

definition skip_d :: "'\<alpha> relation_d" ("\<Pi>d")
where "\<Pi>d \<equiv> (true \<turnstile> \<Pi>r)"

definition J
where "J  \<equiv>  \<lambda> (A, A') . (ok A  \<longrightarrow>  ok A') \<and> more A = more A'"

type_synonym '\<alpha> Healthiness_condition = "'\<alpha> relation \<Rightarrow> '\<alpha> relation"

definition
Healthy::"'\<alpha> relation \<Rightarrow> '\<alpha> Healthiness_condition \<Rightarrow> bool" ("_ is _ healthy")
where "P is H healthy \<equiv> (P = H P)"

lemma Healthy_def': "P is H healthy = (H P = P)"
  unfolding Healthy_def by auto

definition H1::"('\<alpha> alphabet_d) Healthiness_condition"
where "H1 (P)  \<equiv>  (ok o fst  \<longrightarrow> P)"

definition H2::"('\<alpha> alphabet_d) Healthiness_condition"
where "H2 (P)  \<equiv>  P ;; J"

definition H3::"('\<alpha> alphabet_d) Healthiness_condition"
where "H3 (P)  \<equiv>  P ;; \<Pi>d"

definition H4::"('\<alpha> alphabet_d) Healthiness_condition"
where "H4 (P)  \<equiv>  ((P;;true) \<longleftrightarrow> true)"

definition \<sigma>f::"'\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d"
where "\<sigma>f D \<equiv> \<lambda> (A, A') . D (A, A'\<lparr>ok:=False\<rparr>)"

definition \<sigma>t::"'\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d"
where "\<sigma>t D \<equiv> \<lambda> (A, A') . D (A, A'\<lparr>ok:=True\<rparr>)"

definition OKAY::"'\<alpha> relation_d"
where "OKAY \<equiv> \<lambda> (A, A') . ok A"

definition OKAY'::"'\<alpha> relation_d"
where "OKAY' \<equiv> \<lambda> (A, A') . ok A'"

lemmas design_defs = design_def skip_d_def J_def Healthy_def H1_def H2_def H3_def
                     H4_def \<sigma>f_def \<sigma>t_def OKAY_def OKAY'_def

subsection\<open>Proofs\<close>

text \<open>Proof of theorems and properties of designs and their healthiness conditions
are given in the following.\<close>

lemma t_comp_lz_d: "(true;;(P \<turnstile> Q)) = true"
  apply (auto simp: fun_eq_iff design_defs)
  apply (rule_tac b="b\<lparr>ok:=False\<rparr>" in comp_intro, auto)
done

lemma pi_comp_left_unit: "(\<Pi>d;;(P \<turnstile> Q)) = (P \<turnstile> Q)"
by (auto simp: fun_eq_iff design_defs)

theorem t3_1_4_2:
"((P1 \<turnstile> Q1) \<triangleleft> b \<triangleright> (P2 \<turnstile> Q2)) = ((P1 \<triangleleft> b \<triangleright> P2) \<turnstile> (Q1 \<triangleleft> b \<triangleright> Q2))"
by (auto simp: fun_eq_iff design_defs split: cond_splits)

lemma conv_conj_distr: "\<sigma>t (P \<and> Q) = (\<sigma>t P \<and> \<sigma>t Q)"
by (auto simp: design_defs fun_eq_iff)

lemma conv_disj_distr: "\<sigma>t (P \<or> Q) = (\<sigma>t P \<or> \<sigma>t Q)"
by (auto simp: design_defs fun_eq_iff)

lemma conv_imp_distr: "\<sigma>t (P \<longrightarrow> Q) = ((\<sigma>t P) \<longrightarrow> \<sigma>t Q)"
by (auto simp: design_defs fun_eq_iff)

lemma conv_not_distr: "\<sigma>t (\<not> P) = (\<not>(\<sigma>t P))"
by (auto simp: design_defs fun_eq_iff)

lemma div_conj_distr: "\<sigma>f (P \<and> Q) = (\<sigma>f P \<and> \<sigma>f Q)"
by (auto simp: design_defs fun_eq_iff)

lemma div_disj_distr: "\<sigma>f (P \<or> Q) = (\<sigma>f P \<or> \<sigma>f Q)"
by (auto simp: design_defs fun_eq_iff)

lemma div_imp_distr: "\<sigma>f (P \<longrightarrow> Q) = ((\<sigma>f P) \<longrightarrow> \<sigma>f Q)"
by (auto simp: design_defs fun_eq_iff)

lemma div_not_distr: "\<sigma>f (\<not> P) = (\<not>(\<sigma>f P))"
by (auto simp: design_defs fun_eq_iff)

lemma ok_conv: "\<sigma>t OKAY = OKAY"
by (auto simp: design_defs fun_eq_iff)

lemma ok_div: "\<sigma>f OKAY = OKAY"
by (auto simp: design_defs fun_eq_iff)

lemma ok'_conv: "\<sigma>t OKAY' = true"
by (auto simp: design_defs fun_eq_iff)

lemma ok'_div: "\<sigma>f OKAY' = false"
by (auto simp: design_defs fun_eq_iff)

lemma H2_J_1:
 assumes A: "P is H2 healthy"
 shows "[(\<lambda> (A, A'). (P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)))]"
using A by (auto simp: design_defs fun_eq_iff)

lemma H2_J_2_a : "P (a,b) \<longrightarrow> (P ;; J) (a,b)"
  unfolding J_def by auto

lemma ok_or_not_ok : "\<lbrakk>P(a, b\<lparr>ok := True\<rparr>); P(a, b\<lparr>ok := False\<rparr>)\<rbrakk> \<Longrightarrow> P(a, b)"
  apply (case_tac "ok b")
  apply (subgoal_tac "b\<lparr>ok:=True\<rparr> = b")
  apply (simp_all)
  apply (subgoal_tac "b\<lparr>ok:=False\<rparr> = b")
  apply (simp_all)
done

lemma H2_J_2_b :
  assumes A: "[(\<lambda> (A, A'). (P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)))]"
  and B : "(P ;; J) (a,b)"
  shows "P (a,b)"
  using B
  apply (auto simp: design_defs fun_eq_iff)
  apply (case_tac "ok b")
  apply (subgoal_tac "b = ba\<lparr>ok:=True\<rparr>", auto intro!: A[simplified, rule_format])
  apply (rule_tac s=ba and t="ba\<lparr>ok:=False\<rparr>" in subst, simp_all)
  apply (subgoal_tac "b = ba", simp_all)
  apply (case_tac "ok ba")
  apply (subgoal_tac "b = ba", simp_all)
  apply (subgoal_tac "b = ba\<lparr>ok:=True\<rparr>", auto intro!: A[simplified, rule_format])
  apply (rule_tac s=ba and t="ba\<lparr>ok:=False\<rparr>" in subst, simp_all)
done

lemma H2_J_2 :
  assumes A: "[(\<lambda> (A, A'). (P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)))]"
  shows "P is H2 healthy "
  apply (auto simp add: H2_def Healthy_def fun_eq_iff)
  apply (simp add: H2_J_2_a)
  apply (rule H2_J_2_b [OF A])
  apply auto
  done

lemma H2_J:
"[\<lambda> (A, A'). P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)] = P is H2 healthy"
using H2_J_1 H2_J_2 by blast

lemma design_eq1: "(P \<turnstile> Q) = (P \<turnstile> P \<and> Q)"
by (rule ext) (auto simp: design_defs)

lemma H1_idem: "H1 o H1 = H1"
by (auto simp: design_defs fun_eq_iff)

lemma H1_idem2: "(H1 (H1 P)) = (H1 P)"
by (simp add: H1_idem[simplified fun_eq_iff Fun.comp_def, rule_format] fun_eq_iff)

lemma H2_idem: "H2 o H2 = H2"
by (auto simp: design_defs fun_eq_iff)

lemma H2_idem2: "(H2 (H2 P)) = (H2 P)"
by (simp add: H2_idem[simplified fun_eq_iff Fun.comp_def, rule_format] fun_eq_iff)

lemma H1_H2_commute: "H1 o H2 = H2 o H1"
by (auto simp: design_defs fun_eq_iff split: cond_splits)

lemma H1_H2_commute2: "H1 (H2 P) = H2 (H1 P)"
by (simp add: H1_H2_commute[simplified fun_eq_iff Fun.comp_def, rule_format] fun_eq_iff)

lemma alpha_d_eqD: "r = r' \<Longrightarrow> ok r = ok r' \<and> alpha_d.more r = alpha_d.more r'"
by (auto simp: alpha_d.equality)

lemma design_H1: "(P \<turnstile> Q) is H1 healthy"
by (auto simp: design_defs fun_eq_iff)

lemma design_H2:
"(\<forall> a b. P (a, b\<lparr>ok := True\<rparr>) \<longrightarrow> P (a, b\<lparr>ok := False\<rparr>)) \<Longrightarrow> (P \<turnstile> Q) is H2 healthy"
by (rule H2_J_2) (auto simp: design_defs fun_eq_iff)

end


(*  Title:      statecharts/DataSpace/Contrib.thy
    Author:     Steffen Helke and Florian Kammüller, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

section \<open>Contributions to the Standard Library of HOL\<close>

theory Contrib
imports Main
begin

subsection \<open>Basic definitions and lemmas\<close>

subsubsection \<open>Lambda expressions\<close>

definition restrict :: "['a => 'b, 'a set] => ('a => 'b)" where
 "restrict f A = (%x. if x : A then f x else (@ y. True))"

syntax (ASCII)
  "_lambda_in" :: "[pttrn, 'a set, 'a => 'b] => ('a => 'b)"  ("(3%_:_./ _)" [0, 0, 3] 3)
syntax
  "_lambda_in" :: "[pttrn, 'a set, 'a => 'b] => ('a => 'b)"  ("(3\<lambda>_\<in>_./ _)" [0, 0, 3] 3)
translations
  "\<lambda>x\<in>A. f"  == "CONST restrict (%x. f) A"

subsubsection \<open>Maps\<close>

definition chg_map :: "('b => 'b) => 'a => ('a \<rightharpoonup> 'b) => ('a \<rightharpoonup> 'b)" where
 "chg_map f a m = (case m a of None => m | Some b => m(a|->f b))"

lemma map_some_list [simp]:
   "map the (map Some L) = L"
apply (induct_tac L)
apply auto
done

lemma dom_ran_the:
  "\<lbrakk> ran G = {y}; x \<in> (dom G) \<rbrakk> \<Longrightarrow> (the (G x)) = y"
apply (unfold ran_def dom_def)
apply auto
done

lemma dom_None:
  "(S \<notin> dom F) \<Longrightarrow> (F S = None)"
by (unfold dom_def, auto)

lemma ran_dom_the:
  "\<lbrakk> y \<notin> Union (ran G); x \<in> dom G \<rbrakk> \<Longrightarrow> y \<notin> the (G x)"
by (unfold ran_def dom_def, auto)

lemma dom_map_upd: "dom(m(a|->b)) = insert a (dom m)"
apply auto
done

subsubsection \<open>\<open>rtrancl\<close>\<close>

lemma rtrancl_mem_Sigma:
 "\<lbrakk> a \<noteq> b; (a, b) \<in> (A \<times> A)^* \<rbrakk> \<Longrightarrow> b \<in> A"
apply (frule rtranclD)
apply (cut_tac r="A \<times> A" and A=A in trancl_subset_Sigma)
apply auto
done

lemma help_rtrancl_Range:
 "\<lbrakk> a \<noteq> b; (a,b) \<in> R ^* \<rbrakk> \<Longrightarrow> b \<in> Range R"
apply (erule rtranclE)
apply auto
done

lemma rtrancl_Int_help:
  "(a,b) \<in> (A \<inter> B) ^*  ==> (a,b) \<in> A^* \<and> (a,b) \<in> B^*"
apply (unfold Int_def)
apply auto
apply (rule_tac b=b in rtrancl_induct)
apply auto
apply (rule_tac b=b in rtrancl_induct)
apply auto
done

lemmas rtrancl_Int1 = rtrancl_Int_help [THEN conjunct1]
lemmas rtrancl_Int2 = rtrancl_Int_help [THEN conjunct2]

lemma tranclD3 [rule_format]:
  "(S,T) \<in> R^+ \<Longrightarrow> (S,T) \<notin> R \<longrightarrow> (\<exists> U. (S,U) \<in> R \<and> (U,T) \<in> R^+)"
apply (rule_tac a="S" and b="T" and r=R in trancl_induct)
apply auto
done

lemma tranclD4 [rule_format]:
  "(S,T) \<in> R^+ \<Longrightarrow> (S,T) \<notin> R \<longrightarrow> (\<exists> U. (S,U) \<in> R^+ \<and> (U,T) \<in> R)"
apply (rule_tac a="S" and b="T" and r=R in trancl_induct)
apply auto
done

lemma trancl_collect [rule_format]:
  "\<lbrakk> (x,y) \<in> R^*; S \<notin> Domain R \<rbrakk> \<Longrightarrow> y \<noteq> S \<longrightarrow> (x,y) \<in> {p. fst p \<noteq> S \<and> snd p \<noteq> S \<and> p \<in> R}^*"
apply (rule_tac b=y in rtrancl_induct)
apply auto
apply (rule rtrancl_into_rtrancl)
apply fast
apply auto
done

lemma trancl_subseteq:
  "\<lbrakk> R \<subseteq> Q; S \<in> R^* \<rbrakk> \<Longrightarrow> S \<in> Q^*"
apply (frule rtrancl_mono)
apply fast
done

lemma trancl_Int_subset:
   "(R \<inter> (A \<times> A))\<^sup>+ \<subseteq> R\<^sup>+ \<inter> (A \<times> A)"
apply (rule subsetI)
apply (rename_tac S)
apply (case_tac "S")
apply (rename_tac T V)
apply auto
apply (rule_tac a=T and b=V and r="(R  \<inter> A \<times> A)" in converse_trancl_induct, auto)+
done

lemma trancl_Int_mem:
   "(S,T) \<in> (R \<inter> (A \<times> A))\<^sup>+ \<Longrightarrow> (S,T)  \<in> R\<^sup>+ \<inter> A \<times> A"
by (rule trancl_Int_subset [THEN subsetD], assumption)

lemma Int_expand:
  "{(S,S'). P S S' \<and>  Q S S'} = ({(S,S'). P S S'} \<inter> {(S,S'). Q S S'})"
by auto

subsubsection \<open>\<open>finite\<close>\<close>

lemma finite_conj:
 "finite ({(S,S'). P S S'}::(('a*'b)set)) \<longrightarrow>
     finite {(S,S'). P (S::'a) (S'::'b) \<and> Q (S::'a) (S'::'b)}"
apply (rule impI)
apply (subst Int_expand)
apply (rule finite_Int)
apply auto
done

lemma finite_conj2:
  "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> finite ({(S,S'). S: A \<and> S' : B})"
by auto

subsubsection \<open>\<open>override\<close>\<close>

lemma dom_override_the:
  "(x \<in> (dom G2)) \<longrightarrow> ((G1 ++ G2) x) = (G2 x)"
by (auto)

lemma dom_override_the2 [simp]:
  "\<lbrakk> dom G1 \<inter> dom G2 = {}; x \<in> (dom G1) \<rbrakk> \<Longrightarrow> ((G1 ++ G2) x) = (G1 x)"
apply (unfold dom_def map_add_def)
apply auto
apply (drule sym)
apply (erule equalityE)
apply (unfold Int_def)
apply auto
apply (erule_tac x=x in allE)
apply auto
done

lemma dom_override_the3 [simp]:
  "\<lbrakk> x \<notin> dom G2; x \<in> dom G1 \<rbrakk> \<Longrightarrow> ((G1 ++ G2) x) = (G1 x)"
apply (unfold dom_def map_add_def)
apply auto
done

lemma Union_ran_override [simp]:
  "S \<in> dom G \<Longrightarrow> \<Union> (ran (G ++ Map.empty(S \<mapsto> insert SA (the(G S))))) =
   (insert SA (Union (ran G)))"
apply (unfold dom_def ran_def)
apply auto
apply (rename_tac T)
apply (case_tac "T = S")
apply auto
done

lemma Union_ran_override2 [simp]:
  "S \<in> dom G \<Longrightarrow> \<Union> (ran (G(S \<mapsto> insert SA (the(G S))))) = (insert SA (Union (ran G)))"
apply (unfold dom_def ran_def)
apply auto
apply (rename_tac T)
apply (case_tac "T = S")
apply auto
done

lemma chg_map_upd [simp]:
  "m a = Some b \<Longrightarrow> chg_map f a m = m(a|->f b)"
by (unfold chg_map_def, auto)

lemma ran_override_chg_map:
  "A \<in> dom G \<Longrightarrow> ran (G ++ Map.empty(A|->B)) = (ran (chg_map (\<lambda> x. B) A G))"
apply (unfold dom_def ran_def)
apply (subst map_add_Some_iff [THEN ext])
apply auto
apply (rename_tac T)
apply (case_tac "T = A")
apply auto
done

subsubsection \<open>\<open>Part\<close>\<close>

definition  Part :: "['a set, 'b => 'a] => 'a set" where
            "Part A h = A \<inter> {x. \<exists> z. x = h(z)}"

lemma Part_UNIV_Inl_comp:
 "((Part UNIV (Inl o f)) = (Part UNIV (Inl o g))) = ((Part UNIV f) = (Part UNIV g))"
apply (unfold Part_def)
apply auto
apply (erule equalityE)
apply (erule subsetCE)
apply auto
apply (erule equalityE)
apply (erule subsetCE)
apply auto
done

lemma Part_eqI [intro]: "\<lbrakk> a \<in> A; a=h(b) \<rbrakk> \<Longrightarrow> a \<in> Part A h"
by (auto simp add: Part_def)

lemmas PartI = Part_eqI [OF _ refl]

lemma PartE [elim!]: "\<lbrakk> a \<in> Part A h;  !!z. \<lbrakk> a \<in> A;  a=h(z) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (auto simp add: Part_def)

lemma Part_subset: "Part A h \<subseteq> A"
by (auto simp add: Part_def)

lemma Part_mono: "A \<subseteq> B \<Longrightarrow> Part A h \<subseteq> Part B h"
by blast

lemmas basic_monos = basic_monos Part_mono

lemma PartD1: "a \<in> Part A h \<Longrightarrow> a \<in> A"
by (simp add: Part_def)

lemma Part_id: "Part A (\<lambda> x. x) = A"
by blast

lemma Part_Int: "Part (A \<inter> B) h = (Part A h) \<inter> (Part B h)"
by blast

lemma Part_Collect: "Part (A \<inter> {x. P x}) h = (Part A h) \<inter> {x. P x}"
by blast

subsubsection \<open>Set operators\<close>

lemma subset_lemma:
  "\<lbrakk> A \<inter> B = {}; A \<subseteq> B \<rbrakk> \<Longrightarrow> A = {}"
by auto

lemma subset_lemma2:
 "\<lbrakk> B \<inter> A = {}; C \<subseteq> A \<rbrakk> \<Longrightarrow> C \<inter> B = {}"
by auto

lemma insert_inter:
  "\<lbrakk> a \<notin> A; (A \<inter> B) = {} \<rbrakk> \<Longrightarrow> (A \<inter> (insert a B)) = {}"
by auto

lemma insert_notmem:
  "\<lbrakk> a \<noteq> b; a \<notin> B \<rbrakk> \<Longrightarrow> a \<notin> (insert b B)"
by auto

lemma insert_union:
 "A \<union> (insert a B) = insert a A \<union> B"
by auto

lemma insert_or:
     "{s. s = t1 \<or>  (P s)} = insert t1 {s. P s }"
by auto

lemma Collect_subset:
  "{x . x \<subseteq> A \<and> P x} = {x \<in> Pow A. P x}"
by auto

lemma OneElement_Card [simp]:
  "\<lbrakk> finite M; card M <= Suc 0; t \<in> M \<rbrakk> \<Longrightarrow> M = {t}"
apply auto
apply (rename_tac s)
apply (rule_tac P="finite M" in mp)
apply (rule_tac P="card M <= Suc 0" in mp)
apply (rule_tac P="t \<in> M" in mp)
apply (rule_tac F="M" in finite_induct)
apply auto
apply (rule_tac P="finite M" in mp)
apply (rule_tac P="card M <= Suc 0" in mp)
apply (rule_tac P="s \<in> M" in mp)
apply (rule_tac P="t \<in> M" in mp)
apply (rule_tac F="M" in finite_induct)
apply auto
done

subsubsection \<open>One point rule\<close>

lemma Ex1_one_point [simp]:
  "(\<exists>! x. P x \<and> x = a) = P a"
by auto

lemma Ex1_one_point2 [simp]:
  "(\<exists>! x. P x \<and> Q x \<and> x = a) = (P a \<and> Q a)"
by auto

lemma Some_one_point [simp]:
 "P a \<Longrightarrow> (SOME x. P x \<and> x = a) = a"
by auto

lemma Some_one_point2 [simp]:
 "\<lbrakk> Q a; P a \<rbrakk> \<Longrightarrow> (SOME x. P x \<and> Q x \<and> x = a) = a"
by auto

end


(*  Title:      Serial_Rel.thy
    Author:     Sebastian Ullrich
*)

subsection "Serial Relations"

text \<open>A serial relation on a finite carrier induces a cycle.\<close>

theory Serial_Rel
imports Main
begin

definition "serial_on A r \<longleftrightarrow> (\<forall>x \<in> A. \<exists>y \<in> A. (x,y) \<in> r)"
lemmas serial_onI = serial_on_def[THEN iffD2, rule_format]
lemmas serial_onE = serial_on_def[THEN iffD1, rule_format, THEN bexE]

fun iterated_serial_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "iterated_serial_on A r x 0 = x"
| "iterated_serial_on A r x (Suc n) = (SOME y. y \<in> A \<and> (iterated_serial_on A r x n,y) \<in> r)"

lemma iterated_serial_on_linear: "iterated_serial_on A r x (n+m) = iterated_serial_on A r (iterated_serial_on A r x n) m"
by (induction m) auto

lemma iterated_serial_on_in_A:
  assumes "serial_on A r" "a \<in> A"
  shows "iterated_serial_on A r a n \<in> A"
proof (induct n)
  case (Suc n)
  thus ?case
    using assms(1, 2) by (subst iterated_serial_on.simps(2)) (rule someI2_ex, auto elim: serial_onE)
qed (simp add:assms(2))

lemma iterated_serial_on_in_power:
  assumes "serial_on A r" "a \<in> A"
  shows "(a,iterated_serial_on A r a n) \<in> r ^^ n"
proof (induct n)
  case (Suc n)
  moreover obtain b where "(iterated_serial_on A r a n,b) \<in> r" "b \<in> A"
    using iterated_serial_on_in_A[OF assms, of n] assms(1) by - (rule serial_onE)
  ultimately show ?case by (subst iterated_serial_on.simps(2)) (rule someI2_ex, auto)
qed simp

lemma trancl_powerI: "a \<in> R ^^ n \<Longrightarrow> n > 0 \<Longrightarrow> a \<in> R\<^sup>+"
by (auto simp:trancl_power)

end


section \<open>Refinement Lattice \label{S:lattice}\<close>

theory Refinement_Lattice
imports
  Main
  "HOL-Library.Lattice_Syntax"
begin

text \<open>
  The underlying lattice of commands is complete and distributive.
  We follow the refinement calculus tradition so that $\nondet$
  is non-deterministic choice and $c \refsto d$ means $c$ is refined
  (or implemented) by $d$.
\<close>

declare [[show_sorts]]

text \<open>Remove existing notation for quotient as it interferes with the rely quotient\<close>
no_notation Equiv_Relations.quotient  (infixl "'/'/" 90)

class refinement_lattice = complete_distrib_lattice
begin

text \<open>The refinement lattice infimum corresponds to non-deterministic choice for commands.\<close>

abbreviation
  refine :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
where
  "c \<sqsubseteq> d \<equiv> less_eq c d"

abbreviation
  refine_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 50)
where
  "c \<sqsubset> d \<equiv> less c d"

text \<open>Non-deterministic choice is monotonic in both arguments\<close>
lemma inf_mono_left: "a \<sqsubseteq> b \<Longrightarrow> a \<sqinter> c \<sqsubseteq> b \<sqinter> c"
  using inf_mono by auto

lemma inf_mono_right: "c \<sqsubseteq> d \<Longrightarrow> a \<sqinter> c \<sqsubseteq> a \<sqinter> d"
  using inf_mono by auto

text \<open>Binary choice is a special case of choice over a set.\<close>
lemma Inf2_inf: "\<Sqinter>{ f x | x. x \<in> {c, d}} = f c \<sqinter> f d"
proof -
  have "{ f x | x. x \<in> {c, d}} = {f c, f d}" by blast
  then have "\<Sqinter>{ f x | x. x \<in> {c, d}} = \<Sqinter>{f c, f d}" by simp
  also have "... = f c \<sqinter> f d" by simp
  finally show ?thesis .
qed

text \<open>Helper lemma for choice over indexed set.\<close>
lemma INF_Inf: "(\<Sqinter>x\<in>X. f x) = (\<Sqinter>{f x |x. x \<in> X})"
  by (simp add: Setcompr_eq_image)

lemma (in -) INF_absorb_args: "(\<Sqinter>i j. (f::nat \<Rightarrow> 'c::complete_lattice) (i + j)) = (\<Sqinter>k. f k)"
proof (rule order_class.order.antisym)
  show "(\<Sqinter>k. f k) \<le> (\<Sqinter>i j. f (i + j))"
    by (simp add: complete_lattice_class.INF_lower complete_lattice_class.le_INF_iff)
next
  have "\<And>k. \<exists>i j. f (i + j) \<le> f k"
    by (metis add.left_neutral order_class.eq_iff)
  then have "\<And>k. \<exists>i. (\<Sqinter>j. f (i + j)) \<le> f k"
    by (meson UNIV_I complete_lattice_class.INF_lower2)
  then show "(\<Sqinter>i j. f (i + j)) \<le> (\<Sqinter>k. f k)"
    by (simp add: complete_lattice_class.INF_mono)
qed

lemma (in -) nested_Collect: "{f y |y. y \<in> {g x |x. x \<in> X}} = {f (g x) |x. x \<in> X}"
  by blast

text \<open>A transition lemma for INF distributivity properties, going from Inf to INF,
  qualified version followed by a straightforward one.\<close>

lemma Inf_distrib_INF:
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes f_Inf_distrib: "\<And>c D. f c (\<Sqinter> D) = \<Sqinter> {f c d | d . d \<in> D }"
  shows "f c (\<Sqinter>x\<in>X. d x) = (\<Sqinter>x\<in>X. f c (d x))"
  by (simp add: Setcompr_eq_image f_Inf_distrib image_comp)

end

lemmas refine_trans = order.trans

text \<open>More transitivity rules to make calculational reasoning smoother\<close>
declare ord_eq_le_trans[trans]
declare ord_le_eq_trans[trans]
declare dual_order.trans[trans]

abbreviation
  dist_over_sup :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "dist_over_sup F \<equiv> (\<forall> X . F (\<Squnion> X) = (\<Squnion>x\<in>X. F (x)))"

abbreviation
  dist_over_inf :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "dist_over_inf F \<equiv> (\<forall> X . F (\<Sqinter> X) = (\<Sqinter>x\<in>X. F (x)))"

end