theory UniversalProperty
  imports "Generators" "FreeGroupMain" "Cancellation" "Word_Problem"
begin

section \<open>Universal Property.\<close>

definition (in group) genmap
  where "genmap S f g = (if g \<in> S then f g else inv (f (wordinverse g)))"

definition freeg :: "_  \<Rightarrow> bool"
  where "freeg G  = ((group G)
 \<and> (\<exists>A \<subseteq> carrier G . \<forall>group H .
 (\<forall>f \<in> A \<rightarrow> carrier H . (\<exists>g \<in> hom G H . (\<forall>x \<in> A . f x = g x) \<and>
 (\<forall>h \<in> hom G H. \<forall>x \<in> A .f x = h x \<longrightarrow> (\<forall>y \<in> carrier G.  g y = h y))))))"

definition inclusion ("\<iota>")
  where "\<iota> g = [(g, True)]"

definition unlift :: "(('a, 'b) word set\<Rightarrow> 'c) \<Rightarrow> ('a, 'b) monoidgentype set\<Rightarrow> (('a, 'b) word set) set \<Rightarrow> ('a, 'b) word \<Rightarrow> 'c"
  where "unlift f S gens x = f (reln_tuple \<langle>S\<rangle> `` {x})"

lemma (in group) genmap_closed:
  assumes cl: "f \<in> (\<iota> ` (S ::('c, 'd) monoidgentype set)) \<rightarrow> carrier G"
      and "g \<in> (\<iota> ` S) \<union> (wordinverse ` (\<iota> ` S))"
    shows "genmap (\<iota> ` S) f g \<in> carrier G"
proof-
  have 1:"g \<in> (\<iota> ` S) \<or> g \<in> (wordinverse ` (\<iota> ` S))" using assms(2) by blast
  then show ?thesis
  proof(cases "g \<in> (\<iota> ` S)")
    case True
    then show ?thesis using assms by (metis Pi_mem genmap_def)
  next
    case False
    then have 2: "g \<in> (wordinverse ` (\<iota> ` S))" using 1 by simp
    then have "genmap (\<iota> ` S) f g =  inv (f (wordinverse g))" by (simp add: False genmap_def)
    moreover have "wordinverse g  \<in> (\<iota> ` S)" by (metis 1 False image_iff wordinverse_symm)
    ultimately show ?thesis using assms by (metis Pi_mem Units_eq Units_inv_Units)
  qed
qed

fun (in group) genmapext
  where "genmapext S f [] = \<one>"|
"genmapext S f (x#xs) = (genmap S f [x]) \<otimes> (genmapext S f xs)"

lemma gen_spanset: assumes "xs \<in> \<langle>S\<rangle>" "xs \<noteq> []" shows "hd xs \<in> invgen S"
  by (metis assms(1) assms(2) freewords_on_def list.sel(1) words_on.cases)

lemma inclusion_union:
  assumes "a \<in> (S ::('a, 'b) monoidgentype set) \<times> {True, False}"
  shows "[a] \<in> (\<iota> ` S) \<union> (wordinverse ` (\<iota> ` S))"
proof(cases "snd a = True")
  case True
  have "fst a \<in> S" using assms by auto
  then show ?thesis by (metis (mono_tags, lifting) True UnI1 inclusion_def rev_image_eqI surjective_pairing)
next
  case False
  have 1:"fst a \<in> S" using assms by auto
  moreover have "snd a = False" using assms False by simp
  ultimately have "inverse a = (fst a, True)" by (metis inverse.simps(2) prod.collapse)
  then have "wordinverse [a] \<in> (\<iota> ` S)" by (simp add: 1 inclusion_def)
  then show ?thesis  by (metis UnCI imageI wordinverse_of_wordinverse)
qed

lemma (in group) genmapext_closed:
  assumes "f \<in> (\<iota> ` (S ::('c, 'd) monoidgentype set)) \<rightarrow> carrier G"
      and "x \<in> freewords_on  S"
    shows "genmapext (\<iota> ` S) f x \<in> carrier G"
  using assms
proof(induction x)
  case Nil
  then show ?case by simp
next
  case (Cons a x)
  have a:"genmapext (\<iota> ` S) f (a # x) = genmap (\<iota> ` S) f [a] \<otimes>  (genmapext (\<iota> ` S)  f x)" by simp
  have "a \<in> S \<times> {True, False}"  using freewords_on_def gen_spanset invgen_def Cons by (metis list.distinct(1) list.sel(1))
  then have "[a] \<in> (\<iota> ` S) \<union> (wordinverse ` (\<iota> ` S))" using inclusion_union  by blast
  then have " genmap (\<iota> ` S) f [a] \<in> carrier G" using genmap_closed Cons.prems(1) by metis
  moreover have "x \<in> \<langle>S\<rangle>" using Cons.prems(2) freewords_on_def span_cons by blast
  ultimately show ?case using a by (simp add: Cons.IH assms(1))
qed

lemma (in group) genmapext_append:
  assumes "f \<in> (\<iota> ` (S ::('c, 'd) monoidgentype set)) \<rightarrow> carrier G"
      and "x \<in> freewords_on S"
      and "y \<in> freewords_on S"
    shows "genmapext (\<iota> ` S)  f (x @ y) = genmapext (\<iota> ` S) f x \<otimes> genmapext (\<iota> ` S) f y"
  using assms
proof(induction x)
  case Nil
  have "genmapext (\<iota> ` S) f [] = \<one>" by simp
  moreover have "genmapext (\<iota> ` S) f y \<in> carrier G" using genmapext_closed assms by auto
  then have "genmapext (\<iota> ` S) f [] \<otimes> genmapext (\<iota> ` S)  f y = genmapext (\<iota> ` S) f y" using r_one by simp
  then show ?case by simp
next
  case (Cons a x)
  have "a \<in> S \<times> {True, False}" using freewords_on_def gen_spanset invgen_def Cons by (metis list.distinct(1) list.sel(1))
  then have a:"[a] \<in> (\<iota> ` S) \<union> (wordinverse ` (\<iota> ` S))" using inclusion_union  by blast
  have x:"x \<in> \<langle>S\<rangle>" using Cons.prems(2) freewords_on_def span_cons by blast
  have "genmapext (\<iota> ` S) f (a # x) \<otimes> genmapext (\<iota> ` S) f y = genmap (\<iota> ` S) f [a] \<otimes> genmapext (\<iota> ` S) f x \<otimes> genmapext (\<iota> ` S) f y" by simp
  then have 1: "genmapext (\<iota> ` S) f (a # x) \<otimes> genmapext (\<iota> ` S) f y = genmap (\<iota> ` S) f [a] \<otimes> genmapext (\<iota> ` S) f (x @ y)"
    using Cons.IH Cons.prems(1) Cons.prems(3)  a genmap_closed genmapext_closed m_assoc x by metis
  have "genmapext  (\<iota> ` S) f ((a # x) @ y) = genmapext (\<iota> ` S) f (a # (x  @ y))" by auto
  then have "genmapext (\<iota> ` S) f ((a #x) @ y) = genmap (\<iota> ` S) f [a] \<otimes> genmapext (\<iota> ` S) f (x @ y)" by simp
  then show ?case using 1 by auto
qed

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 "inverse x1 = x2"
proof-
  assume a: "(\<And>xs1 x1 x2 xs2. \<lbrakk>x = xs1 @ x1 # x2 # xs2; y = xs1 @ xs2; inverse x1 =  x2\<rbrakk> \<Longrightarrow> thesis)"
  from assms
  obtain i where "cancels_to_1_at i x y"
    unfolding cancels_to_1_def by auto
  hence "inverse (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

lemma cancels_to_1_preserves:
  assumes "cancels_to_1 x y"
      and "x \<in> freewords_on S"
    shows "y \<in> freewords_on S"
proof-
  obtain xs1 x1 x2 xs2
  where x:"x = xs1 @ x1 # x2 # xs2"
    and y:"y = xs1 @ xs2"
    using assms cancels_to_1_unfold by metis
  have "xs1 \<in> freewords_on S" using x leftappend_span freewords_on_def assms(2) by blast
  moreover have "xs2 \<in> freewords_on S" using x rightappend_span freewords_on_def assms(2) span_cons by blast
  ultimately show ?thesis using y by (simp add: span_append freewords_on_def)
qed

lemma cancels_to_preserves:
  assumes "cancels_to x y"
      and "x \<in> freewords_on S"
    shows "y \<in> freewords_on S"
  using assms unfolding cancels_to_def
proof(induct rule:rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by simp
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case using cancels_to_1_preserves by auto
qed

lemma inclusion_snd:
  assumes "[x] \<in> (\<iota> ` S)"
  shows "snd x = True"
proof-
  show ?thesis using assms  by (metis image_iff inclusion_def last.simps old.prod.inject prod.collapse)
qed

lemma (in group) inverse_ext:
  assumes  "inverse x1 = x2"
  and "[x1] \<in> freewords_on (S ::('c, 'd) monoidgentype set)"
  and "[x2] \<in> freewords_on S"
  and "f \<in> (\<iota> ` S) \<rightarrow> carrier G"
  shows "(genmapext (\<iota> ` S) f [x1] \<otimes> genmapext (\<iota> ` S) f [x2]) = \<one>"
proof-
  have "genmapext (\<iota> ` S) f [x1] = genmap (\<iota> ` S) f [x1] \<otimes> \<one>" by simp
  have x1:"x1 \<in> S \<times> {True, False}" using  invgen_def gen_spanset freewords_on_def assms(2)  by (metis list.distinct(1) list.sel(1))
  then have "[x1] \<in> (\<iota> ` S) \<union> (wordinverse ` (\<iota> ` S))" using inclusion_union  by blast
  then have g1:"genmap (\<iota> ` S) f [x1] \<in> carrier G" using genmap_closed[of "f" "S" "[x1]"] assms(4) by fast
  moreover have "genmapext (\<iota> ` S) f [x1] = genmap (\<iota> ` S) f [x1] \<otimes> \<one>" by simp
  ultimately have 1:"genmapext (\<iota> ` S) f [x1] = genmap (\<iota> ` S) f [x1]" by simp
  have "genmapext (\<iota> ` S) f [x2] = genmap (\<iota> ` S) f [x2] \<otimes> \<one>" by simp
  have x2:"x2 \<in> S \<times> {True, False}" using  invgen_def gen_spanset freewords_on_def assms(3)  by (metis list.distinct(1) list.sel(1))
  then have "[x2] \<in> (\<iota> ` S) \<union> (wordinverse ` (\<iota> ` S))" using inclusion_union  by blast
  then have g2:"genmap (\<iota> ` S) f [x2] \<in> carrier G" using genmap_closed assms(4) by blast
  moreover have "genmapext (\<iota> ` S) f [x2] = genmap (\<iota> ` S) f [x2] \<otimes> \<one>" by simp
  ultimately have 2:"genmapext (\<iota> ` S) f [x2] = genmap (\<iota> ` S) f [x2]" by simp
  have fx1:"fst x1 \<in> S" using x1 by auto
  have fx2:"fst x2 \<in> S" using x2 by auto
  then show ?thesis
  proof (cases "snd x1 = False")
    case True
    then have "snd x2 = True" using assms(1) by (metis inverse.simps(2) snd_eqD surjective_pairing)
    then have "[x2] \<in> (\<iota> ` S)" using fx2 by (metis inclusion_def rev_image_eqI surjective_pairing)
    then have a:"genmap (\<iota> ` S) f [x2] = f [x2]" by (simp add: genmap_def)
    have "[x1] \<notin> (\<iota> ` S)" using inclusion_snd True  by metis
    moreover have "wordinverse [x1] = [x2]" by (simp add: assms(1))
    ultimately have "genmap (\<iota> ` S) f [x1] = inv (f [x2])" by (simp add: genmap_def)
    then show ?thesis  using 1 2 a  Units_eq Units_l_inv g2 by presburger
next
  case False
    then have T:"snd x1 = True" using assms(1) by (metis inverse.simps(2) snd_eqD surjective_pairing)
    then have "[x1] \<in> (\<iota> ` S)" using fx1 by (metis inclusion_def rev_image_eqI surjective_pairing)
    then have a:"genmap (\<iota> ` S) f [x1] = f [x1]" by (simp add: genmap_def)
    have "snd x2 = False" using T assms(1) by (metis eq_snd_iff inverse.simps(1))
    then have "[x2] \<notin> (\<iota> ` S)" using inclusion_snd  by metis
    moreover have "wordinverse [x2] = [x1]"
      using assms(1) x1 by auto
    ultimately have "genmap (\<iota> ` S) f [x2] = inv (f [x1])" by (simp add: genmap_def)
    then show ?thesis  using 1 2 a Units_eq Units_r_inv g1 by presburger
  qed
qed

lemma (in group) genmapext_cancels_to:
  assumes "cancels_to x y"
      and "x \<in> freewords_on (S ::('c, 'd) monoidgentype set)"
      and "y \<in> freewords_on S"
      and  "f \<in> (\<iota> ` S) \<rightarrow> carrier G"
  shows "genmapext (\<iota> ` S) f x = genmapext (\<iota> ` S) f y"
using assms
unfolding cancels_to_def
proof(induct rule:rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by auto
  case (rtrancl_into_rtrancl a b c)
obtain c1 x1 x2 c2
      where b: "b = c1 @ x1 # x2 # c2"
      and c: "c = c1 @ c2"
      and i: "inverse x1 = x2"
  using cancels_to_1_unfold rtrancl_into_rtrancl.hyps(3) by blast
  have bin: "b \<in> freewords_on S" using cancels_to_preserves  cancels_to_def rtrancl_into_rtrancl.prems(1) rtrancl_into_rtrancl.hyps(1)  by metis
  have c1:"c1 \<in> freewords_on S" using b bin  freewords_on_def leftappend_span by blast
  moreover have fx1:"([x1] @ [x2] @ c2)\<in> freewords_on S" using b bin  freewords_on_def rightappend_span by fastforce
  moreover then have x1:"[x1] \<in> freewords_on S" using fx1  freewords_on_def leftappend_span by blast
  moreover  have fx2: "([x2] @ c2) \<in> freewords_on S" using fx1  freewords_on_def rightappend_span by fastforce
  moreover then have x2:"[x2] \<in> freewords_on S" using  freewords_on_def leftappend_span by blast
  moreover  have c2: "c2 \<in> freewords_on S" using fx2  freewords_on_def rightappend_span by fastforce
  ultimately have 2: "genmapext (\<iota> ` S) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` S) f c1  \<otimes> (genmapext (\<iota> ` S) f [x1] \<otimes> genmapext (\<iota> ` S) f [x2]) \<otimes> genmapext (\<iota> ` S) f c2" using genmapext_append rtrancl_refl.prems(3) by (smt (z3) genmapext_closed m_assoc m_closed)
  then have "genmapext (\<iota> ` S) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` S) f c1  \<otimes> \<one> \<otimes> genmapext (\<iota> ` S) f c2" using inverse_ext i x1 x2 assms(4) by metis
  then have "genmapext (\<iota> ` S) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` S) f c1  \<otimes>  genmapext (\<iota> ` S) f c2"
    using c1 c2 assms(4) genmapext_closed by (metis l_cancel_one' one_closed)
  then have "genmapext (\<iota> ` S) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` S) f (c1@c2)"
    using genmapext_append c1 c2 assms(4) by metis
  then have "genmapext (\<iota> ` S) f b = genmapext (\<iota> ` S) f c" using b c by simp
  then show ?case using rtrancl_into_rtrancl by (simp add: bin)
qed

lemma (in group) genmapext_reln_tuple:
  assumes "(x,y) \<in> (reln_tuple (freewords_on (S ::('c, 'd) monoidgentype set)))"
      and "x \<in> freewords_on S"
      and "y \<in> freewords_on S"
      and  "f \<in> (\<iota> ` S) \<rightarrow> carrier G"
  shows "genmapext (\<iota> ` S) f x = genmapext (\<iota> ` S) f y"
proof-
  let ?rx = "(reduce^^(length x)) x"
  let ?ry = "(reduce^^(length y)) y"
  have "cancels_to x ?rx" by (simp add: iter_cancels_to)
  moreover then have "?rx  \<in> freewords_on S" using assms cancels_to_preserves by blast
  ultimately have x:"genmapext (\<iota> ` S) f x = genmapext (\<iota> ` S) f ?rx"  using genmapext_cancels_to[of "x" "?rx" "S" "f"] assms(2) assms(4) by auto
  have  "cancels_to y ?ry" by (simp add: iter_cancels_to)
  moreover then have ryg:"?ry  \<in> freewords_on S" using assms cancels_to_preserves by blast
  ultimately have y:"genmapext (\<iota> ` S) f y = genmapext (\<iota> ` S) f ?ry"  using genmapext_cancels_to[of "y" "?ry" "S" "f"] assms(3) assms(4) by auto
  have "FreeGroupMain.reln x y" using assms(1) reln_tuple_def assms by (metis (no_types, lifting) case_prodD mem_Collect_eq)
  then have "cancels_eq x y" using reln_imp_cancels by blast
  then have "?rx = ?ry" using cancels_imp_iter by blast
  then show ?thesis using x y by simp
qed

lemma (in group) congruentlift: assumes "f \<in> (\<iota> ` (S::('c,'d) monoidgentype set)) \<rightarrow> carrier G" shows "congruent (reln_tuple (freewords_on S)) (genmapext (\<iota> ` S) f)"
  unfolding congruent_def
proof-
  have "(\<And>x y. (x, y) \<in> (reln_tuple \<langle>S\<rangle>) \<Longrightarrow> (genmapext (\<iota> ` S) f x) = (genmapext (\<iota> ` S) f y))"
  proof-
    fix x y assume assm: "(x, y) \<in> (reln_tuple \<langle>S\<rangle>)"
    moreover then have "x \<in> \<langle>S\<rangle>" using reln_tuple_def by auto
    moreover have "y \<in> \<langle>S\<rangle>" using reln_tuple_def assm  by auto
    ultimately show "(genmapext (\<iota> ` S) f x) = (genmapext (\<iota> ` S) f y)" using genmapext_reln_tuple assms by blast
  qed
  then show "\<forall>(y, z)\<in>reln_tuple \<langle>S\<rangle>. genmapext (\<iota> ` S) f y = genmapext (\<iota> ` S)  f z" by blast
qed

definition (in group) genmapext_proj where "genmapext_proj S f a = (\<Union>x \<in> a. {genmapext S f x})"

lemma (in group) genmapext_proj_wd:
  assumes " A \<in> quotient \<langle>(S::('c,'d) monoidgentype set)\<rangle> (reln_tuple \<langle>S\<rangle>)"
          "a \<in> A"
          "f \<in> (\<iota> ` S) \<rightarrow> carrier G"
          shows "genmapext_proj (\<iota> ` S) f A = {genmapext (\<iota> ` S) f a}"
proof-
  have "\<forall> x \<in> A . ({genmapext (\<iota> ` S) f x} = {genmapext (\<iota> ` S) f a})"
  proof-
    have "(\<And>x. x \<in> A \<Longrightarrow> ({genmapext (\<iota> ` S) f x} = {genmapext (\<iota> ` S) f a}))"
    proof-
      fix x  assume assm: "x \<in> A"
      then have "(x, a)\<in>reln_tuple \<langle>S\<rangle>" by (meson assms(1) assms(2) quotient_eq_iff reln_equiv)
      then have "genmapext (\<iota> ` S) f x = genmapext (\<iota> ` S) f a"
        using assms(3) congruentlift unfolding congruent_def by blast
      then show "{genmapext (\<iota> ` S) f x} = {genmapext (\<iota> ` S) f a}" by simp
    qed
    then show "\<forall> x \<in> A . ({genmapext (\<iota> ` S) f x} = {genmapext (\<iota> ` S) f a})" by simp
  qed
  then show ?thesis unfolding genmapext_proj_def using assms(2) by blast
qed

definition (in group) genmapext_lift where "genmapext_lift S f a = (THE x. x \<in> genmapext_proj S f a)"

lemma (in group) genmapext_lift_wd:
assumes " A \<in> quotient \<langle>(S::('c,'d) monoidgentype set)\<rangle> (reln_tuple \<langle>S\<rangle>)"
          "a \<in> A"
          "f \<in> (\<iota> ` S) \<rightarrow> carrier G"
        shows "genmapext_lift (\<iota> ` S) f A = genmapext (\<iota> ` S) f a"
  unfolding genmapext_lift_def
proof-
  have "genmapext_proj (\<iota> ` S) f A = {genmapext (\<iota> ` S) f a}" using assms genmapext_proj_wd by blast
  then show "(THE x. x \<in> genmapext_proj (\<iota> ` S) f A) = genmapext (\<iota> ` S) f a"  by simp
qed

lemma (in group) genmapext_lift_hom:
  assumes "f \<in> (\<iota> ` (S::('c,'d) monoidgentype set)) \<rightarrow> carrier G"
  shows "genmapext_lift (\<iota> ` S) f \<in> hom (freegroup S) G"
proof-
  {
  fix x
  assume "x \<in> carrier (freegroup S)"
  then have x2: "x \<in>   quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" unfolding freegroup_def by simp
  moreover then obtain x1 where x1:"x1 \<in> x" by (metis all_not_in_conv in_quotient_imp_non_empty reln_equiv)
  ultimately have xx1: "x = ((reln_tuple \<langle>S\<rangle>)``{x1})"  by (metis (no_types, lifting) Image_singleton_iff equiv_class_eq quotientE reln_equiv)
  then have xin: "x1 \<in> \<langle>S\<rangle>" by (meson in_mono in_quotient_imp_subset reln_equiv x1 x2)
  have "genmapext_lift (\<iota> ` S) f x = genmapext (\<iota> ` S) f x1" using genmapext_lift_wd x2 x1 assms(1)
    by (simp add: genmapext_lift_wd) (* by simp*)
  then have "genmapext_lift (\<iota> ` S) f x \<in> carrier G" using genmapext_closed  assms(1) xin
    by (simp add: genmapext_closed)
}
  moreover
  {
  fix x assume x:"x \<in> carrier (freegroup S)"
  fix y assume y:"y \<in> carrier (freegroup S)"
  have x2:"x \<in>   quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" using freegroup_def x by (metis partial_object.select_convs(1))
  moreover then obtain x1 where x1:"x1 \<in> x" by (metis all_not_in_conv in_quotient_imp_non_empty reln_equiv)
  ultimately have xx1: "x = ((reln_tuple \<langle>S\<rangle>)``{x1})"  by (metis (no_types, lifting) Image_singleton_iff equiv_class_eq quotientE reln_equiv)
  then have xin: "x1 \<in> \<langle>S\<rangle>" by (meson in_mono in_quotient_imp_subset reln_equiv x1 x2)
  have y2:"y \<in>   quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" using freegroup_def y by (metis partial_object.select_convs(1))
  moreover then obtain y1 where y1:"y1 \<in> y" by (metis all_not_in_conv in_quotient_imp_non_empty reln_equiv)
  ultimately have yy1:"y = ((reln_tuple \<langle>S\<rangle>)``{y1})"  by (metis (no_types, lifting) Image_singleton_iff equiv_class_eq quotientE reln_equiv)
  then have yin:"y1 \<in> \<langle>S\<rangle>" by (meson in_mono in_quotient_imp_subset reln_equiv y1 y2)
  have 1:"x \<otimes>\<^bsub>(freegroup S)\<^esub> y = proj_append \<langle>S\<rangle> (x) (y)" by (simp add: freegroup_def)
  then have "x \<otimes>\<^bsub>(freegroup S)\<^esub> y = proj_append \<langle>S\<rangle> ((reln_tuple \<langle>S\<rangle>)``{x1}) ((reln_tuple \<langle>S\<rangle>)``{y1})" using xx1 yy1 by simp
  then have 2:"x \<otimes>\<^bsub>(freegroup S)\<^esub> y = ((reln_tuple \<langle>S\<rangle>)``{x1@y1})" using proj_append_wd x2 y2 x1 y1 reln_equiv by (metis (no_types, lifting)   quotient_eq_iff refl_onD1 reln_refl)
  then have "genmapext_lift (\<iota> ` S) f (x \<otimes>\<^bsub>(freegroup S)\<^esub> y) = genmapext_lift (\<iota> ` S) f ((reln_tuple \<langle>S\<rangle>)``{x1@y1})" by simp
  moreover  have "((reln_tuple \<langle>S\<rangle>)``{x1@y1}) \<in> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)"  by (metis 1 2 proj_append_clos x2 y2)
  moreover have "(x1@y1) \<in> ((reln_tuple \<langle>S\<rangle>)``{x1@y1})" using append_congruent eq_equiv_class equiv_2f_clos reln_equiv x1 x2 y1 y2 by fastforce
  ultimately have "genmapext_lift (\<iota> ` S) f (x \<otimes>\<^bsub>(freegroup S)\<^esub> y) = genmapext (\<iota> ` S) f (x1@y1)" using genmapext_lift_wd[of "((reln_tuple \<langle>S\<rangle>)``{x1@y1})" "S" "(x1@y1)" "f"] using assms by presburger
  then have "genmapext_lift (\<iota> ` S) f (x \<otimes>\<^bsub>(freegroup S)\<^esub> y) = genmapext (\<iota> ` S) f x1 \<otimes> genmapext (\<iota> ` S) f y1" using genmapext_append xin yin assms(1) by auto
  then have "genmapext_lift (\<iota> ` S) f (x \<otimes>\<^bsub>(freegroup S)\<^esub> y) = (genmapext_lift (\<iota> ` S) f x) \<otimes> (genmapext_lift (\<iota> ` S) f y)" using genmapext_lift_wd x2 x1 y2 y1  assms(1)
    by metis
}
  ultimately show ?thesis by (simp add: homI)
qed

definition liftgen where "liftgen S = (\<Union>x \<in> (\<iota> ` S).{reln_tuple \<langle>S\<rangle> ``{x}})"

lemma (in group) unlift_S: assumes "f \<in> liftgen S \<rightarrow> carrier G"
  shows "unlift f S (liftgen S) \<in> (\<iota> ` (S::('c,'d) monoidgentype set)) \<rightarrow> carrier G"
proof(rule funcsetI)
  fix x assume assm:"x \<in> \<iota> ` S"
  have "(reln_tuple \<langle>S\<rangle> ``{x}) \<in> (\<Union>x \<in> (\<iota> ` (S::('c,'d) monoidgentype set)).{reln_tuple \<langle>S\<rangle> ``{x}} )" using assm by blast
  then have "f (reln_tuple \<langle>S\<rangle> ``{x}) \<in> carrier G" using assms Pi_split_insert_domain unfolding liftgen_def by fastforce
  moreover have "f (reln_tuple \<langle>S\<rangle> ``{x}) = unlift f S (liftgen S) x"  by (simp add: unlift_def)
  ultimately show "unlift f S (liftgen S) x \<in> carrier G" by simp
qed

lemma (in group) genmapext_unlift_hom: assumes
               "f \<in> liftgen (S::('c,'d) monoidgentype set) \<rightarrow> carrier G"
  shows "genmapext_lift (\<iota> ` S) (unlift f S (liftgen S)) \<in> hom (freegroup S) G"
  by (simp add: assms genmapext_lift_hom unlift_S)

lemma inclusion_subset_spanset:"(\<iota> ` S) \<subseteq> \<langle>S\<rangle>"
proof(rule subsetI)
  fix x assume assms:"x \<in> \<iota> ` S"
  then have "fst (hd x) \<in> S" by (metis fstI image_iff inclusion_def list.sel(1))
  moreover have "snd (hd x) \<in> {True, False}" by simp
  ultimately have "hd x \<in> invgen S" unfolding invgen_def by (simp add: mem_Times_iff)
  moreover have "x = ((hd x)#[])" using assms inclusion_def by (metis image_iff list.sel(1))
  ultimately show "x \<in> \<langle>S\<rangle>" unfolding freewords_on_def using empty gen by metis
qed

lemma liftgen_subset_quotient:"(liftgen S) \<subseteq> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)"
proof(rule subsetI)
  fix x assume assms:"x \<in> liftgen S"
  then have "x \<in> (\<Union>x \<in> (\<iota> ` S).{reln_tuple \<langle>S\<rangle> ``{x}})" by (simp add: liftgen_def)
  then obtain x1 where "x = (reln_tuple \<langle>S\<rangle> ``{x1}) \<and> x1 \<in> (\<iota> ` S)" by blast
  then moreover have "x1 \<in> \<langle>S\<rangle>" using inclusion_subset_spanset by auto
  ultimately show "x \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>" by (simp add: quotientI)
qed

lemma inclusion_hd: assumes "x \<in> (\<iota> ` S)"
  shows "(hd x#[]) = x"
proof-
  show ?thesis using assms inclusion_def by (metis image_iff list.sel(1))
qed

lemma (in group) genmapext_unlift_ext:
  assumes "f \<in> liftgen (S::('c,'d) monoidgentype set) \<rightarrow> carrier G"
  shows "\<And>x. x \<in> (liftgen S) \<Longrightarrow> f x = genmapext_lift (\<iota> ` S) (unlift f S (liftgen S)) x"
proof-
  fix x assume assm:"x \<in> (liftgen S)"
  then have x:"x \<in> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" using liftgen_subset_quotient by auto
  have "x \<in> (\<Union>x \<in> (\<iota> ` S).{reln_tuple \<langle>S\<rangle> ``{x}})" using assm by (simp add: liftgen_def)
  then obtain x1 where x1x:"x = (reln_tuple \<langle>S\<rangle> ``{x1}) \<and> x1 \<in> (\<iota> ` S)" by blast
  then have x1s:"x1 \<in> \<langle>S\<rangle>" using inclusion_subset_spanset by blast
  then have "x1 \<in> x" using reln_tuple_def reln_refl x1x by fastforce
  then have A:"genmapext_lift (\<iota> ` S) (unlift f S (liftgen S)) x = genmapext (\<iota> ` S) (unlift f S (liftgen S)) x1" using  x assms genmapext_lift_wd[of "x" "S" "x1"] by (simp add: unlift_S)
  have "x1 = (hd x1#[])" using x1x by (metis inclusion_hd)
  then have "genmapext (\<iota> ` S) (unlift f S (liftgen S)) x1 = (genmap (\<iota> ` S) (unlift f S (liftgen S)) x1) \<otimes> \<one>" using genmapext.simps by metis
  then have "genmapext (\<iota> ` S) (unlift f S (liftgen S)) x1 = (genmap (\<iota> ` S) (unlift f S (liftgen S)) x1)" using genmap_closed[of "(unlift f S (liftgen S))" "S" "x1"] unlift_S[of "f" "S"] assms by (simp add: x1x)
  then have "genmapext (\<iota> ` S) (unlift f S (liftgen S)) x1 = (unlift f S (liftgen S)) x1" using x1x unfolding genmap_def by simp
  then have "genmapext (\<iota> ` S) (unlift f S (liftgen S)) x1 = f x" using  x1x by (simp add: unlift_def)
  then show "f x = genmapext_lift (\<iota> ` S) (unlift f S (liftgen S)) x" using A by simp
qed

lemma (in group) span_liftgen: "\<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>  \<subseteq> carrier (freegroup S)"
proof-
  have "carrier (freegroup S) = quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" by (simp add: freegroup_def)
  moreover have "(liftgen S)  \<subseteq> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" by (simp add: liftgen_subset_quotient)
  ultimately show ?thesis by (metis freegroup_is_group group.gen_span_closed)
qed

lemma invgen_elem: assumes "x \<in> invgen S" shows "[x] \<in> (\<iota> ` S) \<or> wordinverse [x] \<in> (\<iota> ` S)"
 proof(cases "snd x = True")
   case True
   moreover have fx:"fst x \<in> S" using assms invgen_def[of "S"] by (metis mem_Sigma_iff prod.collapse)
  ultimately have "[x] \<in> (\<iota> ` S)" using assms fx inclusion_def  by (metis (mono_tags, lifting) image_iff prod.collapse)
  then show "[x] \<in> (\<iota> ` S) \<or> wordinverse [x] \<in> (\<iota> ` S)"  by blast
next
  case False
  then have "snd x = False" using assms by auto
  moreover have "wordinverse [x] = (inverse x)#[]" by simp
moreover have fx:"fst x \<in> S" using assms invgen_def[of "S"] by (metis mem_Sigma_iff prod.collapse)
  ultimately have "wordinverse [x] \<in> (\<iota> ` S)" using inverse.simps(2) assms fx inclusion_def  by (metis (mono_tags, lifting) image_iff prod.collapse)
  then show "[x] \<in> (\<iota> ` S) \<or> wordinverse [x] \<in> (\<iota> ` S)" by blast
qed

lemma (in group) wordinverse_inv:
  assumes "x \<in> carrier (freegroup S)" "x = (reln_tuple \<langle>S\<rangle>) `` {x1}"
  shows "inv\<^bsub>(freegroup S)\<^esub> x = (reln_tuple \<langle>S\<rangle>) `` {wordinverse x1}"
proof-
  have nil: "[] \<in> \<langle>S\<rangle>"  by (simp add: freewords_on_def words_on.empty)
  have 1:"x1 \<in> \<langle>S\<rangle>" using assms unfolding freegroup_def using in_quotient_imp_non_empty refl_onD1 reln_equiv reln_refl by fastforce
  then have 2:"wordinverse x1 \<in> \<langle>S\<rangle>"
    using span_wordinverse by auto
  then have A:"(reln_tuple \<langle>S\<rangle>) `` {wordinverse x1} \<in> carrier (freegroup S)" unfolding freegroup_def by (simp add: quotientI)
  have "x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_tuple \<langle>S\<rangle>) `` {wordinverse x1} = (proj_append \<langle>S\<rangle>) ((reln_tuple \<langle>S\<rangle>) `` {x1}) ((reln_tuple \<langle>S\<rangle>) `` {wordinverse x1})" using assms  by (simp add: freegroup_def)
  then have "x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_tuple \<langle>S\<rangle>) `` {wordinverse x1}
       = ((reln_tuple \<langle>S\<rangle>) `` {x1@wordinverse x1})" using proj_append_wd
    using "1" "2" by blast
  moreover have "x1@(wordinverse x1) \<in> \<langle>S\<rangle>" using 1 2 span_append freewords_on_def by blast
  moreover then have "((x1@(wordinverse x1)), []) \<in> reln_tuple \<langle>S\<rangle>" using nil wordinverse_inverse reln_tuple_def by auto
  moreover then have "reln_tuple \<langle>S\<rangle> `` {x1@(wordinverse x1)} = reln_tuple \<langle>S\<rangle> `` {[]}" by (metis equiv_class_eq reln_equiv)
  ultimately have "x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_tuple \<langle>S\<rangle>) `` {wordinverse x1} = reln_tuple \<langle>S\<rangle> `` {[]}" by simp
  then have B:"x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_tuple \<langle>S\<rangle>) `` {wordinverse x1} = \<one>\<^bsub>(freegroup S)\<^esub>" by (simp add: freegroup_def)
  have " (reln_tuple \<langle>S\<rangle>) `` {wordinverse x1}  \<otimes>\<^bsub>(freegroup S)\<^esub> x = (proj_append \<langle>S\<rangle>) ((reln_tuple \<langle>S\<rangle>) `` {wordinverse x1}) ((reln_tuple \<langle>S\<rangle>) `` {x1})"  using assms  by (simp add: freegroup_def)
  then moreover have "proj_append \<langle>S\<rangle>  ((reln_tuple \<langle>S\<rangle>)``{wordinverse x1}) ((reln_tuple \<langle>S\<rangle>)``{x1})
      = reln_tuple \<langle>S\<rangle> `` {(wordinverse x1)@x1}"
    by (meson "1" "2" proj_append_wd)
  moreover have "(wordinverse x1)@x1 \<in> \<langle>S\<rangle>" using 1 2 span_append freewords_on_def by blast
  moreover then have "(((wordinverse x1)@x1), []) \<in> reln_tuple \<langle>S\<rangle>" using nil inverse_wordinverse reln_tuple_def by auto
  moreover then have "reln_tuple \<langle>S\<rangle> `` {(wordinverse x1)@x1} = reln_tuple \<langle>S\<rangle> `` {[]}" by (metis equiv_class_eq reln_equiv)
  ultimately have C:"(reln_tuple \<langle>S\<rangle>) `` {wordinverse x1}  \<otimes>\<^bsub>(freegroup S)\<^esub> x = \<one>\<^bsub>(freegroup S)\<^esub>" by (simp add: freegroup_def)
  show ?thesis
    by (meson A C assms(1) freegroup_is_group group.inv_equality)
qed

lemma inclusion_liftgen: assumes "x \<in> (\<iota> ` S)" shows "(reln_tuple \<langle>S\<rangle> `` {x}) \<in> liftgen S"
  using assms unfolding liftgen_def
proof-
  fix x assume "x \<in> \<iota> ` S"
  then show "reln_tuple \<langle>S\<rangle> `` {x} \<in> (\<Union>x\<in>\<iota> ` S. {reln_tuple \<langle>S\<rangle> `` {x}})" by blast
qed

lemma (in group) liftgen_span: "carrier (freegroup S) \<subseteq> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>"
proof(rule subsetI)
  fix x assume assm: "x \<in> carrier (freegroup S)"
  have "carrier (freegroup S) = quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" by (simp add: freegroup_def)
  then have x:"x \<in> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" using assm by simp
  then show "x \<in> \<langle>liftgen S\<rangle>\<^bsub>freegroup S\<^esub>"
  proof(cases "x = \<one>\<^bsub>freegroup S\<^esub>")
case True
  then show ?thesis by simp
next
  case False
  then obtain x1 where def:"x = (reln_tuple \<langle>S\<rangle> ``{x1}) \<and> (x1 \<in> \<langle>S\<rangle>)"  by (meson x quotientE)
  then have "(x1 \<in> \<langle>S\<rangle>)" by simp
  then have "(reln_tuple \<langle>S\<rangle> ``{x1}) \<in> \<langle>liftgen S\<rangle>\<^bsub>freegroup S\<^esub>"
  proof(induction x1)
    case Nil
    have "\<one>\<^bsub>freegroup S\<^esub> = reln_tuple \<langle>S\<rangle> `` {[]}" by (simp add: freegroup_def)
  then show ?case  by (metis gen_span.gen_one)
next
  case (Cons a x1)
  then have a: "[a] \<in> \<langle>S\<rangle>" using Cons cons_span  freewords_on_def by blast
  moreover have c1:"x1  \<in> \<langle>S\<rangle>" using Cons span_cons  freewords_on_def by blast
  ultimately have wd:"reln_tuple \<langle>S\<rangle> `` {a # x1} = (proj_append \<langle>S\<rangle>) (reln_tuple \<langle>S\<rangle> `` {[a]})  (reln_tuple \<langle>S\<rangle> `` {x1})"  by (simp add: proj_append_wd)
  have x1in:"reln_tuple \<langle>S\<rangle> `` {x1} \<in> \<langle>liftgen S\<rangle>\<^bsub>freegroup S\<^esub>" using Cons by (simp add: c1)
  have "wordinverse [a] \<in> \<langle>S\<rangle>" using a span_wordinverse by blast
  then have inva: "reln_tuple \<langle>S\<rangle> `` {wordinverse [a]} \<in> carrier (freegroup S)" using freegroup_def by (simp add: freegroup_def quotientI)
  have invgen:"a \<in> (invgen S)" using a by (metis words_on.cases list.inject not_Cons_self2 freewords_on_def)
  then show ?case
  proof(cases "[a]  \<in> (\<iota> ` S)")
    case True
    then have "(reln_tuple \<langle>S\<rangle> `` {[a]}) \<in> liftgen S" by (simp add: inclusion_liftgen)
    then have "(reln_tuple \<langle>S\<rangle> `` {[a]}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>"
      by (simp add: gen_span.gen_gens)
    then have "(proj_append \<langle>S\<rangle>) (reln_tuple \<langle>S\<rangle> `` {[a]})  (reln_tuple \<langle>S\<rangle> `` {x1}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>" using freegroup_def x1in gen_mult[of "(reln_tuple \<langle>S\<rangle> `` {[a]})" "freegroup S" "liftgen S" "(reln_tuple \<langle>S\<rangle> `` {x1})"] by (metis monoid.select_convs(1))
    then show ?thesis using wd by simp
next
  case False
  then have "wordinverse [a] \<in> \<iota> ` S" using invgen invgen_elem by blast
  then have "(reln_tuple \<langle>S\<rangle> `` {wordinverse [a]}) \<in> liftgen S" by (simp add: inclusion_liftgen)
  then have 1: "(reln_tuple \<langle>S\<rangle> `` {wordinverse [a]}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>"
    by (simp add: gen_span.gen_gens)
  have "wordinverse (wordinverse [a]) = [a]"  using wordinverse_of_wordinverse by blast
  then have "inv\<^bsub>(freegroup S)\<^esub> (reln_tuple \<langle>S\<rangle> `` {wordinverse [a]}) = (reln_tuple \<langle>S\<rangle> `` { [a]})" using inva wordinverse_inv[of "(reln_tuple \<langle>S\<rangle> `` {wordinverse [a]})" "S" "wordinverse [a]"] by auto
  then have "(reln_tuple \<langle>S\<rangle> `` { [a]}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>" using 1  by (metis gen_span.gen_inv)
  then have "(proj_append \<langle>S\<rangle>) (reln_tuple \<langle>S\<rangle> `` {[a]})  (reln_tuple \<langle>S\<rangle> `` {x1}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>" using freegroup_def x1in gen_mult[of "(reln_tuple \<langle>S\<rangle> `` {[a]})" "freegroup S" "liftgen S" "(reln_tuple \<langle>S\<rangle> `` {x1})"] by (metis monoid.select_convs(1))
  then show ?thesis using wd by simp
qed
qed
  then show ?thesis using def by simp
qed
qed

lemma (in group) genmapext_unlift_uni:
  assumes "group G"
  and "f  \<in> liftgen (S::('c,'d) monoidgentype set) \<rightarrow> carrier G"
  and "h \<in> hom (freegroup S) G"
  and "\<forall> x \<in> (liftgen S) . f x = h x"
shows "\<forall>y \<in> carrier (freegroup S).  (genmapext_lift (\<iota> ` S) (unlift f S (liftgen S))) y = h y"
proof-
  have 1:"group (freegroup S)" by (simp add: freegroup_is_group)
  have "\<forall> x \<in> (liftgen S) . f x = (genmapext_lift (\<iota> ` S) (unlift f S (liftgen S))) x" using genmapext_unlift_ext assms(2) by blast
  then have "\<forall> x \<in> (liftgen S) . (genmapext_lift (\<iota> ` S) (unlift f S (liftgen S))) x = h x" using assms(4) by auto
  moreover have "(liftgen S) \<subseteq> carrier (freegroup S)" by (simp add: freegroup_def liftgen_subset_quotient)
  moreover have "(genmapext_lift (\<iota> ` S) (unlift f S (liftgen S))) \<in> hom (freegroup S) G" using assms(2) by (simp add: genmapext_unlift_hom)
  ultimately have "\<forall>x \<in> \<langle>(liftgen S)\<rangle>\<^bsub>(freegroup S)\<^esub>. (genmapext_lift (\<iota> ` S) (unlift f S (liftgen S))) x = h x" using hom_unique_on_span assms 1 by blast
  then show ?thesis  using liftgen_span by blast
qed

lemma "carrier (freegroup S) = \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>"
  by (meson freegroup_is_group group.liftgen_span group.span_liftgen subset_antisym)

text \<open>The following lemma proves that, every function from the generating set S to
 a group G, extends to a homomorphism from the freegroup generated by S to G.\<close>

theorem (in group) exists_hom:
  assumes "group G"
      and "f  \<in>  (S::('c,'d) monoidgentype set) \<rightarrow> carrier G"
    shows "\<exists>h \<in> hom (freegroup S) G. \<forall> x \<in> S. f x = h (reln_tuple \<langle>S\<rangle> `` {\<iota>  x})"
proof-
  have "inj_on \<iota> S" unfolding inclusion_def
    by (meson Pair_inject inj_onI list.inject)
  hence bij_step:"bij_betw \<iota> S (\<iota> ` S)" unfolding inclusion_def
    by (meson \<open>inj_on \<iota> S\<close> bij_betw_imageI inclusion_def inj_on_cong)
  then have inv:"\<forall>x \<in>  S. (the_inv_into S \<iota>) (\<iota> x) = x" unfolding the_inv_into_def bij_betw_def
       inj_on_def by auto
  define f' where "f' = f \<circ> (the_inv_into S \<iota>)"
  have "f' \<in> (\<iota> ` S) \<rightarrow> carrier G" using bij_step inv unfolding f'_def using assms(2) by force
  then have step1:"genmapext_lift (\<iota> ` S) f' \<in> hom (freegroup S) G" using genmapext_lift_hom
    by (simp add: \<open>\<And>f S. f \<in> \<iota> ` S \<rightarrow> carrier G \<Longrightarrow> genmapext_lift (\<iota> ` S) f \<in> hom F\<^bsub>S\<^esub> G\<close>)
  define h where "h = genmapext_lift (\<iota> ` S) f'"
  {fix x
   assume "x \<in> \<iota> ` S"
   hence ext_eq:"genmapext_lift (\<iota> ` S) f' (reln_tuple \<langle>S\<rangle> `` {x}) =  genmapext (\<iota> ` S) f' x"
     using genmapext_lift_wd
     by (smt (verit, best) Set.set_insert \<open>f' \<in> \<iota> ` S \<rightarrow> carrier G\<close> equiv_class_self inclusion_subset_spanset insert_subset quotientI reln_equiv)
  hence "h (reln_tuple \<langle>S\<rangle> `` {x}) =  genmapext (\<iota> ` S) f' x" unfolding h_def by simp}
  moreover then have "\<forall>x \<in> S. f x = genmapext (\<iota> ` S) f' (\<iota> x)" unfolding f'_def
    by (smt (z3) PiE assms(2) genmap_def genmapext.simps(1) genmapext.simps(2) image_eqI inclusion_def inv o_apply r_one)
  moreover then have "\<forall> x \<in> S. f x = f' (\<iota> x)" unfolding f'_def using inv by force
  ultimately have "\<forall> x \<in> S. f x = h (reln_tuple \<langle>S\<rangle> `` {\<iota> x})" by simp
  then show ?thesis using step1 h_def by fast
qed

text\<open>The following theorem proves that if a function f from a generating set S to a
 group G, extends to homomorphims h and g from the freegroup on S to G, then h and g
are unique upto their restriction on the carrier set of the freegroup. With the
previous theorem, this suffices to show the existence and uniqueness of
homomorphism extensions from freegroup S to G. \<close>
theorem (in group) uniqueness_of_lift:
  assumes "group G"
     and "f  \<in>  (S::('c,'d) monoidgentype set) \<rightarrow> carrier G"
     and "h \<in> hom (freegroup S) G" "g \<in> hom (freegroup S) G"
     and "\<forall> x \<in> S. f x = h (reln_tuple \<langle>S\<rangle> `` {\<iota>  x})"
     and "\<forall> x \<in> S. f x = g (reln_tuple \<langle>S\<rangle> `` {\<iota>  x})"
   shows "\<forall> x \<in> carrier (freegroup S).  h x  = g x"
proof-
  have "liftgen S \<subseteq> carrier (freegroup S)"
    by (simp add: freegroup_def liftgen_subset_quotient)
  hence h_in:"h \<in> (liftgen S) \<rightarrow> carrier G" using assms(3) span_liftgen
    using hom_in_carrier by fastforce
  hence h_eq:"\<forall>y\<in>carrier (freegroup S). genmapext_lift (\<iota> ` S) (unlift h S (liftgen S)) y = h y"
    using assms genmapext_unlift_uni by blast
  moreover have liftgen_inv:"\<forall>x \<in> (liftgen S). \<exists>y \<in> S. x = (reln_tuple \<langle>S\<rangle> `` {\<iota>  y})"
  proof
    fix x
    assume x:"x \<in> liftgen S"
    then obtain  y' where y':"y' \<in> \<iota> ` S" "x = reln_tuple \<langle>S\<rangle> ``{y'}" unfolding liftgen_def by blast
    then obtain y where "y \<in> S" "y' = \<iota> y" by auto
    thus "\<exists>y\<in>S. x = reln_tuple \<langle>S\<rangle> `` {\<iota> y}" using y' by auto
  qed
  {fix x
   assume asm:"x \<in> (liftgen S)"
   then obtain y where y:"y \<in> S" "x = (reln_tuple \<langle>S\<rangle> `` {\<iota>  y})" using liftgen_inv by meson
   then have "f y = h x" using assms by auto
   moreover have "f y =g x" using assms y by auto
   ultimately have "h x = g x" by auto}
  then have "\<forall>x \<in> (liftgen S). h x = g x" by auto
  then have "\<forall>y\<in>carrier (freegroup S). genmapext_lift (\<iota> ` S) (unlift h S (liftgen S)) y = g y"
    using h_in genmapext_unlift_uni
    using assms(4) by blast
  with h_eq have "\<forall>y\<in>carrier (freegroup S). h y = g y" by fastforce
  then show ?thesis by blast
qed

lemma  inv_extn_to_carrier:
 assumes "group G"
 and "(\<langle>S\<rangle>\<^bsub>G\<^esub>) = carrier G"
 and  "h \<in> hom G (freegroup S')"
 and  "g \<in> hom (freegroup S') G"
 and "\<forall> x \<in> S. g (h x) = x"
 shows "\<forall> x \<in> carrier G. g (h x) = x"
proof
  fix x
  assume "x \<in> carrier G"
  hence x_in:"x \<in> (\<langle>S\<rangle>\<^bsub>G\<^esub>)" using assms by auto
  have comp_hom:"g \<circ> h \<in> hom G G" using assms
    using Group.hom_compose by blast
  have "g (h x) = x" using x_in
  proof(induction rule:gen_span.induct)
    case gen_one
    then show ?case using x_in comp_hom hom_one[OF comp_hom assms(1) assms(1)] by force
  next
    case (gen_gens x)
    then show ?case using assms(5) by metis
  next
    case (gen_inv x)
    show ?case using assms(1,2,3,4) gen_inv
      by (metis comp_def comp_hom group.int_pow_1 group.int_pow_neg hom_int_pow)
  next
    case (gen_mult x y)
    then show ?case  using assms gen_mult.IH(1) gen_mult.IH(2) gen_mult.hyps(1) gen_mult.hyps(2) hom_mult comp_hom
      by (smt (verit, ccfv_SIG) hom_in_carrier)
  qed
  then show "g (h x) = x" by blast
qed

lemma surj_gen_implies_epi:
  assumes "h \<in> hom G H"
   and "carrier H = \<langle>S\<rangle>\<^bsub>H\<^esub>"
   and "group G"
   and "group H"
   and "S \<subseteq> h ` (carrier G)"
 shows "h \<in> epi G H"
proof-
  {fix x
  assume x_in:"x \<in> carrier H"
  hence "x \<in> h ` (carrier G)" unfolding assms(2)
  proof(induction x rule:gen_span.induct)
    case gen_one
    then show ?case using assms
      by (smt (verit, ccfv_SIG) antisym_conv gen_span.gen_one group.gen_span_closed group_hom.hom_span group_hom.intro group_hom_axioms.intro hom_carrier subset_image_iff)
  next
    case (gen_gens x)
    then show ?case using assms(5) by blast
  next
    case (gen_inv x)
    then show ?case
      by (smt (verit) assms(1) assms(3) assms(4) group.inv_equality group.l_inv_ex group_hom.hom_inv group_hom.intro group_hom_axioms.intro image_iff)
  next
    case (gen_mult x y)
    then show ?case
      by (smt (verit, ccfv_SIG) antisym_conv assms(1) assms(2) assms(3) assms(4) assms(5) group.gen_span_closed group.surj_const_mult group_hom.hom_span group_hom.intro group_hom_axioms.intro hom_carrier image_eqI subset_image_iff)
  qed}
  hence "h ` carrier G = carrier H" using assms(1)
    by (simp add: hom_carrier subsetI subset_antisym)
  thus ?thesis using assms(1) unfolding epi_def by blast
qed

text\<open>The following lemma states that a group G generated by a set S, satisfies
 the property that given any map f from S to a monoid of the given type,
it extends to a homomorphism from G to H, then G is isomorphic to a freegroup\<close>

lemma (in group) exist_of_hom_implies_freegroup: fixes S::"'a set"
  assumes "group G"
    and "(\<langle>S\<rangle>\<^bsub>G\<^esub>) = carrier G"
    and "\<And>(H::((unit \<times> 'a) \<times> bool) list set monoid).
          \<And>f. (group H)
           \<and> (f  \<in> S \<rightarrow> (carrier H)) \<longrightarrow> (\<exists>h \<in> hom G H. (\<forall> x \<in> S. h x = f x))"
  shows "\<exists>(S_H::(unit \<times> 'a) set). G \<cong> (freegroup S_H)" using assms
proof-
  define S_H where "(S_H::(unit, 'a) monoidgentype set) = ({()::unit}) \<times> S"
  define f' where "f' = (\<lambda>(x::'a). ((()::unit), x))"
  define f where "f = (\<lambda> (x::'a). (reln_tuple \<langle>S_H\<rangle> `` {\<iota>  (f' x)}))"
  hence bij:"bij_betw f' S S_H" unfolding bij_betw_def inj_on_def S_H_def f'_def by blast
  define Gs where "Gs = freegroup S_H"
  hence group_G:"group Gs"
    by (simp add: freegroup_is_group)
  moreover have f_to_carrier:"f \<in> S \<rightarrow> carrier Gs"
    unfolding f_def S_H_def Gs_def f'_def
  proof
    fix x
    assume "x \<in> S"
    hence "f' x \<in> S_H" using bij
      using bij_betwE by auto
    thus " reln_tuple \<langle>{()} \<times> S\<rangle> `` {\<iota> ((), x)} \<in> carrier F\<^bsub>{()} \<times> S\<^esub> " unfolding f'_def S_H_def
      by (metis (no_types, lifting) freegroup_def inclusion_subset_spanset insert_image insert_subset partial_object.simps(1) quotientI)
  qed
  then obtain h where h:"h \<in> hom G Gs" "\<forall>x \<in> S. h x = f x" using assms(3)[of Gs]
    by (metis group_G)
  have mod_assms2: "carrier G = \<langle>S\<rangle>\<^bsub>G\<^esub>" using assms by blast
  have h_epi:"h \<in> epi G Gs"
  proof-
   have carr_eq:"carrier Gs = \<langle>liftgen S_H\<rangle>\<^bsub>(freegroup S_H)\<^esub>" using Gs_def
         by (simp add: liftgen_span span_liftgen subset_antisym)
   moreover have "f ` S = liftgen S_H" unfolding liftgen_def S_H_def f_def f'_def
         by blast
   moreover have "f ` S = h ` S" using h(2) by simp
   ultimately have "(liftgen S_H) \<subseteq> h ` (carrier G)" using assms
         by (metis gen_span.gen_gens subsetI subset_image_iff)
   hence "h \<in> epi G Gs"  using surj_gen_implies_epi[OF h(1) ] unfolding Gs_def
         using  carr_eq freegroup_is_group assms(1)
         by (metis Gs_def)
   thus ?thesis unfolding epi_def by blast
  qed
  have inv_exists:"(inv_into S f') \<in> S_H \<rightarrow> carrier G" using  f_def f_to_carrier bij_betw_inv_into[OF bij]
    by (metis (no_types, lifting) Pi_I assms(2) bij_betw_imp_funcset funcset_mem gen_span.gen_gens)
  then obtain g where g:"g \<in> hom Gs G" "\<forall> x \<in> S_H. (inv_into S f') x = g (reln_tuple \<langle>S_H\<rangle> `` {\<iota>  x})"
    using bij exists_hom[OF assms(1) inv_exists]  Gs_def by auto
  then have "\<forall> x \<in> S. g (h x) = x" using h
    by (metis bij bij_betw_apply bij_betw_inv_into_left f_def)
  then have "\<forall>x \<in> carrier G. g (h x) = x" using inv_extn_to_carrier[OF assms(1,2)] h(1) g(1)
    unfolding Gs_def by fast
  hence "g \<circ> h \<in> iso G G" by auto
  hence "h \<in> Group.iso G Gs \<and> g \<in> Group.iso Gs G" using epi_iso_compose_rev[OF h_epi g(1)]
       iso_def by blast
  thus ?thesis using is_isoI unfolding Gs_def by blast
qed

text \<open>this provides a sufficient condition for isomorphism to a free group\<close>
lemma (in group) exist_of_hom_implies_freegroup': fixes S::"'a set"
  assumes "group G"
    and "(\<langle>S\<rangle>\<^bsub>G\<^esub>) = carrier G"
    and "\<And>(H::((unit \<times> 'a) \<times> bool) list set monoid).
          \<And>f. (group H)
           \<and> (f  \<in> S \<rightarrow> (carrier H)) \<longrightarrow> (\<exists>h \<in> hom G H. (\<forall> x \<in> S. h x = f x))"
  shows "is_freegroup G"
  using exist_of_hom_implies_freegroup[OF assms] unfolding is_freegroup_def by argo

end


section \<open> Alphabetised Relations \<close>

theory utp_rel
imports
  utp_pred_laws
  utp_healthy
  utp_lift
  utp_tactics
begin

text \<open> An alphabetised relation is simply a predicate whose state-space is a product type. In this
  theory we construct the core operators of the relational calculus, and prove a libary of
  associated theorems, based on Chapters 2 and 5 of the UTP book~\cite{Hoare&98}. \<close>

subsection \<open> Relational Alphabets \<close>

text \<open> We set up convenient syntax to refer to the input and output parts of the alphabet, as is
  common in UTP. Since we are in a product space, these are simply the lenses @{term "fst\<^sub>L"} and
  @{term "snd\<^sub>L"}. \<close>

definition in\<alpha> :: "('\<alpha> \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "in\<alpha> = fst\<^sub>L"

definition out\<alpha> :: "('\<beta> \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out\<alpha> = snd\<^sub>L"

lemma in\<alpha>_uvar [simp]: "vwb_lens in\<alpha>"
  by (unfold_locales, auto simp add: in\<alpha>_def)

lemma out\<alpha>_uvar [simp]: "vwb_lens out\<alpha>"
  by (unfold_locales, auto simp add: out\<alpha>_def)

lemma var_in_alpha [simp]: "x ;\<^sub>L in\<alpha> = ivar x"
  by (simp add: fst_lens_def in\<alpha>_def in_var_def)

lemma var_out_alpha [simp]: "x ;\<^sub>L out\<alpha> = ovar x"
  by (simp add: out\<alpha>_def out_var_def snd_lens_def)

lemma drop_pre_inv [simp]: "\<lbrakk> out\<alpha> \<sharp> p \<rbrakk> \<Longrightarrow> \<lceil>\<lfloor>p\<rfloor>\<^sub><\<rceil>\<^sub>< = p"
  by (pred_simp)

lemma usubst_lookup_ivar_unrest [usubst]:
  "in\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (ivar x) = $x"
  by (rel_simp, metis fstI)

lemma usubst_lookup_ovar_unrest [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (ovar x) = $x\<acute>"
  by (rel_simp, metis sndI)

lemma out_alpha_in_indep [simp]:
  "out\<alpha> \<bowtie> in_var x" "in_var x \<bowtie> out\<alpha>"
  by (simp_all add: in_var_def out\<alpha>_def lens_indep_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_alpha_out_indep [simp]:
  "in\<alpha> \<bowtie> out_var x" "out_var x \<bowtie> in\<alpha>"
  by (simp_all add: in_var_def in\<alpha>_def lens_indep_def fst_lens_def lens_comp_def)

text \<open> The following two functions lift a predicate substitution to a relational one. \<close>

abbreviation usubst_rel_lift :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<times> '\<beta>) usubst" ("\<lceil>_\<rceil>\<^sub>s") where
"\<lceil>\<sigma>\<rceil>\<^sub>s \<equiv> \<sigma> \<oplus>\<^sub>s in\<alpha>"

abbreviation usubst_rel_drop :: "('\<alpha> \<times> '\<alpha>) usubst \<Rightarrow> '\<alpha> usubst" ("\<lfloor>_\<rfloor>\<^sub>s") where
"\<lfloor>\<sigma>\<rfloor>\<^sub>s \<equiv> \<sigma> \<restriction>\<^sub>s in\<alpha>"

text \<open> The alphabet of a relation then consists wholly of the input and output portions. \<close>

lemma alpha_in_out:
  "\<Sigma> \<approx>\<^sub>L in\<alpha> +\<^sub>L out\<alpha>"
  by (simp add: fst_snd_id_lens in\<alpha>_def lens_equiv_refl out\<alpha>_def)

subsection \<open> Relational Types and Operators \<close>

text \<open> We create type synonyms for conditions (which are simply predicates) -- i.e. relations
  without dashed variables --, alphabetised relations where the input and output alphabet can
  be different, and finally homogeneous relations. \<close>

type_synonym '\<alpha> cond        = "'\<alpha> upred"
type_synonym ('\<alpha>, '\<beta>) urel  = "('\<alpha> \<times> '\<beta>) upred"
type_synonym '\<alpha> hrel        = "('\<alpha> \<times> '\<alpha>) upred"
type_synonym ('a, '\<alpha>) hexpr = "('a, '\<alpha> \<times> '\<alpha>) uexpr"

translations
  (type) "('\<alpha>, '\<beta>) urel" <= (type) "('\<alpha> \<times> '\<beta>) upred"

text \<open> We set up some overloaded constants for sequential composition and the identity in case
  we want to overload their definitions later. \<close>

consts
  useq     :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr ";;" 61)
  uassigns :: "'a usubst \<Rightarrow> 'b" ("\<langle>_\<rangle>\<^sub>a")
  uskip    :: "'a" ("II")

text \<open> We define a specialised version of the conditional where the condition can refer only to
  undashed variables, as is usually the case in programs, but not universally in UTP models.
  We implement this by lifting the condition predicate into the relational state-space with
  construction @{term "\<lceil>b\<rceil>\<^sub><"}. \<close>

definition lift_rcond ("\<lceil>_\<rceil>\<^sub>\<leftarrow>") where
[upred_defs]: "\<lceil>b\<rceil>\<^sub>\<leftarrow> = \<lceil>b\<rceil>\<^sub><"

abbreviation
  rcond :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<alpha>, '\<beta>) urel"
  ("(3_ \<triangleleft> _ \<triangleright>\<^sub>r/ _)" [52,0,53] 52)
  where "(P \<triangleleft> b \<triangleright>\<^sub>r Q) \<equiv> (P \<triangleleft> \<lceil>b\<rceil>\<^sub>\<leftarrow> \<triangleright> Q)"

text \<open> Sequential composition is heterogeneous, and simply requires that the output alphabet
  of the first matches then input alphabet of the second. We define it by lifting HOL's
  built-in relational composition operator (@{term "(O)"}). Since this returns a set, the
  definition states that the state binding $b$ is an element of this set. \<close>

lift_definition seqr::"('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<beta>, '\<gamma>) urel \<Rightarrow> ('\<alpha> \<times> '\<gamma>) upred"
is "\<lambda> P Q b. b \<in> ({p. P p} O {q. Q q})" .

adhoc_overloading
  useq seqr

text \<open> We also set up a homogeneous sequential composition operator, and versions of @{term true}
  and @{term false} that are explicitly typed by a homogeneous alphabet. \<close>

abbreviation seqh :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" (infixr ";;\<^sub>h" 61) where
"seqh P Q \<equiv> (P ;; Q)"

abbreviation truer :: "'\<alpha> hrel" ("true\<^sub>h") where
"truer \<equiv> true"

abbreviation falser :: "'\<alpha> hrel" ("false\<^sub>h") where
"falser \<equiv> false"

text \<open> We define the relational converse operator as an alphabet extrusion on the bijective
  lens @{term swap\<^sub>L} that swaps the elements of the product state-space. \<close>

abbreviation conv_r :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta> \<times> '\<alpha>) uexpr" ("_\<^sup>-" [999] 999)
where "conv_r e \<equiv> e \<oplus>\<^sub>p swap\<^sub>L"

text \<open> Assignment is defined using substitutions, where latter defines what each variable should
  map to. This approach, which is originally due to Back~\cite{Back1998}, permits more general
  assignment expressions. The definition of the operator identifies the after state binding, $b'$,
  with the substitution function applied to the before state binding $b$. \<close>

lift_definition assigns_r :: "'\<alpha> usubst \<Rightarrow> '\<alpha> hrel"
  is "\<lambda> \<sigma> (b, b'). b' = \<sigma>(b)" .

adhoc_overloading
  uassigns assigns_r

text \<open> Relational identity, or skip, is then simply an assignment with the identity substitution:
  it simply identifies all variables. \<close>

definition skip_r :: "'\<alpha> hrel" where
[urel_defs]: "skip_r = assigns_r id"

adhoc_overloading
  uskip skip_r

text \<open> Non-deterministic assignment, also known as ``choose'', assigns an arbitrarily chosen value
  to the given variable \<close>

definition nd_assign :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "nd_assign x = (\<Sqinter> v \<bullet> assigns_r [x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>])"

text \<open> We set up iterated sequential composition which iterates an indexed predicate over the
  elements of a list. \<close>

definition seqr_iter :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b hrel) \<Rightarrow> 'b hrel" where
[urel_defs]: "seqr_iter xs P = foldr (\<lambda> i Q. P(i) ;; Q) xs II"

text \<open> A singleton assignment simply applies a singleton substitution function, and similarly
  for a double assignment. \<close>

abbreviation assign_r :: "('t \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
where "assign_r x v \<equiv> \<langle>[x \<mapsto>\<^sub>s v]\<rangle>\<^sub>a"

abbreviation assign_2_r ::
  "('t1 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t2 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t1, '\<alpha>) uexpr \<Rightarrow> ('t2, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
where "assign_2_r x y u v \<equiv> assigns_r [x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v]"

text \<open> We also define the alphabetised skip operator that identifies all input and output variables
  in the given alphabet lens. All other variables are unrestricted. We also set up syntax for it. \<close>

definition skip_ra :: "('\<beta>, '\<alpha>) lens \<Rightarrow>'\<alpha> hrel" where
[urel_defs]: "skip_ra v = ($v\<acute> =\<^sub>u $v)"

text \<open> Similarly, we define the alphabetised assignment operator. \<close>

definition assigns_ra :: "'\<alpha> usubst \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> '\<alpha> hrel" ("\<langle>_\<rangle>\<^bsub>_\<^esub>") where
"\<langle>\<sigma>\<rangle>\<^bsub>a\<^esub> = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> skip_ra a)"

text \<open> Assumptions ($c^{\top}$) and assertions ($c_{\bot}$) are encoded as conditionals. An assumption
  behaves like skip if the condition is true, and otherwise behaves like @{term false} (miracle).
  An assertion is the same, but yields @{term true}, which is an abort. They are the same as
  tests, as in Kleene Algebra with Tests~\cite{kozen1997kleene,Armstrong2015}
  (KAT), which embeds a Boolean algebra into a Kleene algebra to represent conditions. \<close>

definition rassume :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "rassume c = II \<triangleleft> c \<triangleright>\<^sub>r false"

definition rassert :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "rassert c = II \<triangleleft> c \<triangleright>\<^sub>r true"

text \<open> We define two variants of while loops based on strongest and weakest fixed points. The former
  is @{term false} for an infinite loop, and the latter is @{term true}. \<close>

definition while_top :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "while_top b P = (\<nu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

definition while_bot :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "while_bot b P = (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

text \<open> While loops with invariant decoration (cf. \cite{Armstrong2015}) -- partial correctness. \<close>

definition while_inv :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "while_inv b p S = while_top b S"

text \<open> While loops with invariant decoration -- total correctness. \<close>

definition while_inv_bot :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"  where
[urel_defs]: "while_inv_bot b p S = while_bot b S"

text \<open> While loops with invariant and variant decorations -- total correctness. \<close>

definition while_vrt ::
  "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> (nat, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"  where
[urel_defs]: "while_vrt b p v S = while_bot b S"

syntax
  "_uassume"        :: "uexp \<Rightarrow> logic" ("[_]\<^sup>\<top>")
  "_uassume"        :: "uexp \<Rightarrow> logic" ("?[_]")
  "_uassert"        :: "uexp \<Rightarrow> logic" ("{_}\<^sub>\<bottom>")
  "_uwhile"         :: "uexp \<Rightarrow> logic \<Rightarrow> logic" ("while\<^sup>\<top> _ do _ od")
  "_uwhile_top"     :: "uexp \<Rightarrow> logic \<Rightarrow> logic" ("while _ do _ od")
  "_uwhile_bot"     :: "uexp \<Rightarrow> logic \<Rightarrow> logic" ("while\<^sub>\<bottom> _ do _ od")
  "_uwhile_inv"     :: "uexp \<Rightarrow> uexp \<Rightarrow> logic \<Rightarrow> logic" ("while _ invr _ do _ od")
  "_uwhile_inv_bot" :: "uexp \<Rightarrow> uexp \<Rightarrow> logic \<Rightarrow> logic" ("while\<^sub>\<bottom> _ invr _ do _ od" 71)
  "_uwhile_vrt"     :: "uexp \<Rightarrow> uexp \<Rightarrow> uexp \<Rightarrow> logic \<Rightarrow> logic" ("while _ invr _ vrt _ do _ od")

translations
  "_uassume b" == "CONST rassume b"
  "_uassert b" == "CONST rassert b"
  "_uwhile b P" == "CONST while_top b P"
  "_uwhile_top b P" == "CONST while_top b P"
  "_uwhile_bot b P" == "CONST while_bot b P"
  "_uwhile_inv b p S" == "CONST while_inv b p S"
  "_uwhile_inv_bot b p S" == "CONST while_inv_bot b p S"
  "_uwhile_vrt b p v S" == "CONST while_vrt b p v S"

text \<open> We implement a poor man's version of alphabet restriction that hides a variable within
  a relation. \<close>

definition rel_var_res :: "'\<alpha> hrel \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" (infix "\<restriction>\<^sub>\<alpha>" 80) where
[urel_defs]: "P \<restriction>\<^sub>\<alpha> x = (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P)"

text \<open> Alphabet extension and restriction add additional variables by the given lens in both
  their primed and unprimed versions. \<close>

definition rel_aext :: "'\<beta> hrel \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel"
where [upred_defs]: "rel_aext P a = P \<oplus>\<^sub>p (a \<times>\<^sub>L a)"

definition rel_ares :: "'\<alpha> hrel \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> hrel"
  where [upred_defs]: "rel_ares P a = (P \<restriction>\<^sub>p (a \<times> a))"

text \<open> We next describe frames and antiframes with the help of lenses. A frame states that $P$
  defines how variables in $a$ changed, and all those outside of $a$ remain the same. An
  antiframe describes the converse: all variables outside $a$ are specified by $P$, and all those in
  remain the same. For more information please see \cite{Morgan90a}.\<close>

definition frame :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "frame a P = (P \<and> $\<^bold>v\<acute> =\<^sub>u $\<^bold>v \<oplus> $\<^bold>v\<acute> on &a)"

definition antiframe :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "antiframe a P = (P \<and> $\<^bold>v\<acute> =\<^sub>u $\<^bold>v\<acute> \<oplus> $\<^bold>v on &a)"

text \<open> Frame extension combines alphabet extension with the frame operator to both add additional
  variables and then frame those. \<close>

definition rel_frext :: "('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> hrel \<Rightarrow> '\<alpha> hrel"  where
[upred_defs]: "rel_frext a P = frame a (rel_aext P a)"

text \<open> The nameset operator can be used to hide a portion of the after-state that lies outside
  the lens $a$. It can be useful to partition a relation's variables in order to conjoin it
  with another relation. \<close>

definition nameset :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "nameset a P = (P \<restriction>\<^sub>v {$\<^bold>v,$a\<acute>})"

subsection \<open> Syntax Translations \<close>

syntax
  \<comment> \<open> Alternative traditional conditional syntax \<close>
  "_utp_if" :: "uexp \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(if\<^sub>u (_)/ then (_)/ else (_))" [0, 0, 71] 71)
  \<comment> \<open> Iterated sequential composition \<close>
  "_seqr_iter" :: "pttrn \<Rightarrow> 'a list \<Rightarrow> '\<sigma> hrel \<Rightarrow> '\<sigma> hrel" ("(3;; _ : _ \<bullet>/ _)" [0, 0, 10] 10)
  \<comment> \<open> Single and multiple assignement \<close>
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  ("'(_') := '(_')")
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  (infixr ":=" 62)
  \<comment> \<open> Non-deterministic assignment \<close>
  "_nd_assign" :: "svids \<Rightarrow> logic" ("_ := *" [62] 62)
  \<comment> \<open> Substitution constructor \<close>
  "_mk_usubst"      :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> usubst"
  \<comment> \<open> Alphabetised skip \<close>
  "_skip_ra"        :: "salpha \<Rightarrow> logic" ("II\<^bsub>_\<^esub>")
  \<comment> \<open> Frame \<close>
  "_frame"          :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]" [99,0] 100)
  \<comment> \<open> Antiframe \<close>
  "_antiframe"      :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:\<lbrakk>_\<rbrakk>" [79,0] 80)
  \<comment> \<open> Relational Alphabet Extension \<close>
  "_rel_aext"  :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<oplus>\<^sub>r" 90)
  \<comment> \<open> Relational Alphabet Restriction \<close>
  "_rel_ares"  :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<restriction>\<^sub>r" 90)
  \<comment> \<open> Frame Extension \<close>
  "_rel_frext" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sup>+" [99,0] 100)
  \<comment> \<open> Nameset \<close>
  "_nameset"        :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("ns _ \<bullet> _" [0,999] 999)

translations
  "_utp_if b P Q" => "P \<triangleleft> b \<triangleright>\<^sub>r Q"
  ";; x : l \<bullet> P" \<rightleftharpoons> "(CONST seqr_iter) l (\<lambda>x. P)"
  "_mk_usubst \<sigma> (_svid_unit x) v" \<rightleftharpoons> "\<sigma>(&x \<mapsto>\<^sub>s v)"
  "_mk_usubst \<sigma> (_svid_list x xs) (_uexprs v vs)" \<rightleftharpoons> "(_mk_usubst (\<sigma>(&x \<mapsto>\<^sub>s v)) xs vs)"
  "_assignment xs vs" => "CONST uassigns (_mk_usubst (CONST id) xs vs)"
  "_assignment x v" <= "CONST uassigns (CONST subst_upd (CONST id) x v)"
  "_assignment x v" <= "_assignment (_spvar x) v"
  "_nd_assign x" => "CONST nd_assign (_mk_svid_list x)"
  "_nd_assign x" <= "CONST nd_assign x"
  "x,y := u,v" <= "CONST uassigns (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"
  "_skip_ra v" \<rightleftharpoons> "CONST skip_ra v"
  "_frame x P" => "CONST frame x P"
  "_frame (_salphaset (_salphamk x)) P" <= "CONST frame x P"
  "_antiframe x P" => "CONST antiframe x P"
  "_antiframe (_salphaset (_salphamk x)) P" <= "CONST antiframe x P"
  "_nameset x P" == "CONST nameset x P"
  "_rel_aext P a" == "CONST rel_aext P a"
  "_rel_ares P a" == "CONST rel_ares P a"
  "_rel_frext a P" == "CONST rel_frext a P"

text \<open> The following code sets up pretty-printing for homogeneous relational expressions. We cannot
  do this via the ``translations'' command as we only want the rule to apply when the input and output
  alphabet types are the same. The code has to deconstruct a @{typ "('a, '\<alpha>) uexpr"} type, determine
  that it is relational (product alphabet), and then checks if the types \emph{alpha} and \emph{beta}
  are the same. If they are, the type is printed as a \emph{hexpr}. Otherwise, we have no match.
  We then set up a regular translation for the \emph{hrel} type that uses this. \<close>

print_translation \<open>
let
fun tr' ctxt [ a
            , Const (@{type_syntax "prod"},_) $ alpha $ beta ] =
  if (alpha = beta)
    then Syntax.const @{type_syntax "hexpr"} $ a $ alpha
    else raise Match;
in [(@{type_syntax "uexpr"},tr')]
end
\<close>

translations
  (type) "'\<alpha> hrel" <= (type) "(bool, '\<alpha>) hexpr"

subsection \<open> Relation Properties \<close>

text \<open> We describe some properties of relations, including functional and injective relations. We
  also provide operators for extracting the domain and range of a UTP relation. \<close>

definition ufunctional :: "('a, 'b) urel \<Rightarrow> bool"
where [urel_defs]: "ufunctional R \<longleftrightarrow> II \<sqsubseteq> R\<^sup>- ;; R"

definition uinj :: "('a, 'b) urel \<Rightarrow> bool"
where [urel_defs]: "uinj R \<longleftrightarrow> II \<sqsubseteq> R ;; R\<^sup>-"

definition Dom :: "'\<alpha> hrel \<Rightarrow> '\<alpha> upred"
where [upred_defs]: "Dom P = \<lfloor>\<exists> $\<^bold>v\<acute> \<bullet> P\<rfloor>\<^sub><"

definition Ran :: "'\<alpha> hrel \<Rightarrow> '\<alpha> upred"
where [upred_defs]: "Ran P = \<lfloor>\<exists> $\<^bold>v \<bullet> P\<rfloor>\<^sub>>"

\<comment> \<open> Configuration for UTP tactics. \<close>

update_uexpr_rep_eq_thms \<comment> \<open> Reread @{text rep_eq} theorems. \<close>

subsection \<open> Introduction laws \<close>

lemma urel_refine_ext:
  "\<lbrakk> \<And> s s'. P\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<sqsubseteq> Q\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<rbrakk> \<Longrightarrow> P \<sqsubseteq> Q"
  by (rel_auto)

lemma urel_eq_ext:
  "\<lbrakk> \<And> s s'. P\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> = Q\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto)

subsection \<open> Unrestriction Laws \<close>

lemma unrest_iuvar [unrest]: "out\<alpha> \<sharp> $x"
  by (metis fst_snd_lens_indep lift_pre_var out\<alpha>_def unrest_aext_indep)

lemma unrest_ouvar [unrest]: "in\<alpha> \<sharp> $x\<acute>"
  by (metis in\<alpha>_def lift_post_var snd_fst_lens_indep unrest_aext_indep)

lemma unrest_semir_undash [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "$x \<sharp> P"
  shows "$x \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_semir_dash [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "$x\<acute> \<sharp> Q"
  shows "$x\<acute> \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_cond [unrest]:
  "\<lbrakk> x \<sharp> P; x \<sharp> b; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<triangleleft> b \<triangleright> Q"
  by (rel_auto)

lemma unrest_lift_rcond [unrest]:
  "x \<sharp> \<lceil>b\<rceil>\<^sub>< \<Longrightarrow> x \<sharp> \<lceil>b\<rceil>\<^sub>\<leftarrow>"
  by (simp add: lift_rcond_def)

lemma unrest_in\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; in\<alpha> \<sharp> (P :: ('a, ('\<alpha> \<times> '\<beta>)) uexpr) \<rbrakk> \<Longrightarrow> $x \<sharp> P"
  by (rel_auto)

lemma unrest_out\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; out\<alpha> \<sharp> (P :: ('a, ('\<alpha> \<times> '\<beta>)) uexpr) \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P"
  by (rel_auto)

lemma unrest_pre_out\<alpha> [unrest]: "out\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub><"
  by (transfer, auto simp add: out\<alpha>_def)

lemma unrest_post_in\<alpha> [unrest]: "in\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub>>"
  by (transfer, auto simp add: in\<alpha>_def)

lemma unrest_pre_in_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x \<sharp> \<lceil>p1\<rceil>\<^sub><"
  by (transfer, simp)

lemma unrest_post_out_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x\<acute> \<sharp> \<lceil>p1\<rceil>\<^sub>>"
  by (transfer, simp)

lemma unrest_convr_out\<alpha> [unrest]:
  "in\<alpha> \<sharp> p \<Longrightarrow> out\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: lens_defs)

lemma unrest_convr_in\<alpha> [unrest]:
  "out\<alpha> \<sharp> p \<Longrightarrow> in\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: lens_defs)

lemma unrest_in_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_alpha_usubst_rel_lift [unrest]:
  "out\<alpha> \<sharp> \<lceil>\<sigma>\<rceil>\<^sub>s"
  by (rel_auto)

lemma unrest_in_rel_aext [unrest]: "x \<bowtie> y \<Longrightarrow> $y \<sharp> P \<oplus>\<^sub>r x"
  by (simp add: rel_aext_def unrest_aext_indep)

lemma unrest_out_rel_aext [unrest]: "x \<bowtie> y \<Longrightarrow> $y\<acute> \<sharp> P \<oplus>\<^sub>r x"
  by (simp add: rel_aext_def unrest_aext_indep)

lemma rel_aext_false [alpha]:
  "false \<oplus>\<^sub>r a = false"
  by (pred_auto)

lemma rel_aext_seq [alpha]:
  "weak_lens a \<Longrightarrow> (P ;; Q) \<oplus>\<^sub>r a = (P \<oplus>\<^sub>r a ;; Q \<oplus>\<^sub>r a)"
  apply (rel_auto)
  apply (rename_tac aa b y)
  apply (rule_tac x="create\<^bsub>a\<^esub> y" in exI)
  apply (simp)
  done

lemma rel_aext_cond [alpha]:
  "(P \<triangleleft> b \<triangleright>\<^sub>r Q) \<oplus>\<^sub>r a = (P \<oplus>\<^sub>r a \<triangleleft> b \<oplus>\<^sub>p a \<triangleright>\<^sub>r Q \<oplus>\<^sub>r a)"
  by (rel_auto)

subsection \<open> Substitution laws \<close>

lemma subst_seq_left [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = (\<sigma> \<dagger> P) ;; Q"
  by (rel_simp, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

lemma subst_seq_right [usubst]:
  "in\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = P ;; (\<sigma> \<dagger> Q)"
  by (rel_simp, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

text \<open> The following laws support substitution in heterogeneous relations for polymorphically
  typed literal expressions. These cannot be supported more generically due to limitations
  in HOL's type system. The laws are presented in a slightly strange way so as to be as
  general as possible. \<close>

lemma bool_seqr_laws [usubst]:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>true/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>false/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>true/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>false/$x\<acute>\<rbrakk>)"
    by (rel_auto)+

lemma zero_one_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>0/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>1/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>0/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>1/$x\<acute>\<rbrakk>)"
    by (rel_auto)+

lemma numeral_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>numeral n/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>numeral n/$x\<acute>\<rbrakk>)"
  by (rel_auto)+

lemma usubst_condr [usubst]:
  "\<sigma> \<dagger> (P \<triangleleft> b \<triangleright> Q) = (\<sigma> \<dagger> P \<triangleleft> \<sigma> \<dagger> b \<triangleright> \<sigma> \<dagger> Q)"
  by (rel_auto)

lemma subst_skip_r [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> II = \<langle>\<lfloor>\<sigma>\<rfloor>\<^sub>s\<rangle>\<^sub>a"
  by (rel_simp, (metis (mono_tags, lifting) prod.sel(1) sndI surjective_pairing)+)

lemma subst_pre_skip [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II = \<langle>\<sigma>\<rangle>\<^sub>a"
  by (rel_auto)

lemma subst_rel_lift_seq [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> (P ;; Q) = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P) ;; Q"
  by (rel_auto)

lemma subst_rel_lift_comp [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<circ> \<lceil>\<rho>\<rceil>\<^sub>s = \<lceil>\<sigma> \<circ> \<rho>\<rceil>\<^sub>s"
  by (rel_auto)

lemma usubst_upd_in_comp [usubst]:
  "\<sigma>(&in\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x \<mapsto>\<^sub>s v)"
  by (simp add: pr_var_def fst_lens_def in\<alpha>_def in_var_def)

lemma usubst_upd_out_comp [usubst]:
  "\<sigma>(&out\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x\<acute> \<mapsto>\<^sub>s v)"
  by (simp add: pr_var_def out\<alpha>_def out_var_def snd_lens_def)

lemma subst_lift_upd [alpha]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lceil>\<sigma>(x \<mapsto>\<^sub>s v)\<rceil>\<^sub>s = \<lceil>\<sigma>\<rceil>\<^sub>s($x \<mapsto>\<^sub>s \<lceil>v\<rceil>\<^sub><)"
  by (simp add: alpha usubst, simp add: pr_var_def fst_lens_def in\<alpha>_def in_var_def)

lemma subst_drop_upd [alpha]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lfloor>\<sigma>($x \<mapsto>\<^sub>s v)\<rfloor>\<^sub>s = \<lfloor>\<sigma>\<rfloor>\<^sub>s(x \<mapsto>\<^sub>s \<lfloor>v\<rfloor>\<^sub><)"
  by pred_simp

lemma subst_lift_pre [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>b\<rceil>\<^sub>< = \<lceil>\<sigma> \<dagger> b\<rceil>\<^sub><"
  by (metis apply_subst_ext fst_vwb_lens in\<alpha>_def)

lemma unrest_usubst_lift_in [unrest]:
  "x \<sharp> P \<Longrightarrow> $x \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by pred_simp

lemma unrest_usubst_lift_out [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "$x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by pred_simp

lemma subst_lift_cond [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>s\<rceil>\<^sub>\<leftarrow> = \<lceil>\<sigma> \<dagger> s\<rceil>\<^sub>\<leftarrow>"
  by (rel_auto)

lemma msubst_seq [usubst]: "(P(x) ;; Q(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk> = ((P(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk> ;; (Q(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk>)"
  by (rel_auto)

subsection \<open> Alphabet laws \<close>

lemma aext_cond [alpha]:
  "(P \<triangleleft> b \<triangleright> Q) \<oplus>\<^sub>p a = ((P \<oplus>\<^sub>p a) \<triangleleft> (b \<oplus>\<^sub>p a) \<triangleright> (Q \<oplus>\<^sub>p a))"
  by (rel_auto)

lemma aext_seq [alpha]:
  "wb_lens a \<Longrightarrow> ((P ;; Q) \<oplus>\<^sub>p (a \<times>\<^sub>L a)) = ((P \<oplus>\<^sub>p (a \<times>\<^sub>L a)) ;; (Q \<oplus>\<^sub>p (a \<times>\<^sub>L a)))"
  by (rel_simp, metis wb_lens_weak weak_lens.put_get)

lemma rcond_lift_true [simp]:
  "\<lceil>true\<rceil>\<^sub>\<leftarrow> = true"
  by rel_auto

lemma rcond_lift_false [simp]:
  "\<lceil>false\<rceil>\<^sub>\<leftarrow> = false"
  by rel_auto

lemma rel_ares_aext [alpha]:
  "vwb_lens a \<Longrightarrow> (P \<oplus>\<^sub>r a) \<restriction>\<^sub>r a = P"
  by (rel_auto)

lemma rel_aext_ares [alpha]:
  "{$a, $a\<acute>} \<natural> P \<Longrightarrow> P \<restriction>\<^sub>r a \<oplus>\<^sub>r a = P"
  by (rel_auto)

lemma rel_aext_uses [unrest]:
  "vwb_lens a \<Longrightarrow> {$a, $a\<acute>} \<natural> (P \<oplus>\<^sub>r a)"
  by (rel_auto)

subsection \<open> Relational unrestriction \<close>

text \<open> Relational unrestriction states that a variable is both unchanged by a relation, and is
  not "read" by the relation. \<close>

definition RID :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"
where "RID x P = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x)"

declare RID_def [urel_defs]

lemma RID1: "vwb_lens x \<Longrightarrow> (\<forall> v. x := \<guillemotleft>v\<guillemotright> ;; P = P ;; x := \<guillemotleft>v\<guillemotright>) \<Longrightarrow> RID(x)(P) = P"
  apply (rel_auto)
   apply (metis vwb_lens.put_eq)
  apply (metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)
  done

lemma RID2: "vwb_lens x \<Longrightarrow> x := \<guillemotleft>v\<guillemotright> ;; RID(x)(P) = RID(x)(P) ;; x := \<guillemotleft>v\<guillemotright>"
  apply (rel_auto)
   apply (metis mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put wb_lens_def weak_lens.put_get)
  apply blast
  done

lemma RID_assign_commute:
  "vwb_lens x \<Longrightarrow> P = RID(x)(P) \<longleftrightarrow> (\<forall> v. x := \<guillemotleft>v\<guillemotright> ;; P = P ;; x := \<guillemotleft>v\<guillemotright>)"
  by (metis RID1 RID2)

lemma RID_idem:
  "mwb_lens x \<Longrightarrow> RID(x)(RID(x)(P)) = RID(x)(P)"
  by (rel_auto)

lemma RID_mono:
  "P \<sqsubseteq> Q \<Longrightarrow> RID(x)(P) \<sqsubseteq> RID(x)(Q)"
  by (rel_auto)

lemma RID_pr_var [simp]:
  "RID (pr_var x) = RID x"
  by (simp add: pr_var_def)

lemma RID_skip_r:
  "vwb_lens x \<Longrightarrow> RID(x)(II) = II"
  apply (rel_auto) using vwb_lens.put_eq by fastforce

lemma skip_r_RID [closure]: "vwb_lens x \<Longrightarrow> II is RID(x)"
  by (simp add: Healthy_def RID_skip_r)

lemma RID_disj:
  "RID(x)(P \<or> Q) = (RID(x)(P) \<or> RID(x)(Q))"
  by (rel_auto)

lemma disj_RID [closure]: "\<lbrakk> P is RID(x); Q is RID(x) \<rbrakk> \<Longrightarrow> (P \<or> Q) is RID(x)"
  by (simp add: Healthy_def RID_disj)

lemma RID_conj:
  "vwb_lens x \<Longrightarrow> RID(x)(RID(x)(P) \<and> RID(x)(Q)) = (RID(x)(P) \<and> RID(x)(Q))"
  by (rel_auto)

lemma conj_RID [closure]: "\<lbrakk> vwb_lens x; P is RID(x); Q is RID(x) \<rbrakk> \<Longrightarrow> (P \<and> Q) is RID(x)"
  by (metis Healthy_if Healthy_intro RID_conj)

lemma RID_assigns_r_diff:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> RID(x)(\<langle>\<sigma>\<rangle>\<^sub>a) = \<langle>\<sigma>\<rangle>\<^sub>a"
  apply (rel_auto)
   apply (metis vwb_lens.put_eq)
  apply (metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)
  done

lemma assigns_r_RID [closure]: "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>a is RID(x)"
  by (simp add: Healthy_def RID_assigns_r_diff)

lemma RID_assign_r_same:
  "vwb_lens x \<Longrightarrow> RID(x)(x := v) = II"
  apply (rel_auto)
  using vwb_lens.put_eq apply fastforce
  done

lemma RID_seq_left:
  assumes "vwb_lens x"
  shows "RID(x)(RID(x)(P) ;; Q) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(RID(x)(P) ;; Q) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; Q) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> (\<exists> $x \<bullet> $x\<acute> =\<^sub>u $x)) ;; (\<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
     apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
    done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

lemma RID_seq_right:
  assumes "vwb_lens x"
  shows "RID(x)(P ;; RID(x)(Q)) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(P ;; RID(x)(Q)) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = (((\<exists> $x \<bullet>  P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> (\<exists> $x\<acute> \<bullet> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
     apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
    done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp robust, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

lemma seqr_RID_closed [closure]: "\<lbrakk> vwb_lens x; P is RID(x); Q is RID(x) \<rbrakk> \<Longrightarrow> P ;; Q is RID(x)"
  by (metis Healthy_def RID_seq_right)

definition unrest_relation :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> bool" (infix "\<sharp>\<sharp>" 20)
where "(x \<sharp>\<sharp> P) \<longleftrightarrow> (P is RID(x))"

declare unrest_relation_def [urel_defs]

lemma runrest_assign_commute:
  "\<lbrakk> vwb_lens x; x \<sharp>\<sharp> P \<rbrakk> \<Longrightarrow> x := \<guillemotleft>v\<guillemotright> ;; P = P ;; x := \<guillemotleft>v\<guillemotright>"
  by (metis RID2 Healthy_def unrest_relation_def)

lemma runrest_ident_var:
  assumes "x \<sharp>\<sharp> P"
  shows "($x \<and> P) = (P \<and> $x\<acute>)"
proof -
  have "P = ($x\<acute> =\<^sub>u $x \<and> P)"
    by (metis RID_def assms Healthy_def unrest_relation_def utp_pred_laws.inf.cobounded2 utp_pred_laws.inf_absorb2)
  moreover have "($x\<acute> =\<^sub>u $x \<and> ($x \<and> P)) = ($x\<acute> =\<^sub>u $x \<and> (P \<and> $x\<acute>))"
    by (rel_auto)
  ultimately show ?thesis
    by (metis utp_pred_laws.inf.assoc utp_pred_laws.inf_left_commute)
qed

lemma skip_r_runrest [unrest]:
  "vwb_lens x \<Longrightarrow> x \<sharp>\<sharp> II"
  by (simp add: unrest_relation_def closure)

lemma assigns_r_runrest:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> \<langle>\<sigma>\<rangle>\<^sub>a"
  by (simp add: unrest_relation_def closure)

lemma seq_r_runrest [unrest]:
  assumes "vwb_lens x" "x \<sharp>\<sharp> P" "x \<sharp>\<sharp> Q"
  shows "x \<sharp>\<sharp> (P ;; Q)"
  using assms by (simp add: unrest_relation_def closure )

lemma false_runrest [unrest]: "x \<sharp>\<sharp> false"
  by (rel_auto)

lemma and_runrest [unrest]: "\<lbrakk> vwb_lens x; x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<and> Q)"
  by (metis RID_conj Healthy_def unrest_relation_def)

lemma or_runrest [unrest]: "\<lbrakk> x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<or> Q)"
  by (simp add: RID_disj Healthy_def unrest_relation_def)

end