theory UniversalProperty
imports "Generators" "FreeGroupMain" "CancelResults" "Iter_Reduction_Results"
begin

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>X \<subseteq> carrier G . \<forall>group H .(\<forall>f \<in> X \<rightarrow> carrier H . (\<exists>g \<in> hom G H . (\<forall>x \<in> X . f x = g x) \<and> (\<forall>h \<in> hom G H. \<forall>x \<in> X .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 gens S x = f (reln_set \<langle>gens\<rangle> `` {x})"

lemma (in group) genmap_closed:
  assumes cl: "f \<in> (\<iota> ` (gens ::('a, 'b) monoidgentype set)) \<rightarrow> carrier G"
      and "g \<in> (\<iota> ` gens) \<union> (wordinverse ` (\<iota> ` gens))"
    shows "genmap (\<iota> ` gens) f g \<in> carrier G"
proof-
  have 1:"g \<in> (\<iota> ` gens) \<or> g \<in> (wordinverse ` (\<iota> ` gens))" using assms(2) by blast
  then show ?thesis
  proof(cases "g \<in> (\<iota> ` gens)")
    case True
    then show ?thesis using assms by (metis Pi_mem genmap_def)
  next
    case False
    then have 2: "g \<in> (wordinverse ` (\<iota> ` gens))" using 1 by simp
    then have "genmap (\<iota> ` gens) f g =  inv (f (wordinverse g))" by (simp add: False genmap_def)
    moreover have "wordinverse g  \<in> (\<iota> ` gens)" 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> \<llangle>S\<rrangle>" "xs \<noteq> []" shows "hd xs \<in> S"
  using assms
proof(induction xs)
  case empty
  then show ?case by simp
next
  case (gen x xs)
  then show ?case by simp
qed

lemma inclusion_union:
  assumes "a \<in> (gens ::('a, 'b) monoidgentype set) \<times> {True, False}"
  shows "[a] \<in> (\<iota> ` gens) \<union> (wordinverse ` (\<iota> ` gens))"
proof(cases "snd a = True")
  case True
  have "fst a \<in> gens" 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> gens" 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> ` gens)" 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> ` (gens ::('a, 'b) monoidgentype set)) \<rightarrow> carrier G"
      and "x \<in> FreeGroupMain.spanset  gens"
    shows "genmapext (\<iota> ` gens) 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> ` gens) f (a # x) = genmap (\<iota> ` gens) f [a] \<otimes>  (genmapext (\<iota> ` gens)  f x)" by simp
  have "a \<in> gens \<times> {True, False}"  using FreeGroupMain.spanset_def gen_spanset invgen_def Cons by (metis list.distinct(1) list.sel(1))
  then have "[a] \<in> (\<iota> ` gens) \<union> (wordinverse ` (\<iota> ` gens))" using inclusion_union  by blast
  then have " genmap (\<iota> ` gens) f [a] \<in> carrier G" using genmap_closed Cons.prems(1) by meson
  moreover have "x \<in> \<langle>gens\<rangle>" using Cons.prems(2) FreeGroupMain.spanset_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> ` (gens ::('a, 'b) monoidgentype set)) \<rightarrow> carrier G"
      and "x \<in> FreeGroupMain.spanset gens"
      and "y \<in> FreeGroupMain.spanset gens"
    shows "genmapext (\<iota> ` gens)  f (x @ y) = genmapext (\<iota> ` gens) f x \<otimes> genmapext (\<iota> ` gens) f y"
  using assms
proof(induction x)
  case Nil
  have "genmapext (\<iota> ` gens) f [] = \<one>" by simp
  moreover have "genmapext (\<iota> ` gens) f y \<in> carrier G" using genmapext_closed assms by auto
  then have "genmapext (\<iota> ` gens) f [] \<otimes> genmapext (\<iota> ` gens)  f y = genmapext (\<iota> ` gens) f y" using r_one by simp
  then show ?case by simp
next
  case (Cons a x)
  have "a \<in> gens \<times> {True, False}" using FreeGroupMain.spanset_def gen_spanset invgen_def Cons by (metis list.distinct(1) list.sel(1))
  then have a:"[a] \<in> (\<iota> ` gens) \<union> (wordinverse ` (\<iota> ` gens))" using inclusion_union  by blast
  have x:"x \<in> \<langle>gens\<rangle>" using Cons.prems(2) FreeGroupMain.spanset_def span_cons by blast
  have "genmapext (\<iota> ` gens) f (a # x) \<otimes> genmapext (\<iota> ` gens) f y = genmap (\<iota> ` gens) f [a] \<otimes> genmapext (\<iota> ` gens) f x \<otimes> genmapext (\<iota> ` gens) f y" by simp
  then have 1: "genmapext (\<iota> ` gens) f (a # x) \<otimes> genmapext (\<iota> ` gens) f y = genmap (\<iota> ` gens) f [a] \<otimes> genmapext (\<iota> ` gens) f (x @ y)" using Cons.IH Cons.prems(1) Cons.prems(3)  a genmap_closed genmapext_closed m_assoc x by presburger
  have "genmapext  (\<iota> ` gens) f ((a # x) @ y) = genmapext (\<iota> ` gens) f (a # (x  @ y))" by auto
  then have "genmapext (\<iota> ` gens) f ((a #x) @ y) = genmap (\<iota> ` gens) f [a] \<otimes> genmapext (\<iota> ` gens) 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> FreeGroupMain.spanset gens"
    shows "y \<in> FreeGroupMain.spanset gens"
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> FreeGroupMain.spanset gens" using x leftappend_span FreeGroupMain.spanset_def assms(2) by blast
  moreover have "xs2 \<in> FreeGroupMain.spanset gens" using x rightappend_span FreeGroupMain.spanset_def assms(2) span_cons by blast
  ultimately show ?thesis using y by (simp add: span_append FreeGroupMain.spanset_def)
qed

lemma cancels_to_preserves:
  assumes "cancels_to x y"
      and "x \<in> FreeGroupMain.spanset gens"
    shows "y \<in> FreeGroupMain.spanset gens"
  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> ` gens)"
  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> FreeGroupMain.spanset (gens ::('a, 'b) monoidgentype set)"
  and "[x2] \<in> FreeGroupMain.spanset gens"
  and "f \<in> (\<iota> ` gens) \<rightarrow> carrier G"
  shows "(genmapext (\<iota> ` gens) f [x1] \<otimes> genmapext (\<iota> ` gens) f [x2]) = \<one>"
proof-
  have "genmapext (\<iota> ` gens) f [x1] = genmap (\<iota> ` gens) f [x1] \<otimes> \<one>" by simp
  have x1:"x1 \<in> gens \<times> {True, False}" using  invgen_def gen_spanset FreeGroupMain.spanset_def assms(2)  by (metis list.distinct(1) list.sel(1))
  then have "[x1] \<in> (\<iota> ` gens) \<union> (wordinverse ` (\<iota> ` gens))" using inclusion_union  by blast
  then have g1:"genmap (\<iota> ` gens) f [x1] \<in> carrier G" using genmap_closed[of "f" "gens" "[x1]"] assms(4) by fast
  moreover have "genmapext (\<iota> ` gens) f [x1] = genmap (\<iota> ` gens) f [x1] \<otimes> \<one>" by simp
  ultimately have 1:"genmapext (\<iota> ` gens) f [x1] = genmap (\<iota> ` gens) f [x1]" by simp
  have "genmapext (\<iota> ` gens) f [x2] = genmap (\<iota> ` gens) f [x2] \<otimes> \<one>" by simp
  have x2:"x2 \<in> gens \<times> {True, False}" using  invgen_def gen_spanset FreeGroupMain.spanset_def assms(3)  by (metis list.distinct(1) list.sel(1))
  then have "[x2] \<in> (\<iota> ` gens) \<union> (wordinverse ` (\<iota> ` gens))" using inclusion_union  by blast
  then have g2:"genmap (\<iota> ` gens) f [x2] \<in> carrier G" using genmap_closed assms(4) by blast
  moreover have "genmapext (\<iota> ` gens) f [x2] = genmap (\<iota> ` gens) f [x2] \<otimes> \<one>" by simp
  ultimately have 2:"genmapext (\<iota> ` gens) f [x2] = genmap (\<iota> ` gens) f [x2]" by simp
  have fx1:"fst x1 \<in> gens" using x1 by auto
  have fx2:"fst x2 \<in> gens" 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> ` gens)" using fx2 by (metis inclusion_def rev_image_eqI surjective_pairing)
    then have a:"genmap (\<iota> ` gens) f [x2] = f [x2]" by (simp add: genmap_def)
    have "[x1] \<notin> (\<iota> ` gens)" using inclusion_snd True  by metis
    moreover have "wordinverse [x1] = [x2]" by (simp add: assms(1))
    ultimately have "genmap (\<iota> ` gens) 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> ` gens)" using fx1 by (metis inclusion_def rev_image_eqI surjective_pairing)
    then have a:"genmap (\<iota> ` gens) 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> ` gens)" using inclusion_snd  by metis
    moreover have "wordinverse [x2] = [x1]"  by (metis append_self_conv2 assms(1) inverse_of_inverse wordinverse.simps(1) wordinverse.simps(2))
    ultimately have "genmap (\<iota> ` gens) 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> FreeGroupMain.spanset (gens ::('a, 'b) monoidgentype set)"
      and "y \<in> FreeGroupMain.spanset gens"
      and  "f \<in> (\<iota> ` gens) \<rightarrow> carrier G"
  shows "genmapext (\<iota> ` gens) f x = genmapext (\<iota> ` gens) 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> FreeGroupMain.spanset gens" using cancels_to_preserves  cancels_to_def rtrancl_into_rtrancl.prems(1) rtrancl_into_rtrancl.hyps(1)  by metis
  have c1:"c1 \<in> FreeGroupMain.spanset gens" using b bin  FreeGroupMain.spanset_def leftappend_span by blast
  moreover have fx1:"([x1] @ [x2] @ c2)\<in> FreeGroupMain.spanset gens" using b bin  FreeGroupMain.spanset_def rightappend_span by fastforce
  moreover then have x1:"[x1] \<in> FreeGroupMain.spanset gens" using fx1  FreeGroupMain.spanset_def leftappend_span by blast
  moreover  have fx2: "([x2] @ c2) \<in> FreeGroupMain.spanset gens" using fx1  FreeGroupMain.spanset_def rightappend_span by fastforce
  moreover then have x2:"[x2] \<in> FreeGroupMain.spanset gens" using  FreeGroupMain.spanset_def leftappend_span by blast
  moreover  have c2: "c2 \<in> FreeGroupMain.spanset gens" using fx2  FreeGroupMain.spanset_def rightappend_span by fastforce
  ultimately have 2: "genmapext (\<iota> ` gens) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` gens) f c1  \<otimes> (genmapext (\<iota> ` gens) f [x1] \<otimes> genmapext (\<iota> ` gens) f [x2]) \<otimes> genmapext (\<iota> ` gens) f c2" using genmapext_append rtrancl_refl.prems(3) by (smt (z3) genmapext_closed m_assoc m_closed)
  then have "genmapext (\<iota> ` gens) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` gens) f c1  \<otimes> \<one> \<otimes> genmapext (\<iota> ` gens) f c2" using inverse_ext i x1 x2 assms(4) by metis
  then have "genmapext (\<iota> ` gens) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` gens) f c1  \<otimes>  genmapext (\<iota> ` gens) f c2" using c1 c2 assms(4) genmapext_closed by (metis l_cancel_one' one_closed)
  then have "genmapext (\<iota> ` gens) f (c1 @ [x1] @ [x2] @ c2) = genmapext (\<iota> ` gens) f (c1@c2)" using genmapext_append c1 c2 assms(4) by metis
  then have "genmapext (\<iota> ` gens) f b = genmapext (\<iota> ` gens) f c" using b c by simp
  then show ?case using rtrancl_into_rtrancl by (simp add: bin)
qed

lemma (in group) genmapext_reln_set:
  assumes "(x,y) \<in> (reln_set (FreeGroupMain.spanset (gens ::('a, 'b) monoidgentype set)))"
      and "x \<in> FreeGroupMain.spanset gens"
      and "y \<in> FreeGroupMain.spanset gens"
      and  "f \<in> (\<iota> ` gens) \<rightarrow> carrier G"
  shows "genmapext (\<iota> ` gens) f x = genmapext (\<iota> ` gens) f y"
proof-
  let ?rx = "iter (length x) reduct x"
  let ?ry = "iter (length y) reduct y"
  have "cancels_to x ?rx" by (simp add: iter_cancels_to)
  moreover then have "?rx  \<in> FreeGroupMain.spanset gens" using assms cancels_to_preserves by blast
  ultimately have x:"genmapext (\<iota> ` gens) f x = genmapext (\<iota> ` gens) f ?rx"  using genmapext_cancels_to[of "x" "?rx" "gens" "f"] assms(2) assms(4) by auto
  have  "cancels_to y ?ry" by (simp add: iter_cancels_to)
  moreover then have ryg:"?ry  \<in> FreeGroupMain.spanset gens" using assms cancels_to_preserves by blast
  ultimately have y:"genmapext (\<iota> ` gens) f y = genmapext (\<iota> ` gens) f ?ry"  using genmapext_cancels_to[of "y" "?ry" "gens" "f"] assms(3) assms(4) by auto
  have "FreeGroupMain.reln x y" using assms(1) reln_set_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

(*
  then have 1:"(symclp cancels_to_1)^** x y" using  eq_symp sympstar by metis
  show ?thesis using 1 assms
  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
    proof(cases "cancels_to b c")
      case True
      then have b:"b \<in> FreeGroupMain.spanset gens" using rtrancl_into_rtrancl.prems(1)  reln_set_def  sledgehammer
      ultimately have "genmapext f c = genmapext f b"  using genmapext_cancels_to rtrancl_into_rtrancl.prems by blast
      moreover have "genmapext f a = genmapext f b" using b  genmapext_cancels_to rtrancl_into_rtrancl by blast
      ultimately show ?thesis by simp
    next
      case False
      then have "cancels_to c b" using rtrancl_into_rtrancl.hyps(3) cancels_to_1_def by (metis rtrancancel symclp_def)
      moreover then have b:"b \<in> FreeGroupMain.spanset gens" using cancels_to_preserves rtrancl_into_rtrancl.prems(2) by blast
      ultimately have "genmapext f c = genmapext f b"  using genmapext_cancels_to rtrancl_into_rtrancl.prems by blast
      moreover have "genmapext f a = genmapext f b" using b  genmapext_cancels_to rtrancl_into_rtrancl by blast
      ultimately show ?thesis by simp
    qed
next
  case False
  show ?thesis sorry
    qed
qed
qed *)

lemma (in group) congruentlift: assumes "f \<in> (\<iota> ` (S::('a,'b) monoidgentype set)) \<rightarrow> carrier G" shows "congruent (reln_set (FreeGroupMain.spanset S)) (genmapext (\<iota> ` S) f)"
  unfolding congruent_def
proof-
  have "(\<And>x y. (x, y) \<in> (reln_set \<langle>S\<rangle>) \<Longrightarrow> (genmapext (\<iota> ` S) f x) = (genmapext (\<iota> ` S) f y))"
  proof-
    fix x y assume assm: "(x, y) \<in> (reln_set \<langle>S\<rangle>)"
    moreover then have "x \<in> \<langle>S\<rangle>" using reln_set_def by auto
    moreover have "y \<in> \<langle>S\<rangle>" using reln_set_def assm  by auto
    ultimately show "(genmapext (\<iota> ` S) f x) = (genmapext (\<iota> ` S) f y)" using genmapext_reln_set assms by blast
  qed
  then show "\<forall>(y, z)\<in>reln_set \<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::('a,'b) monoidgentype set)\<rangle> (reln_set \<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_set \<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::('a,'b) monoidgentype set)\<rangle> (reln_set \<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::('a,'b) 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_set \<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_set \<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
  then have "genmapext_lift (\<iota> ` S) f x \<in> carrier G" using genmapext_closed  assms(1) xin by simp
}
  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_set \<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_set \<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_set \<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_set \<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 = lift_append \<langle>S\<rangle> (x) (y)" by (simp add: freegroup_def)
  then have "x \<otimes>\<^bsub>(freegroup S)\<^esub> y = lift_append \<langle>S\<rangle> ((reln_set \<langle>S\<rangle>)``{x1}) ((reln_set \<langle>S\<rangle>)``{y1})" using xx1 yy1 by simp
  then have 2:"x \<otimes>\<^bsub>(freegroup S)\<^esub> y = ((reln_set \<langle>S\<rangle>)``{x1@y1})" using lift_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_set \<langle>S\<rangle>)``{x1@y1})" by simp
  moreover  have "((reln_set \<langle>S\<rangle>)``{x1@y1}) \<in> quotient \<langle>S\<rangle> (reln_set \<langle>S\<rangle>)"  by (metis 1 2 lift_append_clos x2 y2)
  moreover have "(x1@y1) \<in> ((reln_set \<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_set \<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 presburger
}
  ultimately show ?thesis by (simp add: homI)
qed

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

lemma (in group) unlift_gens: assumes "f \<in> liftgen S \<rightarrow> carrier G"
  shows "unlift f S (liftgen S) \<in> (\<iota> ` (S::('a,'b) monoidgentype set)) \<rightarrow> carrier G"
proof(rule funcsetI)
  fix x assume assm:"x \<in> \<iota> ` S"
  have "(reln_set \<langle>S\<rangle> ``{x}) \<in> (\<Union>x \<in> (\<iota> ` (S::('a,'b) monoidgentype set)).{reln_set \<langle>S\<rangle> ``{x}} )" using assm by blast
  then have "f (reln_set \<langle>S\<rangle> ``{x}) \<in> carrier G" using assms Pi_split_insert_domain unfolding liftgen_def by fastforce
  moreover have "f (reln_set \<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::('a,'b) 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_gens)

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 spanset_def using empty gen by metis
qed

lemma liftgen_subset_quotient:"(liftgen S) \<subseteq> quotient \<langle>S\<rangle> (reln_set \<langle>S\<rangle>)"
proof(rule subsetI)
  fix x assume assms:"x \<in> liftgen S"
  then have "x \<in> (\<Union>x \<in> (\<iota> ` S).{reln_set \<langle>S\<rangle> ``{x}})" by (simp add: liftgen_def)
  then obtain x1 where "x = (reln_set \<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_set \<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::('a,'b) 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_set \<langle>S\<rangle>)" using liftgen_subset_quotient by auto
  have "x \<in> (\<Union>x \<in> (\<iota> ` S).{reln_set \<langle>S\<rangle> ``{x}})" using assm by (simp add: liftgen_def)
  then obtain x1 where x1x:"x = (reln_set \<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_set_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_gens)
  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_gens[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_set \<langle>S\<rangle>)" by (simp add: freegroup_def)
  moreover have "(liftgen S)  \<subseteq> quotient \<langle>S\<rangle> (reln_set \<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_set \<langle>S\<rangle>) `` {x1}"
  shows "inv\<^bsub>(freegroup S)\<^esub> x = (reln_set \<langle>S\<rangle>) `` {wordinverse x1}"
proof-
  have nil: "[] \<in> \<langle>S\<rangle>" using spanset_def group_spanset.empty by auto
  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>"  by (simp add: span_wordinverse)
  then have A:"(reln_set \<langle>S\<rangle>) `` {wordinverse x1} \<in> carrier (freegroup S)" unfolding freegroup_def by (simp add: quotientI)
  have "x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_set \<langle>S\<rangle>) `` {wordinverse x1} = (lift_append \<langle>S\<rangle>) ((reln_set \<langle>S\<rangle>) `` {x1}) ((reln_set \<langle>S\<rangle>) `` {wordinverse x1})" using assms  by (simp add: freegroup_def)
  then have "x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_set \<langle>S\<rangle>) `` {wordinverse x1} = ((reln_set \<langle>S\<rangle>) `` {x1@wordinverse x1})" using lift_append_wd by (simp add: lift_append_wd 1 2)
  moreover have "x1@(wordinverse x1) \<in> \<langle>S\<rangle>" using 1 2 span_append spanset_def by blast
  moreover then have "((x1@(wordinverse x1)), []) \<in> reln_set \<langle>S\<rangle>" using nil wordinverse_inverse reln_set_def by auto
  moreover then have "reln_set \<langle>S\<rangle> `` {x1@(wordinverse x1)} = reln_set \<langle>S\<rangle> `` {[]}" by (metis equiv_class_eq reln_equiv)
  ultimately have "x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_set \<langle>S\<rangle>) `` {wordinverse x1} = reln_set \<langle>S\<rangle> `` {[]}" by simp
  then have B:"x \<otimes>\<^bsub>(freegroup S)\<^esub> (reln_set \<langle>S\<rangle>) `` {wordinverse x1} = \<one>\<^bsub>(freegroup S)\<^esub>" by (simp add: freegroup_def)
  have " (reln_set \<langle>S\<rangle>) `` {wordinverse x1}  \<otimes>\<^bsub>(freegroup S)\<^esub> x = (lift_append \<langle>S\<rangle>) ((reln_set \<langle>S\<rangle>) `` {wordinverse x1}) ((reln_set \<langle>S\<rangle>) `` {x1})"  using assms  by (simp add: freegroup_def)
  then moreover have "lift_append \<langle>S\<rangle>  ((reln_set \<langle>S\<rangle>)``{wordinverse x1}) ((reln_set \<langle>S\<rangle>)``{x1}) = reln_set \<langle>S\<rangle> `` {(wordinverse x1)@x1}"  by (simp add: 1 2 lift_append_wd)
  moreover have "(wordinverse x1)@x1 \<in> \<langle>S\<rangle>" using 1 2 span_append spanset_def by blast
  moreover then have "(((wordinverse x1)@x1), []) \<in> reln_set \<langle>S\<rangle>" using nil inverse_wordinverse reln_set_def by auto
  moreover then have "reln_set \<langle>S\<rangle> `` {(wordinverse x1)@x1} = reln_set \<langle>S\<rangle> `` {[]}" by (metis equiv_class_eq reln_equiv)
  ultimately have C:"(reln_set \<langle>S\<rangle>) `` {wordinverse x1}  \<otimes>\<^bsub>(freegroup S)\<^esub> x = \<one>\<^bsub>(freegroup S)\<^esub>" by (simp add: freegroup_def)
  show ?thesis by (simp add: A C assms(1) freegroup_is_group group.inv_equality inv_unique r_inv)
qed

lemma inclusion_liftgen: assumes "x \<in> (\<iota> ` S)" shows "(reln_set \<langle>S\<rangle> `` {x}) \<in> liftgen S"
  using assms unfolding liftgen_def
proof-
  fix x assume "x \<in> \<iota> ` S"
  then show "reln_set \<langle>S\<rangle> `` {x} \<in> (\<Union>x\<in>\<iota> ` S. {reln_set \<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_set \<langle>S\<rangle>)" by (simp add: freegroup_def)
  then have x:"x \<in> quotient \<langle>S\<rangle> (reln_set \<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_set \<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_set \<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_set \<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  spanset_def by blast
  moreover have c1:"x1  \<in> \<langle>S\<rangle>" using Cons span_cons  spanset_def by blast
  ultimately have wd:"reln_set \<langle>S\<rangle> `` {a # x1} = (lift_append \<langle>S\<rangle>) (reln_set \<langle>S\<rangle> `` {[a]})  (reln_set \<langle>S\<rangle> `` {x1})"  by (simp add: lift_append_wd)
  have x1in:"reln_set \<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_set \<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 group_spanset.cases list.inject not_Cons_self2 spanset_def)
  then show ?case
  proof(cases "[a]  \<in> (\<iota> ` S)")
    case True
    then have "(reln_set \<langle>S\<rangle> `` {[a]}) \<in> liftgen S" by (simp add: inclusion_liftgen)
    then have "(reln_set \<langle>S\<rangle> `` {[a]}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>"  by (simp add: gen_span.gen_gens)
    then have "(lift_append \<langle>S\<rangle>) (reln_set \<langle>S\<rangle> `` {[a]})  (reln_set \<langle>S\<rangle> `` {x1}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>" using freegroup_def x1in gen_mult[of "(reln_set \<langle>S\<rangle> `` {[a]})" "freegroup S" "liftgen S" "(reln_set \<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_set \<langle>S\<rangle> `` {wordinverse [a]}) \<in> liftgen S" by (simp add: inclusion_liftgen)
  then have 1: "(reln_set \<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_set \<langle>S\<rangle> `` {wordinverse [a]}) = (reln_set \<langle>S\<rangle> `` { [a]})" using inva wordinverse_inv[of "(reln_set \<langle>S\<rangle> `` {wordinverse [a]})" "S" "wordinverse [a]"] by auto
  then have "(reln_set \<langle>S\<rangle> `` { [a]}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>" using 1  by (metis gen_span.gen_inv)
  then have "(lift_append \<langle>S\<rangle>) (reln_set \<langle>S\<rangle> `` {[a]})  (reln_set \<langle>S\<rangle> `` {x1}) \<in> \<langle>liftgen S\<rangle>\<^bsub>(freegroup S)\<^esub>" using freegroup_def x1in gen_mult[of "(reln_set \<langle>S\<rangle> `` {[a]})" "freegroup S" "liftgen S" "(reln_set \<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::('a,'b) 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 equiv_redelem:
  assumes "w \<in> (\<langle>S\<rangle> // (reln_set \<langle>S\<rangle>))"
  shows "\<exists>x \<in> w. reduced x \<and> ((reln_set \<langle>S\<rangle>)`` {x} = w)"
proof-
  obtain c where c: "w = (reln_set \<langle>S\<rangle>) `` {c}" by (meson assms quotientE)
  then have cs: "c \<in> \<langle>S\<rangle>" using assms by (metis proj_def proj_in_iff reln_equiv)
  obtain rc where rc: "rc = (iter (length c) reduct c)" by simp
  then have "reduced rc" by (simp add: reduced_iter_length)
  then have "c ~ rc" using rc cancels_imp_rel iter_cancels_to by auto
  moreover then have "rc \<in> \<langle>S\<rangle>" using cs rc using cancels_to_preserves iter_cancels_to by blast
  ultimately have crc: "(c, rc) \<in> reln_set \<langle>S\<rangle>" using cs reln_set_def by auto
  then have "((reln_set \<langle>S\<rangle>)`` {rc} = w)"using c by (smt (verit, ccfv_SIG) equiv_class_eq_iff reln_equiv)
  moreover then have "rc \<in> w" using c crc by simp
  ultimately show ?thesis using \<open>reduced rc\<close> by auto
qed

lemma redelem_unique :
  assumes "w \<in> (\<langle>S\<rangle> // (reln_set \<langle>S\<rangle>))"
  shows "\<exists>!x \<in> w. reduced x \<and> ((reln_set \<langle>S\<rangle>)`` {x} = w)"
proof(rule classical)
  assume 1:"\<not>(\<exists>!x \<in> w. reduced x \<and> ((reln_set \<langle>S\<rangle>)`` {x} = w))"
  have "\<exists>x \<in> w. reduced x \<and> ((reln_set \<langle>S\<rangle>)`` {x} = w)" using assms equiv_redelem by auto
  then obtain x where x:"x \<in> w \<and> reduced x" by auto
  obtain y where y:"(y \<in> w \<and> reduced y \<and> (reln_set \<langle>S\<rangle>)`` {x} = w) \<and> y \<noteq> x " using 1 x by (smt (verit, best) assms equiv_class_eq_iff equiv_class_self quotientE quotient_eq_iff reln_equiv)
  then have "(x, y) \<in> reln_set \<langle>S\<rangle>" using x y by blast
  then have "x ~ y" using reln_set_def by auto
  then have "y = x" using x y using 1 reduced_cancel_eq reln_imp_cancels by blast
  moreover then have "(reln_set \<langle>S\<rangle>)`` {x} = (reln_set \<langle>S\<rangle>)`` {y}" by simp
  ultimately have False by (simp add: y)
  then show "\<exists>!x \<in> w. reduced x \<and> ((reln_set \<langle>S\<rangle>)`` {x} = w)" by simp
qed

definition equiv_red :: "('a, 'b) monoidgentype set \<Rightarrow> ('a, 'b) word set \<Rightarrow> ('a, 'b) word"
  where "equiv_red S w = (THE x. x \<in> w \<and> reduced x \<and> (w = reln_set \<langle>S\<rangle> `` {x}))"

lemma equivred_equiv:
  assumes "w \<in> (\<langle>S\<rangle> // (reln_set \<langle>S\<rangle>))"
  shows "\<forall>x\<in>w. (reln_set \<langle>S\<rangle>) `` {x} = (reln_set \<langle>S\<rangle>) `` {equiv_red S w}"
proof-
  obtain x where x:"x \<in> w" using assms equiv_redelem by auto
  then have xs: "x \<in> \<langle>S\<rangle>" using append_congruent assms equiv_2f_clos reln_equiv rightappend_span spanset_def by fastforce
  have rw: "equiv_red S w \<in> w" using equiv_red_def redelem_unique by (metis (no_types, lifting) Uniq_I assms the1_equality')
  then have rs: "equiv_red S w \<in> \<langle>S\<rangle>" using assms by (meson quotient_eq_iff refl_onD1 reln_equiv reln_refl)
  then have "(x,equiv_red S w)\<in>(reln_set \<langle>S\<rangle>)" using xs x rs rw by (meson assms quotient_eq_iff reln_equiv)
  then have "(reln_set \<langle>S\<rangle>) `` {x} = (reln_set \<langle>S\<rangle>) `` {equiv_red S w}" by (meson equiv_class_eq_iff reln_equiv)
  then show ?thesis using x assms by (smt (verit, best)  equiv_class_eq_iff quotient_eq_iff reln_equiv)
qed

definition (in group) equivinv :: "('a, 'b) monoidgentype set \<Rightarrow> ('a, 'b) word set \<Rightarrow> ('a, 'b) word set"
  where "equivinv S w = (reln_set \<langle>S\<rangle> `` {wordinverse (equiv_red S w)})"

end


(*  Title:       CoreC++
    Author:      Tobias Nipkow, Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>
*)

section \<open>Definite assignment\<close>

theory DefAss
imports BigStep
begin

subsection \<open>Hypersets\<close>

type_synonym hyperset = "vname set option"

definition hyperUn :: "hyperset \<Rightarrow> hyperset \<Rightarrow> hyperset"   (infixl "\<squnion>" 65) where
  "A \<squnion> B  \<equiv>  case A of None \<Rightarrow> None
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> None | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<union> B\<rfloor>)"

definition hyperInt :: "hyperset \<Rightarrow> hyperset \<Rightarrow> hyperset"   (infixl "\<sqinter>" 70) where
  "A \<sqinter> B  \<equiv>  case A of None \<Rightarrow> B
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> \<lfloor>A\<rfloor> | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<inter> B\<rfloor>)"

definition hyperDiff1 :: "hyperset \<Rightarrow> vname \<Rightarrow> hyperset"   (infixl "\<ominus>" 65) where
  "A \<ominus> a  \<equiv>  case A of None \<Rightarrow> None | \<lfloor>A\<rfloor> \<Rightarrow> \<lfloor>A - {a}\<rfloor>"

definition hyper_isin :: "vname \<Rightarrow> hyperset \<Rightarrow> bool"   (infix "\<in>\<in>" 50) where
"a \<in>\<in> A  \<equiv>  case A of None \<Rightarrow> True | \<lfloor>A\<rfloor> \<Rightarrow> a \<in> A"

definition hyper_subset :: "hyperset \<Rightarrow> hyperset \<Rightarrow> bool"   (infix "\<sqsubseteq>" 50) where
  "A \<sqsubseteq> B  \<equiv>  case B of None \<Rightarrow> True
                 | \<lfloor>B\<rfloor> \<Rightarrow> (case A of None \<Rightarrow> False | \<lfloor>A\<rfloor> \<Rightarrow> A \<subseteq> B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "\<lfloor>A\<rfloor> \<squnion> \<lfloor>B\<rfloor> = \<lfloor>A \<union> B\<rfloor> \<and> \<lfloor>A\<rfloor> \<ominus> a = \<lfloor>A - {a}\<rfloor>"
by(simp add:hyperset_defs)

lemma [simp]: "None \<squnion> A = None \<and> A \<squnion> None = None"
by(simp add:hyperset_defs)

lemma [simp]: "a \<in>\<in> None \<and> None \<ominus> a = None"
by(simp add:hyperset_defs)

lemma hyperUn_assoc: "(A \<squnion> B) \<squnion> C = A \<squnion> (B \<squnion> C)"
by(simp add:hyperset_defs Un_assoc)

lemma hyper_insert_comm: "A \<squnion> \<lfloor>{a}\<rfloor> = \<lfloor>{a}\<rfloor> \<squnion> A \<and> A \<squnion> (\<lfloor>{a}\<rfloor> \<squnion> B) = \<lfloor>{a}\<rfloor> \<squnion> (A \<squnion> B)"
by(simp add:hyperset_defs)

subsection \<open>Definite assignment\<close>

primrec \ :: "expr \<Rightarrow> hyperset" and \s :: "expr list \<Rightarrow> hyperset" where
"\ (new C) = \<lfloor>{}\<rfloor>" |
"\ (Cast C e) = \ e" |
"\ (\<lparr>C\<rparr>e) = \ e" |
"\ (Val v) = \<lfloor>{}\<rfloor>" |
"\ (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2" |
"\ (Var V) = \<lfloor>{}\<rfloor>" |
"\ (LAss V e) = \<lfloor>{V}\<rfloor> \<squnion> \ e" |
"\ (e\<bullet>F{Cs}) = \ e" |
"\ (e\<^sub>1\<bullet>F{Cs}:=e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2" |
"\ (Call e Copt M es) = \ e \<squnion> \s es" |
"\ ({V:T; e}) = \ e \<ominus> V" |
"\ (e\<^sub>1;;e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2" |
"\ (if (e) e\<^sub>1 else e\<^sub>2) =  \ e \<squnion> (\ e\<^sub>1 \<sqinter> \ e\<^sub>2)" |
"\ (while (b) e) = \ b" |
"\ (throw e) = None" |

"\s ([]) = \<lfloor>{}\<rfloor>" |
"\s (e#es) = \ e \<squnion> \s es"

primrec \<D> :: "expr \<Rightarrow> hyperset \<Rightarrow> bool" and \<D>s :: "expr list \<Rightarrow> hyperset \<Rightarrow> bool" where
"\<D> (new C) A = True" |
"\<D> (Cast C e) A = \<D> e A" |
"\<D> (\<lparr>C\<rparr>e) A = \<D> e A" |
"\<D> (Val v) A = True" |
"\<D> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))" |
"\<D> (Var V) A = (V \<in>\<in> A)" |
"\<D> (LAss V e) A = \<D> e A" |
"\<D> (e\<bullet>F{Cs}) A = \<D> e A" |
"\<D> (e\<^sub>1\<bullet>F{Cs}:=e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))" |
"\<D> (Call e Copt M es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))" |
"\<D> ({V:T; e}) A = \<D> e (A \<ominus> V)" |
"\<D> (e\<^sub>1;;e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))" |
"\<D> (if (e) e\<^sub>1 else e\<^sub>2) A =
  (\<D> e A \<and> \<D> e\<^sub>1 (A \<squnion> \ e) \<and> \<D> e\<^sub>2 (A \<squnion> \ e))" |
"\<D> (while (e) c) A = (\<D> e A \<and> \<D> c (A \<squnion> \ e))" |
"\<D> (throw e) A = \<D> e A" |

"\<D>s ([]) A = True" |
"\<D>s (e#es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"

lemma As_map_Val[simp]: "\s (map Val vs) = \<lfloor>{}\<rfloor>"
by (induct vs) simp_all

lemma D_append[iff]: "\<And>A. \<D>s (es @ es') A = (\<D>s es A \<and> \<D>s es' (A \<squnion> \s es))"
by (induct es type:list) (auto simp:hyperUn_assoc)

lemma A_fv: "\<And>A. \ e = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fv e"
and  "\<And>A. \s es = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fvs es"

apply(induct e and es rule: \.induct \s.induct)
apply (simp_all add:hyperset_defs)
apply blast+
done

lemma sqUn_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<squnion> B \<sqsubseteq> A' \<squnion> B"
by(simp add:hyperset_defs) blast

lemma diff_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<ominus> b \<sqsubseteq> A' \<ominus> b"
by(simp add:hyperset_defs) blast

(* This order of the premises avoids looping of the simplifier *)
lemma D_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D> e A \<Longrightarrow> \<D> (e::expr) A'"
and Ds_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A \<Longrightarrow> \<D>s (es::expr list) A'"

apply(induct e and es rule: \<D>.induct \<D>s.induct)
apply simp
apply simp
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply (fastforce simp add:hyperset_defs)
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:diff_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp
apply simp
apply (iprover dest:sqUn_lem)
done

(* And this is the order of premises preferred during application: *)
lemma D_mono': "\<D> e A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D> e A'"
and Ds_mono': "\<D>s es A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A'"
by(blast intro:D_mono, blast intro:Ds_mono)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_NStoogeSort2IsSort
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function twoThirds :: "int => int" where
  "twoThirds y =
   (if (y = 2) then 1 else
      (if (y = 1) then 1 else
         (if (y = 0) then 0 else 2 + (twoThirds (y - 3)))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun insert :: "int => int list => int list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if y <= z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "int list => int list"
  and nstoogesort2 :: "int list => int list"
  and nstooge2sort1 :: "int list => int list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "((nstoogesort2 xs) = (isort xs))"
  oops

end


theory relaxedprefix_is_prefix_4
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype It = A | B | C

fun eq :: "It => It => bool" where
"eq (A) y =
   case y of
     | other => False
     | A => True
   end"
| "eq (B) y =
     case y of
       | other => False
       | B => True
     end"
| "eq (C) y =
     case y of
       | other => False
       | C => True
     end"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (Nil2) y = True"
| "isPrefix (Cons2 z x2) (Nil2) = False"
| "isPrefix (Cons2 z x2) (Cons2 x3 x4) =
     (if eq z x3 then isPrefix x2 x4 else False)"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (Nil2) y = True"
| "isRelaxedPrefix (Cons2 z (Nil2)) y = True"
| "isRelaxedPrefix (Cons2 z (Cons2 x3 x4)) (Nil2) = False"
| "isRelaxedPrefix (Cons2 z (Cons2 x3 x4)) (Cons2 x5 x6) =
     (if eq z x5 then isRelaxedPrefix (Cons2 x3 x4) x6 else
        isPrefix (Cons2 x3 x4) (Cons2 x5 x6))"

fun append :: "It list => It list => It list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

(*hipster eq isPrefix isRelaxedPrefix append *)

theorem x0 :
  "!! (x :: It) (xs :: It list) (ys :: It list) .
     isRelaxedPrefix (Cons2 x xs) (append xs ys)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory BDD_uniqueness
  imports Main BDD_basic
begin

inductive distinguisher:: "BDD \<Rightarrow> BDD \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
  dist_n_t [simp, intro]: "distinguisher Nothing Top f" |
  dist_n_st [simp, intro]: "f v \<Longrightarrow> distinguisher Nothing t f \<Longrightarrow> distinguisher Nothing (Select v t e) f" |
  dist_n_se [simp, intro]: "~f v \<Longrightarrow> distinguisher Nothing e f \<Longrightarrow> distinguisher Nothing (Select v t e) f" |
  dist_t_n [simp, intro]: "distinguisher Top Nothing f" |
  dist_t_st [simp, intro]: "f v \<Longrightarrow> distinguisher Top t f \<Longrightarrow> distinguisher Top (Select v t e) f" |
  dist_t_se [simp, intro]: "~f v \<Longrightarrow> distinguisher Top e f \<Longrightarrow> distinguisher Top (Select v t e) f" |
  dist_s_nt [simp, intro]: "f v \<Longrightarrow> distinguisher t Nothing f \<Longrightarrow> distinguisher (Select v t e) Nothing f" |
  dist_s_ne [simp, intro]: "~f v \<Longrightarrow> distinguisher e Nothing f \<Longrightarrow> distinguisher (Select v t e) Nothing f" |
  dist_s_tt [simp, intro]: "f v \<Longrightarrow> distinguisher t Top f \<Longrightarrow> distinguisher (Select v t e) Top f" |
  dist_s_te [simp, intro]: "~f v \<Longrightarrow> distinguisher e Top f \<Longrightarrow> distinguisher (Select v t e) Top f" |
  dist_s_sgt: "va > vb \<Longrightarrow> f va \<Longrightarrow> distinguisher ta (Select vb tb eb) f \<Longrightarrow> distinguisher (Select va ta ea) (Select vb tb eb) f" |
  dist_s_sge: "va > vb \<Longrightarrow> ~f va \<Longrightarrow> distinguisher ea (Select vb tb eb) f \<Longrightarrow> distinguisher (Select va ta ea) (Select vb tb eb) f" |
  dist_s_slt: "vb > va \<Longrightarrow> f vb \<Longrightarrow> distinguisher (Select va ta ea) tb f \<Longrightarrow> distinguisher (Select va ta ea) (Select vb tb eb) f" |
  dist_s_sle: "vb > va \<Longrightarrow> ~f vb \<Longrightarrow> distinguisher (Select va ta ea) eb f \<Longrightarrow> distinguisher (Select va ta ea) (Select vb tb eb) f" |
  dist_s_set: "f v \<Longrightarrow> distinguisher ta tb f \<Longrightarrow> distinguisher (Select v ta ea) (Select v tb eb) f" |
  dist_s_see: "~f v \<Longrightarrow> distinguisher ea eb f \<Longrightarrow> distinguisher (Select v ta ea) (Select v tb eb) f"

(* TODO: dist_s_s, dist t_s, dist n_s, dist s_t, dist n_t proof fixtures *)

definition join_dist :: "nat \<Rightarrow> (nat \<Rightarrow> bool) option \<Rightarrow> (nat \<Rightarrow> bool) option \<Rightarrow> (nat \<Rightarrow> bool) option" where
  "join_dist v t e = (case t of
     Some(f) \<Rightarrow> Some(replace f v True) |
     None \<Rightarrow> e)"

fun distinguish :: "BDD \<Rightarrow> BDD \<Rightarrow> (nat \<Rightarrow> bool) option" where
  "distinguish (Select va ta ea) (Select vb tb eb) =
     (if va > vb
      then join_dist va (distinguish ta (Select vb tb eb)) (distinguish ea (Select vb tb eb))
      else if va = vb
      then join_dist va (distinguish ta tb) (distinguish ea eb)
      else join_dist vb (distinguish (Select va ta ea) tb) (distinguish (Select va ta ea) eb))" |
  "distinguish Nothing Top = Some (\<lambda>x. False)" |
  "distinguish Top Nothing = Some (\<lambda>x. False)" |
  "distinguish Nothing Nothing = None" |
  "distinguish Top Top = None" |
  "distinguish Nothing (Select vb tb eb) = join_dist vb (distinguish Nothing tb) (distinguish Nothing eb)" |
  "distinguish Top (Select vb tb eb) = join_dist vb (distinguish Top tb) (distinguish Top eb)" |
  "distinguish (Select va ta ea) Nothing = join_dist va (distinguish ta Nothing) (distinguish ea Nothing)" |
  "distinguish (Select va ta ea) Top = join_dist va (distinguish ta Top) (distinguish ea Top)"

(* TODO: Similar fixtures here, probably one for join_dist. *)
lemma join_dist_none [simp]: "(join_dist v mt me = None) = (mt = None \<and> me = None)"
  by (simp add: join_dist_def option.case_eq_if)

lemma join_dist_some [simp]:
  "(join_dist v mt me = Some f) =
   ((\<exists>g. mt = Some g \<and> f = replace g v True) \<or> (mt = None \<and> me = Some f))"
  by (auto simp add: join_dist_def option.case_eq_if)

theorem dist_contains: "distinguisher a b f \<Longrightarrow> contains a f \<noteq> contains b f"
  apply (induction a b f rule: distinguisher.induct)
  by (simp_all add: contains_p_correct)

lemma dist_symm: "distinguisher a b f \<Longrightarrow> distinguisher b a f"
  apply (induction a b f rule: distinguisher.induct)
  using distinguisher.intros by simp_all

lemma noncontains_dist_top [simp]: "\<not>contains b f \<Longrightarrow> distinguisher Top b f"
  apply (induction b)
  apply auto
  apply (case_tac "f x1")
  apply (meson contains_sel_t dist_t_st)
  apply (metis contains_sel_e dist_t_se)
  done

lemma contains_dist_nothing [simp]: "contains b f \<Longrightarrow> distinguisher Nothing b f"
  apply (induction b f rule: contains.induct)
  by auto

lemma contains_dist0: "contains a f \<Longrightarrow> \<not>contains b f \<Longrightarrow> distinguisher a b f"
  apply (induction a b rule: distinguish.induct)
  apply simp_all
  apply (case_tac "vb < va")
  apply auto[1]
  apply (case_tac "f va")
  apply (simp add: contains_p_correct dist_s_sgt)
  apply (simp add: contains_p_correct dist_s_sge)
  apply auto[1]
  apply (case_tac "vb = va")
  apply auto[1]
  apply (case_tac "f va")
  apply (simp add: contains_p_correct dist_s_set)
  apply (simp add: contains_p_correct dist_s_see)
  apply (subgoal_tac "va < vb")
  apply auto[2]
  apply (case_tac "f vb")
  apply (simp add: contains_p_correct dist_s_slt)
  apply (simp add: contains_p_correct dist_s_sle)
  using contains_dist_nothing dist_symm apply blast
  done

theorem contains_dist: "contains a f \<noteq> contains b f \<Longrightarrow> distinguisher a b f"
  by (meson contains_dist0 dist_symm)

theorem dister_correct: "distinguisher a b f = (contains a f \<noteq> contains b f)"
  using contains_dist dist_contains by blast

theorem norm_dist: "(\<forall>f. ~distinguisher a b f) = (\<forall>f. contains a f = contains b f)"
  using dister_correct by blast

theorem dist_comm0: "distinguish a b = r \<Longrightarrow> distinguish b a = r"
  apply (induction arbitrary: r rule: distinguish.induct)
  apply (auto simp add: split: option.split)
  done

lemma dist_comm: "distinguish a b = distinguish b a"
  using dist_comm0 by blast

theorem dist_none_equiv0: "distinguish a b = None \<Longrightarrow> contains a f \<Longrightarrow> contains b f"
  apply (induction arbitrary: f rule: distinguish.induct)
  apply (auto simp add: split: option.split)
  apply (metis contains_p.simps(3) contains_p_correct join_dist_none)
  apply (auto simp add: contains_p_correct)
  by presburger

theorem dist_none_dister: "distinguish a b = None \<Longrightarrow> ~distinguisher a b f"
  by (metis dist_comm0 dist_none_equiv0 norm_dist)

lemma dist_ord_false: "ordered n a \<Longrightarrow> ordered n b \<Longrightarrow> (distinguish a b = Some(f)) \<Longrightarrow> ~f n"
  apply (induction arbitrary: n f rule: distinguish.induct)
  apply (auto simp add: split: option.split)
  apply (case_tac "vb < va")
  apply auto[2]
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject nat_neq_iff ordered.cases ordered_widen)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_widen)
  apply (case_tac "vb = va")
  apply simp
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject less_not_refl ordered.cases ordered_widen)
  apply simp
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject leD order_refl ordered.cases ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) nat_neq_iff ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) nat_neq_iff ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) nat_neq_iff ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) nat_neq_iff ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  done

lemma dist_nothing_correct: "ordered n a \<Longrightarrow> (distinguish Nothing a = Some(f)) \<Longrightarrow> contains a f"
  apply (induction a arbitrary: n f)
  apply auto
  apply (rule contains_sel_t)
  apply simp
  apply (subst ordered_contains_ignore_t)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.cases)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.cases)
  apply (rule contains_sel_e)
  apply (rule dist_ord_false[of _ Nothing])
  apply (rule ordered_nothing)
  prefer 2
  apply assumption
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.cases)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.cases)
  done

lemma dist_top_correct: "\<lbrakk>ordered n a; distinguish Top a = Some(f)\<rbrakk> \<Longrightarrow> \<not>contains a f"
  apply (induction a arbitrary: n f)
  apply simp_all
  apply (subst contains_p_correct)
  apply simp
  apply (subgoal_tac "\<forall>a. contains_p a f = contains a f")
  defer
  using contains_p_correct apply presburger
  apply auto
  apply (subgoal_tac "contains a1 g")
  apply (subgoal_tac "ordered n a1")
  apply auto[1]
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) dist_ord_false ordered.simps)
  by (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps)

theorem dist_correct: "ordered n a \<Longrightarrow> ordered n b \<Longrightarrow> (distinguish a b = Some(f)) \<Longrightarrow> (contains a f \<noteq> contains b f)"
  apply (induction arbitrary: n f rule: distinguish.induct)
  apply simp_all
  defer
  apply (rule dist_nothing_correct)
  apply auto[2]
  apply (rule dist_top_correct)
  apply assumption
  apply simp
  apply (rule dist_nothing_correct)
  apply assumption
  apply (subst dist_comm)
  apply auto[1]
  apply (rule dist_top_correct)
  apply assumption
  apply (subst dist_comm)
  apply auto[1]
  apply (case_tac "vb < va")
  apply auto[1]
  defer
  apply (rule contains_sel_t)
  apply simp
  apply (subst ordered_contains_ignore_t)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases)
  apply (subgoal_tac "\<not>contains (Select vb tb eb) g")
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t ordered_sel)
  defer
  apply (rule contains_sel_e)
  apply (rule dist_ord_false)
  prefer 3
  apply assumption
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps)
  apply (metis BDD.inject ordered.simps)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps)
  apply (case_tac "va = vb")
  apply auto[1]
  defer
  apply (rule contains_sel_t)
  apply simp
  apply (subst ordered_contains_ignore_t)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases)
  apply (subgoal_tac "\<not>contains tb g")
  apply (subgoal_tac "ordered n ta")
  apply (subgoal_tac "ordered n tb")
  apply auto[1]
  apply simp_all
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_widen)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_widen)
  apply (subgoal_tac "contains tb g = contains tb (replace g vb True)")
  using contains_sel_t apply auto[1]
  apply metis
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t)
  defer
  apply (rule contains_sel_e)
  apply (rule dist_ord_false)
  prefer 3
  apply assumption
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) contains.simps dist_ord_false ordered.simps)
  apply (subgoal_tac "va < vb")
  apply simp_all
  apply auto[1]
  defer
  apply (subst ordered_contains_ignore_t)
  apply (metis BDD.inject ordered.simps)
  apply (subgoal_tac "\<not>contains tb g")
  apply (subgoal_tac "ordered n ta")
  apply (subgoal_tac "ordered n tb")
  apply auto[1]
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_widen)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_widen)
  apply (subgoal_tac "contains tb g = contains tb (replace g vb True)")
  using contains_sel_t apply auto[1]
  apply metis
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t)
  defer
  apply (metis BDD.inject BDD.simps(5) contains.simps dist_ord_false ordered.simps)
  (* contains \<Longrightarrow> contains \<Longrightarrow> False va then *)
  apply (subgoal_tac "contains ta g")
  apply (subgoal_tac "ordered n ta")
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t ordered_sel)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  apply (subgoal_tac "contains ta g = contains ta (replace g va True)")
  apply (erule ssubst)
  apply (erule ssubst)
  apply (metis (mono_tags, lifting) contains_p.simps(3) contains_p_correct)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t)
  (* va else *)
  apply (subgoal_tac "contains ea f")
  apply (subgoal_tac "ordered n ea")
  apply (metis)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) contains_p.simps(3) contains_p_correct dist_ord_false ordered.simps)
  (* = then *)
  apply (subgoal_tac "contains tb g")
  apply (subgoal_tac "ordered n ta")
  apply (subgoal_tac "ordered n tb")
  apply (metis (mono_tags) BDD.distinct(3) BDD.distinct(5) BDD.inject contains_p.simps(3) contains_p_correct ordered.cases ordered_contains_ignore_t)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_widen)
  apply (subgoal_tac "contains tb g = contains tb (replace g vb True)")
  apply (erule ssubst)
  apply (erule ssubst)
  apply (simp add: contains_p_correct)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t)
  (* = else *)
  apply (subgoal_tac "contains eb f")
  apply (subgoal_tac "ordered n eb")
  apply (subgoal_tac "ordered n ea")
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject contains.simps dist_ord_false ordered.cases)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps ordered_widen)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_widen)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject contains.simps dist_ord_false ordered.cases)
  (* vb then *)
  apply (subgoal_tac "contains (Select va ta ea) g")
  apply (subgoal_tac "ordered vb (Select va ta ea)")
  apply (subgoal_tac "ordered vb tb")
  apply (metis (mono_tags) contains_top dist_t_st dister_correct ordered_contains_ignore_t)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps)
  apply (subgoal_tac "contains (Select va ta ea) g = contains (Select va ta ea) (replace g vb True)")
  apply (erule ssubst)
  apply (erule ssubst)
  apply assumption
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject ordered.cases ordered_contains_ignore_t ordered_sel)
  (* vb else *)
  apply (subgoal_tac "contains (Select va ta ea) f")
  apply (subgoal_tac "ordered vb (Select va ta ea)")
  apply (subgoal_tac "ordered vb eb")
  apply (metis contains_p.simps(3) contains_p_correct dist_ord_false)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) ordered.simps)
  apply (metis BDD.inject ordered.simps)
  apply (metis)
  done

lemma dist_some_nothing_complete: "contains b f \<Longrightarrow> \<exists>g. distinguish Nothing b = Some g"
  apply (induction b arbitrary: f)
  apply simp_all
  apply (case_tac "f x1")
  apply (subgoal_tac "\<exists>g. distinguish Nothing b1 = Some g")
  apply auto[1]
  apply (simp add: contains_p_correct)
  apply (case_tac "distinguish Nothing b1")
  apply (subgoal_tac "\<exists>g. distinguish Nothing b2 = Some g")
  apply auto[1]
  apply (simp add: contains_p_correct)
  apply auto[1]
  done

lemma dist_some_top_complete: "~contains b f \<Longrightarrow> \<exists>g. distinguish Top b = Some g"
  apply (induction b arbitrary: f)
  apply simp_all
  apply (case_tac "f x1")
  apply (subgoal_tac "\<exists>g. distinguish Top b1 = Some g")
  apply auto[1]
  apply (simp add: contains_p_correct)
  apply (case_tac "distinguish Top b1")
  apply (subgoal_tac "\<exists>g. distinguish Top b2 = Some g")
  apply auto[1]
  apply (simp add: contains_p_correct)
  apply auto[1]
  done

theorem dist_some_complete0: "contains a f \<Longrightarrow> ~contains b f \<Longrightarrow> \<exists>g. distinguish a b = Some(g)"
  apply (induction a b arbitrary: f rule: distinguish.induct)
  prefer 7
  apply (rule dist_some_top_complete)
  apply assumption
  prefer 7
  apply (subst dist_comm)
  apply (rule dist_some_nothing_complete)
  apply assumption
  apply simp_all
  (* Select / Select *)
  (* = *)
  apply (case_tac "va = vb")
  apply simp_all
  apply (case_tac "f vb")
  (* f vb *)
  apply (subgoal_tac "\<exists>g. distinguish ta tb = Some g")
  apply auto[1]
  apply (simp add: contains_p_correct)
  (* ~f vb *)
  apply (case_tac "distinguish ta tb")
  (* ta tb indistinguishable *)
  apply (subgoal_tac "contains ea f")
  apply (subgoal_tac "\<not>contains eb f")
  apply auto[1]
  apply (meson contains_sel)
  apply (simp add: contains_p_correct)
  (* ta tb distinguishable *)
  apply auto[1]
  (* < *)
  apply (case_tac "vb < va")
  apply simp_all
  apply (case_tac "f va")
  (* f va *)
  apply (subgoal_tac "\<exists>g. distinguish ta (Select vb tb eb) = Some g")
  apply auto[1]
  apply (simp add: contains_p_correct)
  (* ~f va *)
  apply (case_tac "distinguish ta (Select vb tb eb)")
  (* indist *)
  apply (subgoal_tac "contains ea f")
  apply auto[1]
  apply (simp add: contains_p_correct)
  (* dist *)
  apply auto[1]
  (* > *)
  apply (case_tac "f vb")
  (* f vb *)
  apply (subgoal_tac "\<exists>g. distinguish (Select va ta ea) tb = Some g")
  apply auto[1]
  apply (simp add: contains_p_correct)
  (* ~f vb *)
  apply (case_tac "distinguish (Select va ta ea) tb")
  (* indist *)
  apply (subgoal_tac "\<not>contains eb f")
  apply auto[1]
  apply (meson contains_sel)
  (* dist *)
  apply auto[1]
  done

theorem dist_some_complete: "(contains a f \<noteq> contains b f) \<Longrightarrow> \<exists>g. distinguish a b = Some(g)"
  by (metis dist_comm dist_some_complete0)

lemma equiv_dist_none: "ordered n a \<Longrightarrow> ordered n b \<Longrightarrow> (\<forall>f. contains a f = contains b f) = (distinguish a b = None)"
  by (meson contains_dist dist_correct dist_none_dister option.exhaust)

lemma dist_none_nothing: "\<lbrakk>norm n b; distinguish Nothing b = None\<rbrakk> \<Longrightarrow> b = Nothing"
  apply (induction b arbitrary: n)
  apply auto
  by (metis BDD.inject BDD.simps(5) BDD.simps(7) norm.cases)

lemma dist_none_top: "\<lbrakk>norm n b; distinguish Top b = None\<rbrakk> \<Longrightarrow> b = Top"
  using norm_top contains_top dist_none_equiv0 by presburger

lemma dist_none_unique: "\<lbrakk>norm n a; norm n b; distinguish a b = None\<rbrakk> \<Longrightarrow> a = b"
  apply (induction a b arbitrary: n rule: distinguish.induct)
  defer
  apply simp
  apply simp
  apply simp
  apply simp
  apply simp
  apply (metis BDD.simps(5) dist_none_nothing distinguish.simps(6) join_dist_none)
  apply (metis dist_none_top)
  apply (metis dist_comm dist_none_nothing)
  apply (metis dist_comm dist_none_top)
  apply (insert norm_ord)
  (* vb < va *)
  apply (case_tac "vb < va")
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) distinguish.simps(1) join_dist_none norm.simps)
  (* vb = va *)
  apply (case_tac "vb = va")
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) distinguish.simps(1) join_dist_none norm.simps)
  (* vb > va *)
  apply (metis BDD.distinct(6) BDD.inject BDD.simps(5) distinguish.simps(1) join_dist_none norm.cases norm_widen)
  done

theorem dup_free_unique: "\<lbrakk>norm n a; norm n b\<rbrakk> \<Longrightarrow> (\<forall>f. contains a f = contains b f) = (a = b)"
  by (meson dist_none_unique equiv_dist_none norm_ord)

end


(*X. Parent, 25/08/2019  *)
(*This file introduces David Lewis DDL and studies its
relationship with the Aqvist-Hansson DDL  *)
(*This uses material from my chapter for the second volume of the
handbook of deontic logic  *)

theory Lewis  imports Main  "HOL-Library.Rewrite"
begin
typedecl i \<comment>\<open>type for possible worlds\<close>
type_synonym \<tau> = "(i\<Rightarrow>bool)"
consts  aw::i \<comment>\<open>actual world\<close>

abbreviation(input) mtrue  :: "\<tau>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation(input) mfalse :: "\<tau>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation(input) mnot   :: "\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation(input) mand   :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation(input) mor    :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation(input) mimp   :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation(input) mequ   :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

abbreviation(input) mbox :: "\<tau>\<Rightarrow>\<tau>" ("\<box>") where "\<box>\<phi> \<equiv> \<lambda>w.  \<forall>v. \<phi>(v)"
definition ddediomond  :: "\<tau>\<Rightarrow>\<tau>" ("\<diamond>") where "\<diamond>\<phi> \<equiv> \<lambda>w. \<exists>v. \<phi>(v)"

consts r :: "i\<Rightarrow>\<tau>"  (infixr "r" 70)
 \<comment>\<open>the betterness relation r, used in definition of \<circle><_|_>  \<close>
abbreviation(input) mopt  :: "\<tau>\<Rightarrow>\<tau>" ("opt<_>")
  where "opt<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)  \<longrightarrow>  v r x) )) )"
abbreviation(input) msubset :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

(*David Lewis's evaluation rule for the conditional *)
abbreviation(input) mcond  :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv> (\<lambda>v. (\<not>(\<exists>x. (\<phi>)(x))\<or>  (\<exists>x. ((\<phi>)(x)\<and>(\<psi>)(x) \<and> (\<forall>y. ((y r x) \<longrightarrow> (\<phi>)(y)\<longrightarrow>(\<psi>)(y)))))))"
definition ddeperm :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("P<_|_>")
  where "P<\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>>"

(*Hansson-Aqvist's evaluation rule for the conditional *)
abbreviation(input) mcond2  :: "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<circle>o<_|_>")
  where "\<circle>o<\<psi>|\<phi>> \<equiv> (\<lambda>v. opt<\<phi>> \<^bold>\<subseteq> \<psi>)"

abbreviation(input) uncobl :: "\<tau>\<Rightarrow>\<tau>" ("\<circle><_>")
  where \<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>

abbreviation limitedness  where "limitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
abbreviation transitivity where "transitivity \<equiv> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z)"
abbreviation totalness where "totalness \<equiv> (\<forall>x y. (x r y \<or> y r x))"
abbreviation reflexivity where "reflexivity \<equiv> (\<forall>x. (x r x))"

abbreviation(input) valid :: "\<tau>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
definition cjactual :: "\<tau>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy, user_axioms, show_all, expect=genuine] oops

(*relation with optimality*)
(*The lewis rule is stronger*)

lemma "\<lfloor>\<circle>o<\<psi>|\<phi>>\<^bold>\<rightarrow>\<circle><\<psi>|\<phi>>\<rfloor>"
  nitpick oops

lemma "\<lfloor>\<circle><\<psi>|\<phi>>\<^bold>\<rightarrow>\<circle>o<\<psi>|\<phi>>\<rfloor>"
  sledgehammer oops

lemma
assumes "limitedness"
  assumes "transitivity"
  shows "\<lfloor>\<circle>o<\<psi>|\<phi>>\<^bold>\<rightarrow>\<circle><\<psi>|\<phi>>\<rfloor>"
  sledgehammer oops

(*axioms of E holding irrespective of the properties of r*)

lemma Abs:"\<lfloor>\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> \<box>\<circle><\<psi>|\<phi>>\<rfloor>" sledgehammer oops

lemma Nec:"\<lfloor>\<box>\<psi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>>\<rfloor>" sledgehammer oops

lemma Ext:"\<lfloor>\<box>(\<phi>\<^sub>1\<^bold>\<leftrightarrow>\<phi>\<^sub>2) \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>\<^sub>1> \<^bold>\<leftrightarrow> \<circle><\<psi>|\<phi>\<^sub>2>)\<rfloor>"
  sledgehammer oops

lemma Id:"\<lfloor>\<circle><\<phi>|\<phi>>\<rfloor>" sledgehammer oops

lemma Sh:"\<lfloor>\<circle><\<psi>|\<phi>\<^sub>1\<^bold>\<and>\<phi>\<^sub>2> \<^bold>\<rightarrow> \<circle><(\<phi>\<^sub>2\<^bold>\<rightarrow>\<psi>)|\<phi>\<^sub>1>\<rfloor>" sledgehammer oops

lemma MP:"(\<lfloor>\<phi>\<rfloor>\<and>\<lfloor>\<phi>\<^bold>\<rightarrow>\<psi>\<rfloor>)\<Longrightarrow>\<lfloor>\<psi>\<rfloor>" sledgehammer oops

lemma N:"\<lfloor>\<phi>\<rfloor>\<Longrightarrow>\<lfloor>\<box>\<phi>\<rfloor>" sledgehammer oops

(*axioms of E holding if r transitive and totale*)

lemma COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" nitpick oops

lemma
  assumes "transitivity"
  shows COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" nitpick oops

  lemma
  assumes "totalness"
  shows COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" nitpick oops

lemma
  assumes "transitivity"
  assumes "totalness"
  shows COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" sledgehammer oops

lemma D : "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"  nitpick oops

lemma
 assumes "totalness"
  shows D : "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"  sledgehammer oops

lemma  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>" nitpick

lemma
 assumes "transitivity"
shows Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>" sledgehammer oops

lemma CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>" nitpick oops

lemma
  assumes "transitivity"
  shows CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>" nitpick oops

lemma
  assumes "transitivity"
  assumes "totalness"
  shows CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>" sledgehammer oops

lemma SA:"\<lfloor>\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow>  \<circle><\<psi>|\<phi>\<^bold>\<and>\<chi>>\<rfloor>" nitpick oops
end


section \<open>An Existing FLPSystem\<close>

theory FLPExistingSystem
imports FLPTheorem
begin

text \<open>
  We define an example FLPSystem with some example execution to show that the
  locales employed are not void. (If they were, the consensus impossibility
  result would be trivial.)
\<close>

subsection \<open>System definition\<close>

datatype proc = p0 | p1
datatype state = s0 | s1
datatype val = v0 | v1

primrec trans :: "proc \<Rightarrow> state \<Rightarrow> val messageValue \<Rightarrow> state"
where
  "trans p s0 v = s1"
| "trans p s1 v = s0"

primrec sends ::
  "proc \<Rightarrow> state \<Rightarrow> val messageValue \<Rightarrow> (proc, val) message multiset"
where
  "sends p s0 v = {# <p0, v1> }"
| "sends p s1 v = {# <p1, v0> }"

definition start :: "proc \<Rightarrow> state"
where "start p  \<equiv> s0"

\<comment> \<open>An example execution\<close>
definition exec ::
  "(proc, val, state ) configuration list"
where
  exec_def: "exec \<equiv> [ \<lparr>
    states = (\<lambda>p. s0),
    msgs = ({# <p0, inM True> } \<union># {# <p1, inM True> }) \<rparr> ]"

lemma ProcUniv: "(UNIV :: proc set) = {p0, p1}"
  by (metis UNIV_eq_I insert_iff proc.exhaust)

subsection \<open>Interpretation as FLP Locale\<close>

interpretation FLPSys: flpSystem trans sends start
proof
  \<comment> \<open>finiteProcs\<close>
  show "finite (UNIV :: proc set)"
    unfolding ProcUniv by simp
next
  \<comment> \<open>minimalProcs\<close>
  have "card (UNIV :: proc set) = 2"
    unfolding ProcUniv by simp
  thus "2 \<le> card (UNIV :: proc set)" by simp
next
  \<comment> \<open>finiteSends\<close>
  fix p s m
  have FinExplSends: "finite {<p0, v1>, <p1, v0>}" by auto
  have "{v. 0 < sends p s m v} \<subseteq> {<p0, v1>, <p1, v0>}"
  proof auto
    fix x
    assume "x \<noteq> <p0, v1>" "0 < sends p s m x"
    thus "x = <p1, v0>"
      by (metis (full_types) neq0_conv sends.simps(1,2) state.exhaust)
  qed
  thus "finite {v. 0 < sends p s m v}"
    using FinExplSends finite_subset by blast
next
  \<comment> \<open>noInSends\<close>
  fix p s m p2 v
  show "sends p s m <p2, inM v> = 0" by (induct s, auto)
qed

interpretation FLPExec: execution trans sends start exec "[]"
proof
  \<comment> \<open>notEmpty\<close>
  show "1 \<le> length exec"
    by (simp add:exec_def)
next
  \<comment> \<open>length\<close>
  show "length exec - 1 = length []"
    by (simp add:exec_def)
next
  \<comment> \<open>base\<close>
  show "asynchronousSystem.initial start (hd exec)"
    unfolding asynchronousSystem.initial_def isReceiverOf_def
    by (auto simp add: start_def exec_def, metis proc.exhaust)
next
  \<comment> \<open>step\<close>
  fix i cfg1 cfg2
  assume "i < length exec - 1"
  hence "False" by (simp add:exec_def)
  thus "asynchronousSystem.steps FLPExistingSystem.trans sends cfg1 ([] ! i) cfg2"
    by rule
qed

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QEdlo_ex imports QEdlo
begin

(* tweaking the reflection setup *)

definition "interpret" :: "atom fm \<Rightarrow> 'a::dlo list \<Rightarrow> bool" where
"interpret = Logic.interpret I\<^sub>d\<^sub>l\<^sub>o"

lemma interpret_Atoms:
  "interpret (Atom (Eq i j)) xs = (xs!i = xs!j)"
  "interpret (Atom (Less i j)) xs = (xs!i < xs!j)"
by(simp_all add:interpret_def)

lemma interpret_others:
  "interpret (Neg(ExQ (Neg f))) xs = (\<forall>x. interpret f (x#xs))"
  "interpret (Or (Neg f1) f2) xs = (interpret f1 xs \<longrightarrow> interpret f2 xs)"
by(simp_all add:interpret_def)

lemmas reify_eqs =
  Logic.interpret.simps(1,2,4-7)[of I\<^sub>d\<^sub>l\<^sub>o, folded interpret_def]
  interpret_others interpret_Atoms

method_setup dlo_reify = {*
  Scan.succeed
  (fn ctxt =>
    Method.SIMPLE_METHOD' (Reification.tac ctxt @{thms reify_eqs} NONE
     THEN' simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm"interpret_def"}])))
*} "dlo reification"

(* leave just enough equations in to convert back to True/False by eval *)
declare I\<^sub>d\<^sub>l\<^sub>o.simps(1)[code]
declare Logic.interpret.simps[code del]
declare Logic.interpret.simps(1-2)[code]

subsection{* Examples *}

lemma "\<forall>x::real. \<not> x < x"
apply dlo_reify
apply (subst I_qe_dlo [symmetric])
by eval

lemma "\<forall>x y::real. \<exists>z. x < y \<longrightarrow> x < z & z < y"
apply dlo_reify
apply (subst I_qe_dlo [symmetric])
by eval

lemma "\<exists> x::real. a+b < x & x < c*d"
apply dlo_reify
apply (subst I_qe_dlo [symmetric])
apply normalization
oops

lemma "\<forall>x::real. \<not> x < x"
apply dlo_reify
apply (subst I_qe_dlo [symmetric])
by eval

lemma "\<forall>x y::real. \<exists>z. x < y \<longrightarrow> x < z & z < y"
apply dlo_reify
apply (subst I_qe_dlo [symmetric])
by eval

(* 160 secs *)
lemma "\<not>(\<exists>x y z. \<forall>u::real. x < x | \<not> x<u | x<y & y<z & \<not> x<z)"
apply dlo_reify
apply (subst I_qe_dlo [symmetric])
by eval

lemma "qe_dlo(AllQ (Imp (Atom(Less 0 1)) (Atom(Less 1 0)))) = FalseF"
by eval

lemma "qe_dlo(AllQ(AllQ (Imp (Atom(Less 0 1)) (Atom(Less 0 1))))) = TrueF"
by eval

lemma
  "qe_dlo(AllQ(ExQ(AllQ (And (Atom(Less 2 1)) (Atom(Less 1 0)))))) = FalseF"
by eval

lemma "qe_dlo(AllQ(ExQ(ExQ (And (Atom(Less 1 2)) (Atom(Less 2 0)))))) = TrueF"
by eval

lemma
  "qe_dlo(AllQ(AllQ(ExQ (And (Atom(Less 1 0)) (Atom(Less 0 2)))))) = FalseF"
by eval

lemma "qe_dlo(AllQ(AllQ(ExQ (Imp (Atom(Less 1 2)) (And (Atom(Less 1 0)) (Atom(Less 0 2))))))) = TrueF"
by eval

value "qe_dlo(AllQ (Imp (Atom(Less 0 1)) (Atom(Less 0 2))))"

end


theory well_founded_continued

(* N. Peltier - http://membres-lig.imag.fr/peltier/ *)

imports Main

begin

subsection \<open>Well-Founded Sets\<close>

text \<open>Most useful lemmata are already proven in the Well\_Founded theory available in Isabelle.
We only establish a few convenient results for constructing well-founded sets and relations.\<close>

lemma measure_wf:
  assumes "wf (r :: ('a \<times> 'a) set)"
  assumes "r' = { (x,y). ((m x),(m y)) \<in> r }"
  shows "wf r'"
proof -
  have "(\<forall>Q::'b set. \<forall>x:: 'b. x\<in>Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y,z)\<in> r' --> y\<notin>Q))"
  proof  ((rule allI)+,(rule impI))
    fix Q:: "'b set" fix x:: 'b assume "x\<in>Q"
    let ?Q' = "(m ` Q)"
    from \<open>x \<in> Q\<close> have Q'_not_empty: "m x \<in> ?Q'" by auto
    from assms(1) and Q'_not_empty obtain z' where "z' \<in> ?Q'" and z'min: "\<forall>y. (y,z')\<in> r
      \<longrightarrow> y\<notin>?Q'" using wf_eq_minimal [of r] by blast
    from \<open>z' \<in> ?Q'\<close> obtain z where "z' = (m z)" and "z \<in> Q" by auto
    have "\<forall>y. (y,z)\<in> r' \<longrightarrow> y\<notin>Q"
    proof ((rule allI),(rule impI))
      fix y assume "(y,z)\<in> r'"
      from assms(2) and this and \<open>z' = (m z)\<close> have "((m y),z') \<in> r" by auto
      from this and z'min have "(m y) \<notin> ?Q'" by auto
      then show "y\<notin>Q" by auto
    qed
    from this and \<open>z \<in> Q\<close> show "(\<exists>z\<in>Q. \<forall>y. (y,z)\<in> r' --> y\<notin>Q)"  by auto
  qed
  then show ?thesis using wf_eq_minimal by auto
qed

lemma finite_proj_wf:
  assumes "finite E"
  assumes "x \<in> E"
  assumes "acyclic r"
  shows "(\<exists> y. y \<in> E \<and> (\<forall> z. (z, y) \<in> r \<longrightarrow> z \<notin> E))"
proof -
  let ?r = "{ (u,v). (u \<in> E \<and> v \<in> E \<and> (u,v) \<in> r) }"
  from assms(1) have "finite (E \<times> E)" by auto
  have "?r \<subseteq> (E \<times> E)" by auto
  have "?r \<subseteq> r" by auto
  from \<open>?r \<subseteq> (E \<times> E)\<close> and \<open>finite (E \<times> E)\<close> have "finite ?r" using finite_subset by auto
  from assms(3) and \<open>?r \<subseteq> r\<close> have "acyclic ?r" unfolding acyclic_def using trancl_mono by blast
  from \<open>acyclic ?r\<close> \<open>finite ?r\<close> have "wf ?r" using finite_acyclic_wf by auto
  from this assms(2) obtain y where "y \<in> E" and i: "\<And>z. (z, y) \<in> ?r \<Longrightarrow> z \<notin> E"
    using wfE_min [of "?r" x E] by blast
  have "\<forall>z. (z, y) \<in> r \<longrightarrow> z \<notin> E"
  proof (rule allI,rule impI)
    fix z assume "(z,y) \<in> r"
    show "z \<notin> E"
    proof
      assume "z \<in> E"
      from this and \<open>y \<in> E\<close> and \<open>(z,y) \<in> r\<close> have "(z,y) \<in> ?r" by auto
      from this and i [of z] and \<open>z \<in> E\<close> show False by auto
    qed
  qed
  from this and \<open>y \<in> E\<close> show ?thesis by auto
qed

end


(*  Title:      HOL/Hoare/Hoare_Logic_Abort.thy
    Author:     Leonor Prensa Nieto & Tobias Nipkow
    Copyright   2003 TUM
    Author:     Walter Guttmann (extension to total-correctness proofs)
*)

section \<open>Hoare Logic with an Abort statement for modelling run time errors\<close>

theory Hoare_Logic_Abort
  imports Hoare_Syntax Hoare_Tac
begin

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"
type_synonym 'a var = "'a \<Rightarrow> nat"

datatype 'a com =
  Basic "'a \<Rightarrow> 'a"
| Abort
| Seq "'a com" "'a com"
| Cond "'a bexp" "'a com" "'a com"
| While "'a bexp" "'a com"

abbreviation annskip ("SKIP") where "SKIP == Basic id"

type_synonym 'a sem = "'a option => 'a option => bool"

inductive Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) None None"
| "Sem (Basic f) (Some s) (Some (f s))"
| "Sem Abort s None"
| "Sem c1 s s'' \<Longrightarrow> Sem c2 s'' s' \<Longrightarrow> Sem (Seq c1 c2) s s'"
| "Sem (Cond b c1 c2) None None"
| "s \<in> b \<Longrightarrow> Sem c1 (Some s) s' \<Longrightarrow> Sem (Cond b c1 c2) (Some s) s'"
| "s \<notin> b \<Longrightarrow> Sem c2 (Some s) s' \<Longrightarrow> Sem (Cond b c1 c2) (Some s) s'"
| "Sem (While b c) None None"
| "s \<notin> b \<Longrightarrow> Sem (While b c) (Some s) (Some s)"
| "s \<in> b \<Longrightarrow> Sem c (Some s) s'' \<Longrightarrow> Sem (While b c) s'' s' \<Longrightarrow>
   Sem (While b c) (Some s) s'"

inductive_cases [elim!]:
  "Sem (Basic f) s s'" "Sem (Seq c1 c2) s s'"
  "Sem (Cond b c1 c2) s s'"

lemma Sem_deterministic:
  assumes "Sem c s s1"
      and "Sem c s s2"
    shows "s1 = s2"
proof -
  have "Sem c s s1 \<Longrightarrow> (\<forall>s2. Sem c s s2 \<longrightarrow> s1 = s2)"
    by (induct rule: Sem.induct) (subst Sem.simps, blast)+
  thus ?thesis
    using assms by simp
qed

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a anno \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "Valid p c a q \<equiv> \<forall>s s'. Sem c s s' \<longrightarrow> s \<in> Some ` p \<longrightarrow> s' \<in> Some ` q"

definition ValidTC :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a anno \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "ValidTC p c a q \<equiv> \<forall>s . s \<in> p \<longrightarrow> (\<exists>t . Sem c (Some s) (Some t) \<and> t \<in> q)"

lemma tc_implies_pc:
  "ValidTC p c a q \<Longrightarrow> Valid p c a q"
  by (smt (verit) Sem_deterministic ValidTC_def Valid_def image_iff)

lemma tc_extract_function:
  "ValidTC p c a q \<Longrightarrow> \<exists>f . \<forall>s . s \<in> p \<longrightarrow> f s \<in> q"
  by (meson ValidTC_def)

text \<open>The proof rules for partial correctness\<close>

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) a q"
by (auto simp:Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) a q"
by (auto simp:Valid_def)

lemma SeqRule: "Valid P c1 a1 Q \<Longrightarrow> Valid Q c2 a2 R \<Longrightarrow> Valid P (Seq c1 c2) (Aseq a1 a2) R"
by (auto simp:Valid_def)

lemma CondRule:
 "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
  \<Longrightarrow> Valid w c1 a1 q \<Longrightarrow> Valid w' c2 a2 q \<Longrightarrow> Valid p (Cond b c1 c2) (Acond a1 a2) q"
by (fastforce simp:Valid_def image_def)

lemma While_aux:
  assumes "Sem (While b c) s s'"
  shows "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> Some ` (I \<inter> b) \<longrightarrow> s' \<in> Some ` I \<Longrightarrow>
    s \<in> Some ` I \<Longrightarrow> s' \<in> Some ` (I \<inter> -b)"
  using assms
  by (induct "While b c" s s') auto

lemma WhileRule:
 "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c (A 0) i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b c) (Awhile i v A) q"
apply (clarsimp simp:Valid_def)
apply(drule While_aux)
  apply assumption
 apply blast
apply blast
done

lemma AbortRule: "p \<subseteq> {s. False} \<Longrightarrow> Valid p Abort a q"
by(auto simp:Valid_def)

text \<open>The proof rules for total correctness\<close>

lemma SkipRuleTC:
  assumes "p \<subseteq> q"
    shows "ValidTC p (Basic id) a q"
  by (metis Sem.intros(2) ValidTC_def assms id_def subsetD)

lemma BasicRuleTC:
  assumes "p \<subseteq> {s. f s \<in> q}"
    shows "ValidTC p (Basic f) a q"
  by (metis Ball_Collect Sem.intros(2) ValidTC_def assms)

lemma SeqRuleTC:
  assumes "ValidTC p c1 a1 q"
      and "ValidTC q c2 a2 r"
    shows "ValidTC p (Seq c1 c2) (Aseq a1 a2) r"
  by (meson assms Sem.intros(4) ValidTC_def)

lemma CondRuleTC:
 assumes "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}"
     and "ValidTC w c1 a1 q"
     and "ValidTC w' c2 a2 q"
   shows "ValidTC p (Cond b c1 c2) (Acons a1 a2)  q"
proof (unfold ValidTC_def, rule allI)
  fix s
  show "s \<in> p \<longrightarrow> (\<exists>t . Sem (Cond b c1 c2) (Some s) (Some t) \<and> t \<in> q)"
    apply (cases "s \<in> b")
    apply (metis (mono_tags, lifting) Ball_Collect Sem.intros(6) ValidTC_def assms(1,2))
    by (metis (mono_tags, lifting) Ball_Collect Sem.intros(7) ValidTC_def assms(1,3))
qed

lemma WhileRuleTC:
  assumes "p \<subseteq> i"
      and "\<And>n::nat . ValidTC (i \<inter> b \<inter> {s . v s = n}) c (A n) (i \<inter> {s . v s < n})"
      and "i \<inter> uminus b \<subseteq> q"
    shows "ValidTC p (While b c) (Awhile i v A) q"
proof -
  {
    fix s n
    have "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b c) (Some s) (Some t) \<and> t \<in> q)"
    proof (induction "n" arbitrary: s rule: less_induct)
      fix n :: nat
      fix s :: 'a
      assume 1: "\<And>(m::nat) s::'a . m < n \<Longrightarrow> s \<in> i \<and> v s = m \<longrightarrow> (\<exists>t . Sem (While b c) (Some s) (Some t) \<and> t \<in> q)"
      show "s \<in> i \<and> v s = n \<longrightarrow> (\<exists>t . Sem (While b c) (Some s) (Some t) \<and> t \<in> q)"
      proof (rule impI, cases "s \<in> b")
        assume 2: "s \<in> b" and "s \<in> i \<and> v s = n"
        hence "s \<in> i \<inter> b \<inter> {s . v s = n}"
          using assms(1) by auto
        hence "\<exists>t . Sem c (Some s) (Some t) \<and> t \<in> i \<inter> {s . v s < n}"
          by (metis assms(2) ValidTC_def)
        from this obtain t where 3: "Sem c (Some s) (Some t) \<and> t \<in> i \<inter> {s . v s < n}"
          by auto
        hence "\<exists>u . Sem (While b c) (Some t) (Some u) \<and> u \<in> q"
          using 1 by auto
        thus "\<exists>t . Sem (While b c) (Some s) (Some t) \<and> t \<in> q"
          using 2 3 Sem.intros(10) by force
      next
        assume "s \<notin> b" and "s \<in> i \<and> v s = n"
        thus "\<exists>t . Sem (While b c) (Some s) (Some t) \<and> t \<in> q"
          using Sem.intros(9) assms(3) by fastforce
      qed
    qed
  }
  thus ?thesis
    using assms(1) ValidTC_def by force
qed

subsection \<open>Concrete syntax\<close>

setup \<open>
  Hoare_Syntax.setup
   {Basic = \<^const_syntax>\<open>Basic\<close>,
    Skip = \<^const_syntax>\<open>annskip\<close>,
    Seq = \<^const_syntax>\<open>Seq\<close>,
    Cond = \<^const_syntax>\<open>Cond\<close>,
    While = \<^const_syntax>\<open>While\<close>,
    Valid = \<^const_syntax>\<open>Valid\<close>,
    ValidTC = \<^const_syntax>\<open>ValidTC\<close>}
\<close>

\<comment> \<open>Special syntax for guarded statements and guarded array updates:\<close>
syntax
  "_guarded_com" :: "bool \<Rightarrow> 'a com \<Rightarrow> 'a com"  ("(2_ \<rightarrow>/ _)" 71)
  "_array_update" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a com"  ("(2_[_] :=/ _)" [70, 65] 61)
translations
  "P \<rightarrow> c" \<rightleftharpoons> "IF P THEN c ELSE CONST Abort FI"
  "a[i] := v" \<rightharpoonup> "(i < CONST length a) \<rightarrow> (a := CONST list_update a i v)"
  \<comment> \<open>reverse translation not possible because of duplicate \<open>a\<close>\<close>

text \<open>
  Note: there is no special syntax for guarded array access. Thus
  you must write \<open>j < length a \<rightarrow> a[i] := a!j\<close>.
\<close>

subsection \<open>Proof methods: VCG\<close>

declare BasicRule [Hoare_Tac.BasicRule]
  and SkipRule [Hoare_Tac.SkipRule]
  and AbortRule [Hoare_Tac.AbortRule]
  and SeqRule [Hoare_Tac.SeqRule]
  and CondRule [Hoare_Tac.CondRule]
  and WhileRule [Hoare_Tac.WhileRule]

declare BasicRuleTC [Hoare_Tac.BasicRuleTC]
  and SkipRuleTC [Hoare_Tac.SkipRuleTC]
  and SeqRuleTC [Hoare_Tac.SeqRuleTC]
  and CondRuleTC [Hoare_Tac.CondRuleTC]
  and WhileRuleTC [Hoare_Tac.WhileRuleTC]

method_setup vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare_Tac.hoare_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

method_setup vcg_tc = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (K all_tac)))\<close>
  "verification condition generator"

method_setup vcg_tc_simp = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (Hoare_Tac.hoare_tc_tac ctxt (asm_full_simp_tac ctxt)))\<close>
  "verification condition generator plus simplification"

end