(*  Title:      HOL/UNITY/Extend.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Extending of state setsExtending of state sets
  function f (forget)    maps the extended state to the original state
  function g (forgotten) maps the extended state to the "extending part"
*)

section\<open>Extending State Sets\<close>

theory Extend imports Guar begin

definition
  (*MOVE to Relation.thy?*)
  Restrict :: "[ 'a set, ('a*'b) set] => ('a*'b) set"
  where "Restrict A r = r \<inter> (A \<times> UNIV)"

definition
  good_map :: "['a*'b => 'c] => bool"
  where "good_map h \<longleftrightarrow> surj h & (\<forall>x y. fst (inv h (h (x,y))) = x)"
     (*Using the locale constant "f", this is  f (h (x,y))) = x*)

definition
  extend_set :: "['a*'b => 'c, 'a set] => 'c set"
  where "extend_set h A = h ` (A \<times> UNIV)"

definition
  project_set :: "['a*'b => 'c, 'c set] => 'a set"
  where "project_set h C = {x. \<exists>y. h(x,y) \<in> C}"

definition
  extend_act :: "['a*'b => 'c, ('a*'a) set] => ('c*'c) set"
  where "extend_act h = (%act. \<Union>(s,s') \<in> act. \<Union>y. {(h(s,y), h(s',y))})"

definition
  project_act :: "['a*'b => 'c, ('c*'c) set] => ('a*'a) set"
  where "project_act h act = {(x,x'). \<exists>y y'. (h(x,y), h(x',y')) \<in> act}"

definition
  extend :: "['a*'b => 'c, 'a program] => 'c program"
  where "extend h F = mk_program (extend_set h (Init F),
                               extend_act h ` Acts F,
                               project_act h -` AllowedActs F)"

definition
  (*Argument C allows weak safety laws to be projected*)
  project :: "['a*'b => 'c, 'c set, 'c program] => 'a program"
  where "project h C F =
       mk_program (project_set h (Init F),
                   project_act h ` Restrict C ` Acts F,
                   {act. Restrict (project_set h C) act :
                         project_act h ` Restrict C ` AllowedActs F})"

locale Extend =
  fixes f     :: "'c => 'a"
    and g     :: "'c => 'b"
    and h     :: "'a*'b => 'c"    (*isomorphism between 'a * 'b and 'c *)
    and slice :: "['c set, 'b] => 'a set"
  assumes
    good_h:  "good_map h"
  defines f_def: "f z == fst (inv h z)"
      and g_def: "g z == snd (inv h z)"
      and slice_def: "slice Z y == {x. h(x,y) \<in> Z}"

(** These we prove OUTSIDE the locale. **)

subsection\<open>Restrict\<close>
(*MOVE to Relation.thy?*)

lemma Restrict_iff [iff]: "((x,y): Restrict A r) = ((x,y): r & x \<in> A)"
by (unfold Restrict_def, blast)

lemma Restrict_UNIV [simp]: "Restrict UNIV = id"
apply (rule ext)
apply (auto simp add: Restrict_def)
done

lemma Restrict_empty [simp]: "Restrict {} r = {}"
by (auto simp add: Restrict_def)

lemma Restrict_Int [simp]: "Restrict A (Restrict B r) = Restrict (A \<inter> B) r"
by (unfold Restrict_def, blast)

lemma Restrict_triv: "Domain r \<subseteq> A ==> Restrict A r = r"
by (unfold Restrict_def, auto)

lemma Restrict_subset: "Restrict A r \<subseteq> r"
by (unfold Restrict_def, auto)

lemma Restrict_eq_mono:
     "[| A \<subseteq> B;  Restrict B r = Restrict B s |]
      ==> Restrict A r = Restrict A s"
by (unfold Restrict_def, blast)

lemma Restrict_imageI:
     "[| s \<in> RR;  Restrict A r = Restrict A s |]
      ==> Restrict A r \<in> Restrict A ` RR"
by (unfold Restrict_def image_def, auto)

lemma Domain_Restrict [simp]: "Domain (Restrict A r) = A \<inter> Domain r"
by blast

lemma Image_Restrict [simp]: "(Restrict A r) `` B = r `` (A \<inter> B)"
by blast

(*Possibly easier than reasoning about "inv h"*)
lemma good_mapI:
     assumes surj_h: "surj h"
         and prem:   "!! x x' y y'. h(x,y) = h(x',y') ==> x=x'"
     shows "good_map h"
apply (simp add: good_map_def)
apply (safe intro!: surj_h)
apply (rule prem)
apply (subst surjective_pairing [symmetric])
apply (subst surj_h [THEN surj_f_inv_f])
apply (rule refl)
done

lemma good_map_is_surj: "good_map h ==> surj h"
by (unfold good_map_def, auto)

(*A convenient way of finding a closed form for inv h*)
lemma fst_inv_equalityI:
     assumes surj_h: "surj h"
         and prem:   "!! x y. g (h(x,y)) = x"
     shows "fst (inv h z) = g z"
by (metis UNIV_I f_inv_into_f prod.collapse prem surj_h)

subsection\<open>Trivial properties of f, g, h\<close>

context Extend
begin

lemma f_h_eq [simp]: "f(h(x,y)) = x"
by (simp add: f_def good_h [unfolded good_map_def, THEN conjunct2])

lemma h_inject1 [dest]: "h(x,y) = h(x',y') ==> x=x'"
apply (drule_tac f = f in arg_cong)
apply (simp add: f_def good_h [unfolded good_map_def, THEN conjunct2])
done

lemma h_f_g_equiv: "h(f z, g z) == z"
by (simp add: f_def g_def
            good_h [unfolded good_map_def, THEN conjunct1, THEN surj_f_inv_f])

lemma h_f_g_eq: "h(f z, g z) = z"
by (simp add: h_f_g_equiv)

lemma split_extended_all:
     "(!!z. PROP P z) == (!!u y. PROP P (h (u, y)))"
proof
   assume allP: "\<And>z. PROP P z"
   fix u y
   show "PROP P (h (u, y))" by (rule allP)
 next
   assume allPh: "\<And>u y. PROP P (h(u,y))"
   fix z
   have Phfgz: "PROP P (h (f z, g z))" by (rule allPh)
   show "PROP P z" by (rule Phfgz [unfolded h_f_g_equiv])
qed

end

subsection\<open>@{term extend_set}: basic properties\<close>

lemma project_set_iff [iff]:
     "(x \<in> project_set h C) = (\<exists>y. h(x,y) \<in> C)"
by (simp add: project_set_def)

lemma extend_set_mono: "A \<subseteq> B ==> extend_set h A \<subseteq> extend_set h B"
by (unfold extend_set_def, blast)

context Extend
begin

lemma mem_extend_set_iff [iff]: "z \<in> extend_set h A = (f z \<in> A)"
apply (unfold extend_set_def)
apply (force intro: h_f_g_eq [symmetric])
done

lemma extend_set_strict_mono [iff]:
     "(extend_set h A \<subseteq> extend_set h B) = (A \<subseteq> B)"
by (unfold extend_set_def, force)

lemma (in -) extend_set_empty [simp]: "extend_set h {} = {}"
by (unfold extend_set_def, auto)

lemma extend_set_eq_Collect: "extend_set h {s. P s} = {s. P(f s)}"
by auto

lemma extend_set_sing: "extend_set h {x} = {s. f s = x}"
by auto

lemma extend_set_inverse [simp]: "project_set h (extend_set h C) = C"
by (unfold extend_set_def, auto)

lemma extend_set_project_set: "C \<subseteq> extend_set h (project_set h C)"
apply (unfold extend_set_def)
apply (auto simp add: split_extended_all, blast)
done

lemma inj_extend_set: "inj (extend_set h)"
apply (rule inj_on_inverseI)
apply (rule extend_set_inverse)
done

lemma extend_set_UNIV_eq [simp]: "extend_set h UNIV = UNIV"
apply (unfold extend_set_def)
apply (auto simp add: split_extended_all)
done

subsection\<open>@{term project_set}: basic properties\<close>

(*project_set is simply image!*)
lemma project_set_eq: "project_set h C = f ` C"
by (auto intro: f_h_eq [symmetric] simp add: split_extended_all)

(*Converse appears to fail*)
lemma project_set_I: "!!z. z \<in> C ==> f z \<in> project_set h C"
by (auto simp add: split_extended_all)

subsection\<open>More laws\<close>

(*Because A and B could differ on the "other" part of the state,
   cannot generalize to
      project_set h (A \<inter> B) = project_set h A \<inter> project_set h B
*)
lemma project_set_extend_set_Int: "project_set h ((extend_set h A) \<inter> B) = A \<inter> (project_set h B)"
  by auto

(*Unused, but interesting?*)
lemma project_set_extend_set_Un: "project_set h ((extend_set h A) \<union> B) = A \<union> (project_set h B)"
  by auto

lemma (in -) project_set_Int_subset:
    "project_set h (A \<inter> B) \<subseteq> (project_set h A) \<inter> (project_set h B)"
  by auto

lemma extend_set_Un_distrib: "extend_set h (A \<union> B) = extend_set h A \<union> extend_set h B"
  by auto

lemma extend_set_Int_distrib: "extend_set h (A \<inter> B) = extend_set h A \<inter> extend_set h B"
  by auto

lemma extend_set_INT_distrib: "extend_set h (INTER A B) = (\<Inter>x \<in> A. extend_set h (B x))"
  by auto

lemma extend_set_Diff_distrib: "extend_set h (A - B) = extend_set h A - extend_set h B"
  by auto

lemma extend_set_Union: "extend_set h (\<Union>A) = (\<Union>X \<in> A. extend_set h X)"
  by blast

lemma extend_set_subset_Compl_eq: "(extend_set h A \<subseteq> - extend_set h B) = (A \<subseteq> - B)"
  by (auto simp: extend_set_def)

subsection\<open>@{term extend_act}\<close>

(*Can't strengthen it to
  ((h(s,y), h(s',y')) \<in> extend_act h act) = ((s, s') \<in> act & y=y')
  because h doesn't have to be injective in the 2nd argument*)
lemma mem_extend_act_iff [iff]: "((h(s,y), h(s',y)) \<in> extend_act h act) = ((s, s') \<in> act)"
  by (auto simp: extend_act_def)

(*Converse fails: (z,z') would include actions that changed the g-part*)
lemma extend_act_D: "(z, z') \<in> extend_act h act ==> (f z, f z') \<in> act"
  by (auto simp: extend_act_def)

lemma extend_act_inverse [simp]: "project_act h (extend_act h act) = act"
  unfolding extend_act_def project_act_def by blast

lemma project_act_extend_act_restrict [simp]:
     "project_act h (Restrict C (extend_act h act)) =
      Restrict (project_set h C) act"
  unfolding extend_act_def project_act_def by blast

lemma subset_extend_act_D: "act' \<subseteq> extend_act h act ==> project_act h act' \<subseteq> act"
  unfolding extend_act_def project_act_def by force

lemma inj_extend_act: "inj (extend_act h)"
apply (rule inj_on_inverseI)
apply (rule extend_act_inverse)
done

lemma extend_act_Image [simp]:
     "extend_act h act `` (extend_set h A) = extend_set h (act `` A)"
  unfolding extend_set_def extend_act_def by force

lemma extend_act_strict_mono [iff]:
     "(extend_act h act' \<subseteq> extend_act h act) = (act'<=act)"
  by (auto simp: extend_act_def)

lemma (in -) Domain_extend_act:
    "Domain (extend_act h act) = extend_set h (Domain act)"
  unfolding extend_set_def extend_act_def by force

lemma extend_act_Id [simp]: "extend_act h Id = Id"
  unfolding extend_act_def by (force intro: h_f_g_eq [symmetric])

lemma project_act_I:  "!!z z'. (z, z') \<in> act ==> (f z, f z') \<in> project_act h act"
  unfolding project_act_def by (force simp add: split_extended_all)

lemma project_act_Id [simp]: "project_act h Id = Id"
  unfolding project_act_def by force

lemma Domain_project_act: "Domain (project_act h act) = project_set h (Domain act)"
  unfolding project_act_def by (force simp add: split_extended_all)

subsection\<open>extend\<close>

text\<open>Basic properties\<close>

lemma (in -) Init_extend [simp]:
     "Init (extend h F) = extend_set h (Init F)"
  by (auto simp: extend_def)

lemma (in -) Init_project [simp]:
     "Init (project h C F) = project_set h (Init F)"
  by (auto simp: project_def)

lemma Acts_extend [simp]: "Acts (extend h F) = (extend_act h ` Acts F)"
  by (simp add: extend_def insert_Id_image_Acts)

lemma AllowedActs_extend [simp]:
     "AllowedActs (extend h F) = project_act h -` AllowedActs F"
  by (simp add: extend_def insert_absorb)

lemma (in -) Acts_project [simp]:
     "Acts(project h C F) = insert Id (project_act h ` Restrict C ` Acts F)"
  by (auto simp add: project_def image_iff)

lemma AllowedActs_project [simp]:
     "AllowedActs(project h C F) =
        {act. Restrict (project_set h C) act
               \<in> project_act h ` Restrict C ` AllowedActs F}"
apply (simp (no_asm) add: project_def image_iff)
apply (subst insert_absorb)
apply (auto intro!: bexI [of _ Id] simp add: project_act_def)
done

lemma Allowed_extend: "Allowed (extend h F) = project h UNIV -` Allowed F"
  by (auto simp add: Allowed_def)

lemma extend_SKIP [simp]: "extend h SKIP = SKIP"
apply (unfold SKIP_def)
apply (rule program_equalityI, auto)
done

lemma (in -) project_set_UNIV [simp]: "project_set h UNIV = UNIV"
  by auto

lemma (in -) project_set_Union: "project_set h (\<Union>A) = (\<Union>X \<in> A. project_set h X)"
  by blast

(*Converse FAILS: the extended state contributing to project_set h C
  may not coincide with the one contributing to project_act h act*)
lemma (in -) project_act_Restrict_subset:
     "project_act h (Restrict C act) \<subseteq> Restrict (project_set h C) (project_act h act)"
  by (auto simp add: project_act_def)

lemma project_act_Restrict_Id_eq: "project_act h (Restrict C Id) = Restrict (project_set h C) Id"
  by (auto simp add: project_act_def)

lemma project_extend_eq:
     "project h C (extend h F) =
      mk_program (Init F, Restrict (project_set h C) ` Acts F,
                  {act. Restrict (project_set h C) act
                          \<in> project_act h ` Restrict C `
                                     (project_act h -` AllowedActs F)})"
apply (rule program_equalityI)
  apply simp
 apply (simp add: image_image)
apply (simp add: project_def)
done

lemma extend_inverse [simp]:
     "project h UNIV (extend h F) = F"
apply (simp (no_asm_simp) add: project_extend_eq
          subset_UNIV [THEN subset_trans, THEN Restrict_triv])
apply (rule program_equalityI)
apply (simp_all (no_asm))
apply (subst insert_absorb)
apply (simp (no_asm) add: bexI [of _ Id])
apply auto
apply (simp add: image_def)
using project_act_Id apply blast
apply (simp add: image_def)
apply (rename_tac "act")
apply (rule_tac x = "extend_act h act" in exI)
apply simp
done

lemma inj_extend: "inj (extend h)"
apply (rule inj_on_inverseI)
apply (rule extend_inverse)
done

lemma extend_Join [simp]: "extend h (F\<squnion>G) = extend h F\<squnion>extend h G"
apply (rule program_equalityI)
apply (simp (no_asm) add: extend_set_Int_distrib)
apply (simp add: image_Un, auto)
done

lemma extend_JN [simp]: "extend h (JOIN I F) = (\<Squnion>i \<in> I. extend h (F i))"
apply (rule program_equalityI)
  apply (simp (no_asm) add: extend_set_INT_distrib)
 apply (simp add: image_UN, auto)
done

(** These monotonicity results look natural but are UNUSED **)

lemma extend_mono: "F \<le> G ==> extend h F \<le> extend h G"
  by (force simp add: component_eq_subset)

lemma project_mono: "F \<le> G ==> project h C F \<le> project h C G"
  by (simp add: component_eq_subset, blast)

lemma all_total_extend: "all_total F ==> all_total (extend h F)"
  by (simp add: all_total_def Domain_extend_act)

subsection\<open>Safety: co, stable\<close>

lemma extend_constrains:
     "(extend h F \<in> (extend_set h A) co (extend_set h B)) =
      (F \<in> A co B)"
  by (simp add: constrains_def)

lemma extend_stable:
     "(extend h F \<in> stable (extend_set h A)) = (F \<in> stable A)"
  by (simp add: stable_def extend_constrains)

lemma extend_invariant:
     "(extend h F \<in> invariant (extend_set h A)) = (F \<in> invariant A)"
  by (simp add: invariant_def extend_stable)

(*Projects the state predicates in the property satisfied by  extend h F.
  Converse fails: A and B may differ in their extra variables*)
lemma extend_constrains_project_set:
     "extend h F \<in> A co B ==> F \<in> (project_set h A) co (project_set h B)"
  by (auto simp add: constrains_def, force)

lemma extend_stable_project_set:
     "extend h F \<in> stable A ==> F \<in> stable (project_set h A)"
  by (simp add: stable_def extend_constrains_project_set)

subsection\<open>Weak safety primitives: Co, Stable\<close>

lemma reachable_extend_f: "p \<in> reachable (extend h F) ==> f p \<in> reachable F"
  by (induct set: reachable) (auto intro: reachable.intros simp add: extend_act_def image_iff)

lemma h_reachable_extend: "h(s,y) \<in> reachable (extend h F) ==> s \<in> reachable F"
  by (force dest!: reachable_extend_f)

lemma reachable_extend_eq: "reachable (extend h F) = extend_set h (reachable F)"
apply (unfold extend_set_def)
apply (rule equalityI)
apply (force intro: h_f_g_eq [symmetric] dest!: reachable_extend_f, clarify)
apply (erule reachable.induct)
apply (force intro: reachable.intros)+
done

lemma extend_Constrains:
     "(extend h F \<in> (extend_set h A) Co (extend_set h B)) =
      (F \<in> A Co B)"
  by (simp add: Constrains_def reachable_extend_eq extend_constrains
              extend_set_Int_distrib [symmetric])

lemma extend_Stable: "(extend h F \<in> Stable (extend_set h A)) = (F \<in> Stable A)"
  by (simp add: Stable_def extend_Constrains)

lemma extend_Always: "(extend h F \<in> Always (extend_set h A)) = (F \<in> Always A)"
  by (simp add: Always_def extend_Stable)

(** Safety and "project" **)

(** projection: monotonicity for safety **)

lemma (in -) project_act_mono:
     "D \<subseteq> C ==>
      project_act h (Restrict D act) \<subseteq> project_act h (Restrict C act)"
  by (auto simp add: project_act_def)

lemma project_constrains_mono:
     "[| D \<subseteq> C; project h C F \<in> A co B |] ==> project h D F \<in> A co B"
apply (auto simp add: constrains_def)
apply (drule project_act_mono, blast)
done

lemma project_stable_mono:
     "[| D \<subseteq> C;  project h C F \<in> stable A |] ==> project h D F \<in> stable A"
  by (simp add: stable_def project_constrains_mono)

(*Key lemma used in several proofs about project and co*)
lemma project_constrains:
     "(project h C F \<in> A co B)  =
      (F \<in> (C \<inter> extend_set h A) co (extend_set h B) & A \<subseteq> B)"
apply (unfold constrains_def)
apply (auto intro!: project_act_I simp add: ball_Un)
apply (force intro!: project_act_I dest!: subsetD)
(*the <== direction*)
apply (unfold project_act_def)
apply (force dest!: subsetD)
done

lemma project_stable: "(project h UNIV F \<in> stable A) = (F \<in> stable (extend_set h A))"
  by (simp add: stable_def project_constrains)

lemma project_stable_I: "F \<in> stable (extend_set h A) ==> project h C F \<in> stable A"
apply (drule project_stable [THEN iffD2])
apply (blast intro: project_stable_mono)
done

lemma Int_extend_set_lemma:
     "A \<inter> extend_set h ((project_set h A) \<inter> B) = A \<inter> extend_set h B"
  by (auto simp add: split_extended_all)

(*Strange (look at occurrences of C) but used in leadsETo proofs*)
lemma project_constrains_project_set:
     "G \<in> C co B ==> project h C G \<in> project_set h C co project_set h B"
  by (simp add: constrains_def project_def project_act_def, blast)

lemma project_stable_project_set:
     "G \<in> stable C ==> project h C G \<in> stable (project_set h C)"
  by (simp add: stable_def project_constrains_project_set)

subsection\<open>Progress: transient, ensures\<close>

lemma extend_transient:
     "(extend h F \<in> transient (extend_set h A)) = (F \<in> transient A)"
  by (auto simp add: transient_def extend_set_subset_Compl_eq Domain_extend_act)

lemma extend_ensures:
     "(extend h F \<in> (extend_set h A) ensures (extend_set h B)) =
      (F \<in> A ensures B)"
  by (simp add: ensures_def extend_constrains extend_transient
        extend_set_Un_distrib [symmetric] extend_set_Diff_distrib [symmetric])

lemma leadsTo_imp_extend_leadsTo:
     "F \<in> A leadsTo B
      ==> extend h F \<in> (extend_set h A) leadsTo (extend_set h B)"
apply (erule leadsTo_induct)
  apply (simp add: leadsTo_Basis extend_ensures)
 apply (blast intro: leadsTo_Trans)
apply (simp add: leadsTo_UN extend_set_Union)
done

subsection\<open>Proving the converse takes some doing!\<close>

lemma slice_iff [iff]: "(x \<in> slice C y) = (h(x,y) \<in> C)"
  by (simp add: slice_def)

lemma slice_Union: "slice (\<Union>S) y = (\<Union>x \<in> S. slice x y)"
  by auto

lemma slice_extend_set: "slice (extend_set h A) y = A"
  by auto

lemma project_set_is_UN_slice: "project_set h A = (\<Union>y. slice A y)"
  by auto

lemma extend_transient_slice:
     "extend h F \<in> transient A ==> F \<in> transient (slice A y)"
  by (auto simp: transient_def)

(*Converse?*)
lemma extend_constrains_slice:
     "extend h F \<in> A co B ==> F \<in> (slice A y) co (slice B y)"
  by (auto simp add: constrains_def)

lemma extend_ensures_slice:
     "extend h F \<in> A ensures B ==> F \<in> (slice A y) ensures (project_set h B)"
apply (auto simp add: ensures_def extend_constrains extend_transient)
apply (erule_tac [2] extend_transient_slice [THEN transient_strengthen])
apply (erule extend_constrains_slice [THEN constrains_weaken], auto)
done

lemma leadsTo_slice_project_set:
     "\<forall>y. F \<in> (slice B y) leadsTo CU ==> F \<in> (project_set h B) leadsTo CU"
apply (simp add: project_set_is_UN_slice)
apply (blast intro: leadsTo_UN)
done

lemma extend_leadsTo_slice [rule_format]:
     "extend h F \<in> AU leadsTo BU
      ==> \<forall>y. F \<in> (slice AU y) leadsTo (project_set h BU)"
apply (erule leadsTo_induct)
  apply (blast intro: extend_ensures_slice)
 apply (blast intro: leadsTo_slice_project_set leadsTo_Trans)
apply (simp add: leadsTo_UN slice_Union)
done

lemma extend_leadsTo:
     "(extend h F \<in> (extend_set h A) leadsTo (extend_set h B)) =
      (F \<in> A leadsTo B)"
apply safe
apply (erule_tac [2] leadsTo_imp_extend_leadsTo)
apply (drule extend_leadsTo_slice)
apply (simp add: slice_extend_set)
done

lemma extend_LeadsTo:
     "(extend h F \<in> (extend_set h A) LeadsTo (extend_set h B)) =
      (F \<in> A LeadsTo B)"
  by (simp add: LeadsTo_def reachable_extend_eq extend_leadsTo
              extend_set_Int_distrib [symmetric])

subsection\<open>preserves\<close>

lemma project_preserves_I:
     "G \<in> preserves (v o f) ==> project h C G \<in> preserves v"
  by (auto simp add: preserves_def project_stable_I extend_set_eq_Collect)

(*to preserve f is to preserve the whole original state*)
lemma project_preserves_id_I:
     "G \<in> preserves f ==> project h C G \<in> preserves id"
  by (simp add: project_preserves_I)

lemma extend_preserves:
     "(extend h G \<in> preserves (v o f)) = (G \<in> preserves v)"
  by (auto simp add: preserves_def extend_stable [symmetric]
                   extend_set_eq_Collect)

lemma inj_extend_preserves: "inj h ==> (extend h G \<in> preserves g)"
  by (auto simp add: preserves_def extend_def extend_act_def stable_def
                   constrains_def g_def)

subsection\<open>Guarantees\<close>

lemma project_extend_Join: "project h UNIV ((extend h F)\<squnion>G) = F\<squnion>(project h UNIV G)"
  apply (rule program_equalityI)
  apply (auto simp add: project_set_extend_set_Int image_iff)
  apply (metis Un_iff extend_act_inverse image_iff)
  apply (metis Un_iff extend_act_inverse image_iff)
  done

lemma extend_Join_eq_extend_D:
     "(extend h F)\<squnion>G = extend h H ==> H = F\<squnion>(project h UNIV G)"
apply (drule_tac f = "project h UNIV" in arg_cong)
apply (simp add: project_extend_Join)
done

(** Strong precondition and postcondition; only useful when
    the old and new state sets are in bijection **)

lemma ok_extend_imp_ok_project: "extend h F ok G ==> F ok project h UNIV G"
apply (auto simp add: ok_def)
apply (drule subsetD)
apply (auto intro!: rev_image_eqI)
done

lemma ok_extend_iff: "(extend h F ok extend h G) = (F ok G)"
apply (simp add: ok_def, safe)
apply force+
done

lemma OK_extend_iff: "OK I (%i. extend h (F i)) = (OK I F)"
apply (unfold OK_def, safe)
apply (drule_tac x = i in bspec)
apply (drule_tac [2] x = j in bspec)
apply force+
done

lemma guarantees_imp_extend_guarantees:
     "F \<in> X guarantees Y ==>
      extend h F \<in> (extend h ` X) guarantees (extend h ` Y)"
apply (rule guaranteesI, clarify)
apply (blast dest: ok_extend_imp_ok_project extend_Join_eq_extend_D
                   guaranteesD)
done

lemma extend_guarantees_imp_guarantees:
     "extend h F \<in> (extend h ` X) guarantees (extend h ` Y)
      ==> F \<in> X guarantees Y"
apply (auto simp add: guar_def)
apply (drule_tac x = "extend h G" in spec)
apply (simp del: extend_Join
            add: extend_Join [symmetric] ok_extend_iff
                 inj_extend [THEN inj_image_mem_iff])
done

lemma extend_guarantees_eq:
     "(extend h F \<in> (extend h ` X) guarantees (extend h ` Y)) =
      (F \<in> X guarantees Y)"
  by (blast intro: guarantees_imp_extend_guarantees
                 extend_guarantees_imp_guarantees)

end

end


(*  Title:       A nondeterministic While Combinator
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

section \<open> A nondeterministic while combinator \<close>

theory Workset
imports Main "Refine_Monadic/Refine_Monadic" "~~/src/HOL/Library/Multiset" Utils
begin

subsection \<open> Worklist algorithm \<close>
text \<open>
Peter Lammich's refinement framework provides tools to reason about
while loops. Let's use these tools to define worklist algorithms.

Despite the name, I'm not really interested in algorithms operating
on lists here. Often the order in which the elements of the worklist are
processed is unimportant. Therefore, multisets are useful.

For many algorithm one could use sets instead of multisets, because elements that
have already been processed don't modify the state a second time.
So, this theory introduces 3 closely related concepts: worklist, workbag and workset algorithms.
\<close>

subsection \<open> Introducing some intermediate predicates for While Loops \<close>

definition WHILE_variant_OK where
  "WHILE_variant_OK cond step invar r \<equiv>
  (\<comment>\<open>r is well-founded\<close>
    wf r \<and>

   \<comment>\<open>each step does not fail, decreases according to r and preserves the invariant\<close>
   (\<forall>s. invar s \<and> cond s \<longrightarrow> step s \<le> SPEC (\<lambda>s'. invar s' \<and> (s', s) \<in> r)))"

lemma WHILE_variant_OK_I [intro!] :
  "\<lbrakk>wf r; \<And>s. \<lbrakk> cond s; invar s \<rbrakk> \<Longrightarrow> step s \<le> SPEC (\<lambda>s'. invar s' \<and> (s', s) \<in> r)\<rbrakk> \<Longrightarrow>
    WHILE_variant_OK cond step invar r"
unfolding WHILE_variant_OK_def by blast

definition WHILE_variant_exists where
  "WHILE_variant_exists cond step invar \<equiv>
   \<exists>r. WHILE_variant_OK cond step invar r"

lemma WHILE_variant_exists_I [intro!] :
  "WHILE_variant_OK cond step invar r \<Longrightarrow> WHILE_variant_exists cond step invar"
unfolding WHILE_variant_exists_def by blast

definition "WHILE_invar_OK cond step invar \<equiv>
            (\<forall>s. (cond s \<and> invar s) \<longrightarrow> step s \<le> SPEC invar)"

lemma WHILE_invar_OK_I [intro!] :
  "\<lbrakk>\<And>s. \<lbrakk> cond s; invar s \<rbrakk> \<Longrightarrow> step s \<le> SPEC invar\<rbrakk> \<Longrightarrow> WHILE_invar_OK cond step invar"
unfolding WHILE_invar_OK_def by blast

lemma WHILE_variant___invar_extract :
assumes invar_ex: "WHILE_variant_exists cond step invar"
shows "WHILE_invar_OK cond step invar"
proof
  fix s
  assume "invar s" "cond s"
  with invar_ex obtain r where step1: "step s \<le> SPEC (\<lambda>s'. invar s' \<and> (s', s) \<in> r)"
    unfolding WHILE_variant_exists_def WHILE_variant_OK_def
    by blast

  have step2: "SPEC (\<lambda>s'. invar s' \<and> (s', s) \<in> r) \<le> SPEC invar"
    by (rule SPEC_rule) fast

  from step1 step2 show "step s \<le> SPEC invar"
    by (rule order_trans)
qed

text \<open> Invariants can be combined ... \<close>

lemma WHILE_invar_OK___combine :
  "\<lbrakk>WHILE_invar_OK cond step invar1;
    WHILE_invar_OK cond step invar2\<rbrakk> \<Longrightarrow>
   WHILE_invar_OK cond step (\<lambda>s. invar1 s \<and> invar2 s)"
  unfolding WHILE_invar_OK_def
  by (auto simp: pw_le_iff refine_pw_simps)

text \<open> ... and extended. \<close>

lemma WHILE_invar_OK___extend :
  "\<lbrakk>WHILE_invar_OK cond step invar1;
    \<And>s. \<lbrakk> cond s; invar1 s; invar2 s \<rbrakk> \<Longrightarrow> step s \<le> SPEC invar2\<rbrakk> \<Longrightarrow>
   WHILE_invar_OK cond step (\<lambda>s. invar1 s \<and> invar2 s)"
unfolding WHILE_invar_OK_def
  by (auto simp: pw_le_iff refine_pw_simps)

lemma WHILE_variant_OK___extend_invariant :
assumes invar_OK: "WHILE_invar_OK cond step invar"
    and wf_r: "wf r"
    and in_r: "\<And>s. \<lbrakk> cond s; invar s \<rbrakk> \<Longrightarrow> step s \<le> SPEC (\<lambda>s'. (s', s) \<in> r)"
shows "WHILE_variant_OK cond step invar r"
proof
  show "wf r" by fact
next
  fix s
  assume cond_s: "cond s" and invar_s: "invar s"

  from in_r[OF cond_s invar_s] have step1: "step s \<le> SPEC (\<lambda>s'. (s', s) \<in> r)" .
  from invar_OK have step2: "step s \<le> SPEC (\<lambda>s'. invar s')"
    unfolding WHILE_invar_OK_def using cond_s invar_s by simp

  from step1 step2
  show "step s \<le> SPEC (\<lambda>s'. invar s' \<and> (s', s) \<in> r)"
    apply (cases "step s")
    apply (auto)
  done
qed

text \<open> Interface to WHILE rules using these definitions \<close>

lemma WHILEI_rule_manual:
  assumes I0: "I x0"
  assumes IS: "WHILE_invar_OK b f I"
  assumes II: "\<And>x. \<lbrakk> I x; \<not>b x \<rbrakk> \<Longrightarrow> P x"
  shows "WHILEI I b f x0 \<le> SPEC P"
  using assms
  unfolding WHILE_invar_OK_def
  by (rule_tac WHILEI_rule, simp_all)

lemma WHILEIT_rule_manual:
  assumes I0: "I x0"
  assumes IS: "WHILE_variant_exists b f I"
  assumes II: "\<And>x. \<lbrakk> I x; \<not>b x \<rbrakk> \<Longrightarrow> P x"
  shows "WHILEIT I b f x0 \<le> SPEC P"
  proof -
    from IS [unfolded WHILE_variant_exists_def]
    obtain R where variant_OK: "WHILE_variant_OK b f I R" by blast

    with I0 II show ?thesis
      unfolding WHILE_variant_OK_def
      apply (rule_tac WHILEIT_rule[of R])
      apply (simp_all)
    done
  qed

lemma WHILE_rule_manual:
  assumes I0: "I x0"
  assumes IS: "WHILE_invar_OK b f I"
  assumes II: "\<And>x. \<lbrakk> I x; \<not>b x \<rbrakk> \<Longrightarrow> P x"
  shows "WHILE b f x0 \<le> SPEC P"
  using assms
  unfolding WHILE_invar_OK_def
  by (rule_tac WHILE_rule[of I], simp_all)

lemma WHILET_rule_manual:
  assumes I0: "I x0"
  assumes IS: "WHILE_variant_exists b f I"
  assumes II: "\<And>x. \<lbrakk> I x; \<not>b x \<rbrakk> \<Longrightarrow> P x"
  shows "WHILET b f x0 \<le> SPEC P"
  proof -
    from IS [unfolded WHILE_variant_exists_def]
    obtain R where variant_OK: "WHILE_variant_OK b f I R" by blast

    with I0 II show ?thesis
      unfolding WHILE_variant_OK_def
      apply (rule_tac WHILET_rule[of R I])
      apply (simp_all)
    done
  qed

subsubsection \<open> Multisets / Bags\<close>

definition workbag_update where
  "workbag_update wb e N \<equiv> (wb - {#e#}) + N"

definition WORKBAG_b where
  "WORKBAG_b b = (\<lambda>swb. snd swb \<noteq> {#} \<and> b (fst swb))"

definition WORKBAG_f ::
 "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 'e \<Rightarrow> ('s \<times> 'e multiset) nres) \<Rightarrow>
   's \<times> 'e multiset \<Rightarrow> ('s \<times> 'e multiset) nres" where
  "WORKBAG_f b f = (\<lambda>swb. do {
     ASSERT (WORKBAG_b b swb);
     e \<leftarrow> SPEC (\<lambda>e. e \<in># (snd swb));
     (s', N) \<leftarrow> f (fst swb) e;
     RETURN (s', workbag_update (snd swb) e N)})"

definition WORKBAGI ("WORKBAGI\<^bsup>_\<^esup>") where
  "WORKBAGI \<Phi> b f swb0 =
   WHILEI \<Phi> (WORKBAG_b b) (WORKBAG_f b f) swb0"

definition WORKBAG where "WORKBAG \<equiv> WORKBAGI (\<lambda>_. True)"

definition WORKBAGIT ("WORKBAGI\<^sub>T\<^bsup>_\<^esup>") where
  "WORKBAGIT \<Phi> b f swb0 \<equiv> WHILEIT \<Phi> (WORKBAG_b b) (WORKBAG_f b f) swb0"

definition WORKBAGT ("WORKBAG\<^sub>T") where "WORKBAG\<^sub>T \<equiv> WORKBAGIT (\<lambda>_. True)"

definition WORKBAG_invar_OK where
  "WORKBAG_invar_OK cond step invar =
   (\<forall>s wb e. invar (s, wb) \<and> e \<in># wb \<and> cond s \<longrightarrow>
             step s e \<le> SPEC (\<lambda>s'N. (invar (fst s'N, (workbag_update wb e (snd s'N))))))"

lemma WORKBAG_invar_OK___lift_to_while :
assumes invar_OK: "WORKBAG_invar_OK cond step invar"
shows "WHILE_invar_OK (WORKBAG_b cond) (WORKBAG_f cond step) invar"
proof
  fix swb
  assume cond: "WORKBAG_b cond swb"
     and invar: "invar swb"
  obtain s wb where swb_eq[simp]: "swb = (s, wb)" by fastforce

  from cond have wb_neq: "wb \<noteq> {#}" unfolding WORKBAG_b_def by simp

  from cond invar invar_OK
  have invar_OK': "\<And>e. e \<in># wb \<Longrightarrow> step s e \<le> SPEC (\<lambda>s'N. invar (fst s'N, workbag_update wb e (snd s'N)))"
    unfolding WORKBAG_invar_OK_def WORKBAG_b_def by simp

  thus "WORKBAG_f cond step swb \<le> SPEC invar"
    unfolding WORKBAG_f_def
    apply (intro refine_vcg)
    apply (rule cond)
    apply (simp add: wb_neq)[]
    apply (simp add: case_prod_beta')
  done
qed

definition WORKBAG_variant_OK where
  "WORKBAG_variant_OK cond step invar r \<equiv>
   (wf r \<and>
   (\<forall>s wb e. (invar (s, wb) \<and> e \<in># wb \<and> cond s \<longrightarrow>
     step s e \<le> SPEC (\<lambda>s'N. (invar (fst s'N, (workbag_update wb e (snd s'N)))) \<and>
      ((fst s'N, s) \<in> r \<or> (s'N = (s, {#})))))))"

definition WORKBAG_variant_exists where
  "WORKBAG_variant_exists cond step invar \<equiv>
   \<exists>r. WORKBAG_variant_OK cond step invar r"

lemma WORKBAG_variant_OK___lift_to_while :
fixes invar :: "'S \<times> 'e multiset \<Rightarrow> bool"
assumes var_OK: "WORKBAG_variant_OK cond step invar r"
shows "WHILE_variant_OK (WORKBAG_b cond) (WORKBAG_f cond step) invar (r <*lex*> subset_mset_rel)"
proof
  {
    from var_OK have "wf r"
      unfolding WORKBAG_variant_OK_def
      by fast
    with wf_subset_mset_rel
    show "wf (r <*lex*> subset_mset_rel)" unfolding subset_mset_rel_def by blast
  }

  fix swb :: "'S \<times> 'e multiset"
  obtain s wb where swb_eq[simp]: "swb = (s, wb)" by fastforce

  assume invar_swb: "invar swb"
     and cond_swb: "WORKBAG_b cond swb"

  from var_OK invar_swb cond_swb have var_OK': "\<And>e. e \<in># wb \<Longrightarrow>
    step s e \<le> SPEC (\<lambda>s'N. invar (fst s'N, workbag_update wb e (snd s'N)) \<and>
             ((fst s'N, s) \<in> r \<or> s'N = (s, {#})))"
    unfolding WORKBAG_b_def WORKBAG_variant_OK_def by simp

  have spec_step: "\<And>e. e \<in># wb \<Longrightarrow>
        SPEC (\<lambda>s'N. invar (fst s'N, workbag_update wb e (snd s'N)) \<and>
             ((fst s'N, s) \<in> r \<or> s'N = (s, {#}))) \<le>
        SPEC
           (\<lambda>xa. invar (fst xa, workbag_update wb e (snd xa)) \<and>
                 ((fst xa, s) \<in> r \<or>
                  fst xa = s \<and>
                  (workbag_update wb e (snd xa), wb) \<in> subset_mset_rel))"
   by (auto simp add: subset_iff workbag_update_def subset_mset_rel_def mset_subset_diff_self)

  from cond_swb have "wb \<noteq> {#}" unfolding WORKBAG_b_def by simp
  with order_trans [OF var_OK' spec_step]
  show "WORKBAG_f cond step swb \<le> SPEC (\<lambda>s'. invar s' \<and> (s', swb) \<in> r <*lex*> subset_mset_rel)"
    unfolding WORKBAG_f_def
    apply (intro refine_vcg cond_swb)
    apply (simp_all add: split_beta)
  done
qed

lemma WORKBAG_variant_exists___lift_to_while :
"WORKBAG_variant_exists cond step invar \<Longrightarrow>
 WHILE_variant_exists (WORKBAG_b cond) (WORKBAG_f cond step) invar"
unfolding WORKBAG_variant_exists_def WHILE_variant_exists_def
by (metis WORKBAG_variant_OK___lift_to_while)

lemma WORKBAGI_rule_manual:
  assumes I0: "I (s0, wb0)"
  assumes IS: "WORKBAG_invar_OK b f I"
  assumes II1: "\<And>s wb. \<lbrakk> I (s, wb); \<not>b s; wb \<noteq> {#} \<rbrakk> \<Longrightarrow> P (s, wb)"
  assumes II2: "\<And>s. I (s, {#}) \<Longrightarrow> P (s, {#})"
  shows "WORKBAGI I b f (s0, wb0) \<le> SPEC P"
  unfolding WORKBAGI_def
  proof (rule WHILEI_rule_manual)
    from I0 show "I (s0, wb0)" .
  next
    from WORKBAG_invar_OK___lift_to_while [OF IS]
    show "WHILE_invar_OK (WORKBAG_b b) (WORKBAG_f b f) I" .
  next
    fix x
    assume "I x" "\<not> WORKBAG_b b x"
    with II1[of "fst x" "snd x"] II2[of "fst x"] show "P x"
      unfolding WORKBAG_b_def
      by (cases x, auto)
  qed

lemma WORKBAGIT_rule_manual:
  assumes I0: "I (s0, wb0)"
  assumes IS: "WORKBAG_variant_exists b f I"
  assumes II1: "\<And>s wb. \<lbrakk> I (s, wb); \<not>b s; wb \<noteq> {#} \<rbrakk> \<Longrightarrow> P (s, wb)"
  assumes II2: "\<And>s. I (s, {#}) \<Longrightarrow> P (s, {#})"
  shows "WORKBAGIT I b f (s0, wb0) \<le> SPEC P"
  unfolding WORKBAGIT_def
  proof (rule WHILEIT_rule_manual)
    from I0 show "I (s0, wb0)" .
  next
    from WORKBAG_variant_exists___lift_to_while [OF IS]
    show "WHILE_variant_exists (WORKBAG_b b) (WORKBAG_f b f) I" .
  next
    fix x
    assume "I x" "\<not> WORKBAG_b b x"
    with II1[of "fst x" "snd x"] II2[of "fst x"] show "P x"
      unfolding WORKBAG_b_def
      by (cases x, auto)
  qed

lemma WORKBAGIT_rule:
  assumes "I (s0, wb0)"
  assumes "wf R"
  assumes "\<And>s wb e. \<lbrakk>I (s, wb); e \<in># wb; b s\<rbrakk> \<Longrightarrow>
    f s e \<le> SPEC (\<lambda>s'N.
           I (fst s'N, workbag_update wb e (snd s'N)) \<and>
           ((fst s'N, s) \<in> R \<or> s'N = (s, {#})))"
  assumes "\<And>s wb. \<lbrakk> I (s, wb); \<not>b s; wb \<noteq> {#} \<rbrakk> \<Longrightarrow> P (s, wb)"
  assumes "\<And>s. I (s, {#}) \<Longrightarrow> P (s, {#})"
  shows "WORKBAGIT I b f (s0, wb0) \<le> SPEC P"
  using assms
  apply (rule_tac WORKBAGIT_rule_manual)
  apply (simp_all add: WORKBAG_variant_exists_def WORKBAG_variant_OK_def)
  apply blast
done

subsubsection \<open> Lists \<close>

text \<open> A simple possibility to implement multisets are lists. \<close>

definition WORKLIST_b where
  "WORKLIST_b b = (\<lambda>swl. snd swl \<noteq> [] \<and> b (fst swl))"

definition WORKLIST_f ::
 "('s \<Rightarrow> bool) \<Rightarrow>
  ('s \<Rightarrow> 'e \<Rightarrow> ('s \<times> 'e list) nres) \<Rightarrow>
   's \<times> 'e list \<Rightarrow> ('s \<times> 'e list) nres" where
  "WORKLIST_f b f = (\<lambda>swl. do {
     ASSERT (WORKLIST_b b swl);
     let e = hd (snd swl);
     (s', N) \<leftarrow> f (fst swl) e;
     RETURN (s', N @ tl (snd swl))})"

definition WORKLISTI ("WORKLISTI\<^bsup>_\<^esup>") where
  "WORKLISTI \<Phi> b f swl0 = WHILEI \<Phi> (WORKLIST_b b) (WORKLIST_f b f) swl0"

definition WORKLIST where "WORKLIST \<equiv> WORKLISTI (\<lambda>_. True)"

definition WORKLISTIT ("WORKLISTI\<^sub>T\<^bsup>_\<^esup>") where
  "WORKLISTIT \<Phi> b f swl0 \<equiv> WHILEIT \<Phi> (WORKLIST_b b) (WORKLIST_f b f) swl0"

definition WORKLISTT ("WORKLIST\<^sub>T") where "WORKLIST\<^sub>T \<equiv> WORKLISTIT (\<lambda>_. True)"

lemma WORKLISTT_alt_def :
  "WORKLISTT b f swl0 = WHILET (WORKLIST_b b) (WORKLIST_f b f) swl0"
unfolding WORKLISTT_def WORKLISTIT_def WHILET_def[symmetric]
by simp

definition worklist_build_rel where
  "worklist_build_rel = build_rel (apsnd multiset_of) (\<lambda>_. True)"

lemma worklist_build_rel_sv[simp, intro!]: "single_valued worklist_build_rel"
  unfolding worklist_build_rel_def by rule

lemma WORKBAGIT_LIST_refine:
  assumes R0: "s0' = (s0::'S) \<and> wb0 = multiset_of (wl0 :: 'e list)"
  assumes RPHI: "\<And>s wl. \<Phi>' (s, multiset_of wl) \<Longrightarrow> \<Phi> (s, wl)"
  assumes RB: "\<And>s wl. \<lbrakk>  \<Phi>(s, wl); \<Phi>' (s, multiset_of wl) \<rbrakk> \<Longrightarrow> b s \<longleftrightarrow> b' s"
  assumes RS[refine]:
    "\<And>s wl e. \<lbrakk> \<Phi>(s, wl); \<Phi>' (s, multiset_of wl); b s; b' s; e \<in> set wl\<rbrakk> \<Longrightarrow>
        f s e \<le> \<Down>worklist_build_rel (f' s e)"
  shows "WORKLISTIT \<Phi> b f (s0, wl0) \<le>
         \<Down>worklist_build_rel (WORKBAGIT \<Phi>' b' f' (s0', wb0))"
  unfolding WORKLISTIT_def WORKBAGIT_def
proof (rule WHILEIT_refine)
  from R0 show "((s0, wl0), s0', wb0) \<in> worklist_build_rel"
    unfolding worklist_build_rel_def build_rel_def
    by simp
next
  fix swl :: "('S \<times> 'e list)" and swb
  assume "(swl, swb) \<in> worklist_build_rel"
  then obtain s wl where swl_eq[simp] : "swl = (s, wl)"
                     and swb_eq[simp] : "swb = (s, multiset_of wl)"
    unfolding worklist_build_rel_def build_rel_def
    by (cases swl, cases swb, auto)

  assume PHI': "\<Phi>' swb"
  with RPHI show PHI: "\<Phi> swl" by simp

  from RB PHI PHI' show "WORKLIST_b b swl = WORKBAG_b b' swb"
    unfolding WORKLIST_b_def WORKBAG_b_def apply simp
    unfolding multiset_of_def
    using neq_NilE by fastforce

  assume "WORKLIST_b b swl"
  with RB PHI PHI' have "b s" and "b' s"
    unfolding WORKLIST_b_def by auto

  from `WORKLIST_b b swl`
  obtain e wl' where wl_eq[simp]: "wl = e # wl'"
    unfolding WORKLIST_b_def by (cases wl, auto)

  from RS[of s wl] PHI PHI' `b s` `b' s`
  have f_ref: "f s e \<le> \<Down> worklist_build_rel (f' s e)" by simp

  show "WORKLIST_f b f swl \<le> \<Down> worklist_build_rel (WORKBAG_f b' f' swb)"
    unfolding WORKBAG_f_def WORKLIST_f_def WORKBAG_b_def WORKLIST_b_def
    apply (rule ASSERT_refine_right)
    apply (rule ASSERT_refine_left)
    apply (simp add: `b s` `b' s`)
    apply (rule bind2let_refine [where R' = "{(e, e)}"])
    apply (simp add: Image_iff pw_le_iff refine_pw_simps)
    apply (rule_tac bind_refine [where R' = "worklist_build_rel"])
    apply (simp add: f_ref)
    apply (auto simp add:
      worklist_build_rel_def workbag_update_def pw_le_iff refine_pw_simps
      union_commute refine_rel_defs)
  done
qed

lemma WORKBAGIT_LIST_refine_simple:
  assumes RS:
    "\<And>s wl e. \<lbrakk> \<Phi> (s, multiset_of wl); b s; e \<in> set wl \<rbrakk> \<Longrightarrow>
        f s e \<le> \<Down>worklist_build_rel (f' s e)"
  shows "WORKLISTIT (\<lambda>(s, wl). \<Phi> (s, multiset_of wl)) b f (s0, wl0) \<le>
         \<Down>worklist_build_rel (WORKBAGIT \<Phi> b f' (s0, multiset_of wl0))"
apply (rule WORKBAGIT_LIST_refine)
apply (simp_all add: RS)
done

definition WORKLIST_invar_OK where
  "WORKLIST_invar_OK cond step invar =
   (\<forall>s wl e. invar (s, (e # wl)) \<and> cond s \<longrightarrow>
             step s e \<le> SPEC (\<lambda>s'N. (invar (fst s'N, (snd s'N) @ wl))))"

lemma WORKLIST_invar_OK___lift_to_while :
assumes invar_OK: "WORKLIST_invar_OK cond step invar"
shows "WHILE_invar_OK (WORKLIST_b cond) (WORKLIST_f cond step) invar"
proof
  fix swl
  assume cond: "WORKLIST_b cond swl"
     and invar: "invar swl"
  obtain s wl where swl_eq[simp]: "swl = (s, wl)" by fastforce

  from cond obtain e wl' where wl_eq[simp]: "wl = e # wl'"
    unfolding WORKLIST_b_def by (simp, cases wl, blast)

  from cond invar invar_OK
  have invar_OK': "step s e \<le> SPEC (\<lambda>x. invar (fst x, snd x @ wl'))"
    unfolding WORKLIST_invar_OK_def WORKLIST_b_def by simp

  thus "WORKLIST_f cond step swl \<le> SPEC invar"
    unfolding WORKLIST_f_def
    apply (intro refine_vcg)
    apply (rule cond)
    apply (simp add: split_beta)
  done
qed

definition WORKLIST_variant_OK where
  "WORKLIST_variant_OK cond step invar r \<equiv>
   (wf r \<and>
   (\<forall>s wl e. (invar (s, e # wl) \<and> cond s \<longrightarrow>
     step s e \<le> SPEC (\<lambda>s'N. (invar (fst s'N, (snd s'N) @ wl)) \<and>
      ((fst s'N, s) \<in> r \<or> (s'N = (s, [])))))))"

definition WORKLIST_variant_exists where
  "WORKLIST_variant_exists cond step invar \<equiv>
   \<exists>r. WORKLIST_variant_OK cond step invar r"

lemma WORKLIST_variant_OK___lift_to_while :
fixes invar :: "'S \<times> 'e list \<Rightarrow> bool"
assumes var_OK: "WORKLIST_variant_OK cond step invar r"
shows "WHILE_variant_OK (WORKLIST_b cond) (WORKLIST_f cond step) invar (r <*lex*> measure length)"
proof
  {
    from var_OK have "wf r"
      unfolding WORKLIST_variant_OK_def
      by fast
    thus "wf (r <*lex*> measure length)" by auto
  }

  fix swl :: "'S \<times> 'e list"
  obtain s wl where swl_eq[simp]: "swl = (s, wl)" by fastforce

  assume invar_swl: "invar swl"
     and cond_swl: "WORKLIST_b cond swl"

  from cond_swl obtain e wl' where wl_eq[simp]: "wl = e # wl'"
    unfolding WORKLIST_b_def by (simp, cases wl, blast)

  from var_OK invar_swl cond_swl have var_OK': "
    step s e \<le> SPEC (\<lambda>s'N. invar (fst s'N, (snd s'N) @ wl') \<and>
             ((fst s'N, s) \<in> r \<or> s'N = (s, [])))"
    unfolding WORKLIST_b_def WORKLIST_variant_OK_def by simp

  have spec_step: "
        SPEC (\<lambda>s'N. invar (fst s'N, (snd s'N) @ wl') \<and>
             ((fst s'N, s) \<in> r \<or> s'N = (s, []))) \<le>
        SPEC
           (\<lambda>xa. invar (fst xa, (snd xa) @ wl') \<and>
                 ((fst xa, s) \<in> r \<or>
                  fst xa = s \<and>
                  ((snd xa) @ wl', wl) \<in> measure length))"
   by (auto simp add: subset_iff)

  from order_trans [OF var_OK' spec_step]
  show "WORKLIST_f cond step swl \<le> SPEC (\<lambda>s'. invar s' \<and> (s', swl) \<in> r <*lex*> measure length)"
    unfolding WORKLIST_f_def
    apply (intro refine_vcg cond_swl)
    apply (simp_all add: split_beta)
  done
qed

lemma WORKLIST_variant_exists___lift_to_while :
"WORKLIST_variant_exists cond step invar \<Longrightarrow>
 WHILE_variant_exists (WORKLIST_b cond) (WORKLIST_f cond step) invar"
unfolding WORKLIST_variant_exists_def WHILE_variant_exists_def
by (metis WORKLIST_variant_OK___lift_to_while)

lemma WORKLISTI_rule_manual:
  assumes I0: "I (s0, wl0)"
  assumes IS: "WORKLIST_invar_OK b f I"
  assumes II1: "\<And>s wl. \<lbrakk> I (s, wl); \<not>b s; wl \<noteq> []\<rbrakk> \<Longrightarrow> P (s, wl)"
  assumes II2: "\<And>s. I (s, []) \<Longrightarrow> P (s, [])"
  shows "WORKLISTI I b f (s0, wl0) \<le> SPEC P"
  unfolding WORKLISTI_def
  proof (rule WHILEI_rule_manual)
    from I0 show "I (s0, wl0)" .
  next
    from WORKLIST_invar_OK___lift_to_while [OF IS]
    show "WHILE_invar_OK (WORKLIST_b b) (WORKLIST_f b f) I" .
  next
    fix x
    assume "I x" "\<not> WORKLIST_b b x"
    with II1[of "fst x" "snd x"] II2[of "fst x"] show "P x"
      unfolding WORKLIST_b_def
      by (cases x, auto)
  qed

lemma WORKLISTIT_rule_manual:
  assumes I0: "I (s0, wl0)"
  assumes IS: "WORKLIST_variant_exists b f I"
  assumes II1: "\<And>s wl. \<lbrakk> I (s, wl); \<not>b s; wl \<noteq> [] \<rbrakk> \<Longrightarrow> P (s, wl)"
  assumes II2: "\<And>s. I (s, []) \<Longrightarrow> P (s, [])"
  shows "WORKLISTIT I b f (s0, wl0) \<le> SPEC P"
  unfolding WORKLISTIT_def
  proof (rule WHILEIT_rule_manual)
    from I0 show "I (s0, wl0)" .
  next
    from WORKLIST_variant_exists___lift_to_while [OF IS]
    show "WHILE_variant_exists (WORKLIST_b b) (WORKLIST_f b f) I" .
  next
    fix x
    assume "I x" "\<not> WORKLIST_b b x"
    with II1[of "fst x" "snd x"] II2[of "fst x"] show "P x"
      unfolding WORKLIST_b_def
      by (cases x, auto)
  qed

lemma WORKLISTIT_rule:
  assumes "I (s0, wl0)"
  assumes "wf R"
  assumes "\<And>s wl e. \<lbrakk>I (s, e # wl); b s\<rbrakk> \<Longrightarrow>
    f s e \<le> SPEC (\<lambda>s'N.
           I (fst s'N, (snd s'N) @ wl) \<and>
           ((fst s'N, s) \<in> R \<or> s'N = (s, [])))"
  assumes "\<And>s wl. \<lbrakk> I (s, wl); \<not>b s; wl \<noteq> [] \<rbrakk> \<Longrightarrow> P (s, wl)"
  assumes "\<And>s. I (s, []) \<Longrightarrow> P (s, [])"
  shows "WORKLISTIT I b f (s0, wl0) \<le> SPEC P"
  using assms
  apply (rule_tac WORKLISTIT_rule_manual)
  apply (simp_all add: WORKLIST_variant_exists_def WORKLIST_variant_OK_def)
  apply blast
done

definition WORKLISTIT_refine_rel where
  "WORKLISTIT_refine_rel Rs Re = Rs \<times>\<^sub>r (\<langle>Re\<rangle>list_rel)"

lemma WORKLISTIT_refine_rel_sv[simp,intro!,refine,relator_props]:
  "single_valued Rs \<Longrightarrow> single_valued Re \<Longrightarrow> single_valued (WORKLISTIT_refine_rel Rs Re)"
  unfolding WORKLISTIT_refine_rel_def
  by (tagged_solver)

lemma WORKLISTIT_refine_rel_in [simp] :
  "x \<in> WORKLISTIT_refine_rel R_s R_e \<longleftrightarrow>
   ((fst (fst x), fst (snd x)) \<in> R_s \<and>
    (snd (fst x), snd (snd x)) \<in> \<langle>R_e\<rangle>list_rel)"
unfolding WORKLISTIT_refine_rel_def
by (auto simp: refine_rel_defs)

lemma WORKLISTIT_refine[refine] :
assumes [relator_props]: "single_valued R_s" "single_valued R_e"
assumes I0: "(s0, s0') \<in> R_s" "(wl0, wl0') \<in> \<langle>R_e\<rangle>list_rel"
assumes I_OK: "\<And>s wl s' wl'. \<lbrakk>(s, s') \<in> R_s; (wl, wl') \<in> \<langle>R_e\<rangle>list_rel; I' (s', wl')\<rbrakk> \<Longrightarrow> I (s, wl)"
assumes b_OK: "\<And>s wl s' wl'. \<lbrakk>(s, s') \<in> R_s; (wl, wl') \<in> \<langle>R_e\<rangle>list_rel; I' (s', wl'); I (s, wl)\<rbrakk> \<Longrightarrow>
              b s = b' s'"
assumes f_OK: "\<And>s e s' e'. \<lbrakk>(s, s') \<in> R_s; (e, e') \<in> R_e; b s; b' s'\<rbrakk> \<Longrightarrow>
   f s e \<le> \<Down>(WORKLISTIT_refine_rel R_s R_e) (f' s' e')"
shows "WORKLISTIT I b f (s0, wl0) \<le> \<Down>(WORKLISTIT_refine_rel R_s R_e) (WORKLISTIT I' b' f' (s0', wl0'))"
unfolding WORKLISTIT_def
proof (rule WHILEIT_refine)
  show "((s0, wl0), s0', wl0') \<in> WORKLISTIT_refine_rel R_s R_e"
    using I0 by simp
next
  fix swl swl'
  assume in_R: "(swl, swl') \<in> WORKLISTIT_refine_rel R_s R_e"
  obtain s wl where swl_eq[simp]: "swl = (s, wl)" by fastforce
  obtain s' wl' where swl'_eq[simp]: "swl' = (s', wl')" by fastforce

  from in_R have in_Rs[simp]: "(s, s') \<in> R_s" and
                 in_Re[simp]: "(wl, wl') \<in> \<langle>R_e\<rangle>list_rel" by simp_all

  assume I_swl': "I' swl'"
  thus I_swl: "I swl" using I_OK[OF in_Rs in_Re] by simp

  from in_Re have "wl = [] \<longleftrightarrow> wl' = []"
    by (rule_tac iffI, simp_all add: refine_rel_defs)
  thus "WORKLIST_b b swl = WORKLIST_b b' swl'"
    unfolding WORKLIST_b_def
    using b_OK [OF in_Rs in_Re] I_swl I_swl' by simp

  assume b_swl: "WORKLIST_b b swl"
     and b_swl': "WORKLIST_b b' swl'"

  from b_swl obtain e wl_tl where wl_eq[simp]: "wl = e # wl_tl"
    unfolding WORKLIST_b_def by (simp, cases wl, blast)

  from b_swl' obtain e' wl_tl' where wl'_eq[simp]: "wl' = e' # wl_tl'"
    unfolding WORKLIST_b_def by (simp, cases wl', blast)

  from in_Re have in_Re': "(e, e') \<in> R_e"
    and in_Re'': "(wl_tl, wl_tl') \<in> \<langle>R_e\<rangle>list_rel"
    by (simp_all add: refine_rel_defs)

  from b_swl b_swl'
  show "WORKLIST_f b f swl \<le> \<Down> (WORKLISTIT_refine_rel R_s R_e) (WORKLIST_f b' f' swl')"
    unfolding WORKLIST_f_def WORKLIST_b_def
    apply simp
    apply (rule bind_refine [where ?R' = "(WORKLISTIT_refine_rel R_s R_e)"])
    apply (insert f_OK [OF in_Rs in_Re'], simp) []
    apply refine_rcg
    apply (insert in_Re'')
    apply (simp add: list_all2_appendI refine_rel_defs)
  done
qed

subsection \<open> Code Generation for Worklists \<close>

definition worklist where
  "worklist b f \<equiv> while (WORKLIST_b b)
     (\<lambda>x. let xa = hd (snd x); (a, b) = f (fst x) xa in (a, b @ tl (snd x)))"

lemma worklist_alt_Nil_def :
   "worklist b f (s, []) = (s, [])"
unfolding worklist_def WORKLIST_b_def
by (subst while_unfold, simp)

lemma worklist_alt_Cons_def :
   "worklist b f (s, e # wl) =
    (if (b s) then
       (let (s', N) = f s e in
       (worklist b f (s', N @ wl)))
     else (s, e # wl))"
unfolding worklist_def WORKLIST_b_def
apply (subst while_unfold)
apply (cases "f s e")
apply simp
done

lemmas worklist_alt_def [simp, code] = worklist_alt_Nil_def worklist_alt_Cons_def

lemma WORKLISTIT_cgt [refine_transfer]:
  assumes F_OK[refine_transfer]: "\<And>s e. RETURN (f s e) \<le> F s e"
  shows "RETURN (worklist b f (s, wl)) \<le> WORKLISTIT \<Phi> b F (s, wl)"
unfolding WORKLISTIT_def worklist_def WORKLIST_f_def
apply refine_transfer
done

lemma WORKLISTT_cgt [refine_transfer]:
  assumes F_OK: "\<And>s e. RETURN (f s e) \<le> F s e"
  shows "RETURN (worklist b f (s, wl)) \<le> WORKLISTT b F (s, wl)"
unfolding WORKLISTT_def
by (intro WORKLISTIT_cgt F_OK)

lemma WORKBAGIT_LIST_cgt :
  assumes RS:
    "\<And>s wl e. \<lbrakk> \<Phi> (s, multiset_of wl); b s; e \<in> set wl \<rbrakk> \<Longrightarrow>
        RETURN (f s e) \<le> \<Down>worklist_build_rel (f' s e)"
  shows "RETURN (worklist b f (s0, wl0)) \<le>
         \<Down>worklist_build_rel (WORKBAGIT \<Phi> b f' (s0, multiset_of wl0))"
proof -
  note step1 = WORKLISTIT_cgt[where f = f and b = b and s = s0 and wl = wl0]
  note step2 = order_trans [OF step1 WORKBAGIT_LIST_refine_simple]

  note step3 = step2[where \<Phi>1 = \<Phi> and ?f1 = "\<lambda>s e. RETURN (f s e)"]
  from step3 RS show ?thesis
    by simp
qed

subsubsection \<open> Sets \<close>

text \<open>
While worklist algorithm operate logically on multisets,
using sets is often semantically equivalent. Essentially it means that
only the first operation on an element is important and all others are
ignored. Reasoning about sets is much easier. Therefore, a version
using sets is defined as well in the following. \<close>

definition workset_update where
  "workset_update wb e N \<equiv> (wb - {e}) \<union> N"

definition WORKSET_b where
  "WORKSET_b b = (\<lambda>sws. snd sws \<noteq> {} \<and> b (fst sws))"

definition WORKSET_f ::
 "('s \<Rightarrow> bool) \<Rightarrow>
  ('s \<Rightarrow> 'e \<Rightarrow> ('s \<times> 'e set) nres) \<Rightarrow>
   's \<times> 'e set \<Rightarrow> ('s \<times> 'e set) nres" where
  "WORKSET_f b f = (\<lambda>sws. do {
     ASSERT (WORKSET_b b sws);
     e \<leftarrow> SPEC (\<lambda>e. e \<in> (snd sws));
     (s', N) \<leftarrow> f (fst sws) e;
     ASSERT (finite N);
     RETURN (s', workset_update (snd sws) e N)})"

definition WORKSET_I where
  "WORKSET_I I = (\<lambda>sws. finite (snd sws) \<and> I sws)"

definition WORKSETI ("WORKSETI\<^bsup>_\<^esup>") where
  "WORKSETI \<Phi> b f sws0 = WHILEI (WORKSET_I \<Phi>) (WORKSET_b b) (WORKSET_f b f) sws0"

definition WORKSET where "WORKSET \<equiv> WORKSETI (\<lambda>_. True)"

definition WORKSETIT ("WORKSETI\<^sub>T\<^bsup>_\<^esup>") where
  "WORKSETIT \<Phi> b f swb0 \<equiv> WHILEIT (WORKSET_I \<Phi>) (WORKSET_b b) (WORKSET_f b f) swb0"

definition WORKSETT ("WORKSET\<^sub>T") where "WORKSET\<^sub>T \<equiv> WORKSETIT (\<lambda>_. True)"

definition WORKSET_invar_OK where
  "WORKSET_invar_OK cond step invar =
   (\<forall>s ws e. invar (s, ws) \<and> e \<in> ws \<and> cond s \<longrightarrow>
             step s e \<le> SPEC (\<lambda>s'N. finite (snd s'N) \<and>
                            invar (fst s'N, (workset_update ws e (snd s'N)))))"

lemma WORKSET_invar_OK___lift_to_while :
assumes invar_OK: "WORKSET_invar_OK cond step invar"
shows "WHILE_invar_OK (WORKSET_b cond) (WORKSET_f cond step) (WORKSET_I invar)"
proof
  fix sws
  assume cond: "WORKSET_b cond sws"
     and invar: "WORKSET_I invar sws"
  obtain s ws where sws_eq[simp]: "sws = (s, ws)" by fastforce

  from cond invar invar_OK
  have invar_OK': "\<And>e. e \<in> ws \<Longrightarrow> step s e \<le> SPEC (\<lambda>s'N. finite (snd s'N) \<and>
         invar (fst s'N, workset_update ws e (snd s'N)))"
    unfolding WORKSET_invar_OK_def WORKSET_b_def WORKSET_I_def by simp

  from invar have "finite ws" unfolding WORKSET_I_def by simp
  hence spec_step: "\<And>e. e \<in> ws \<Longrightarrow> SPEC (\<lambda>s'N. finite (snd s'N) \<and>
         invar (fst s'N, workset_update ws e (snd s'N))) \<le>
         SPEC (\<lambda>xa. ASSERT (finite (snd xa)) \<bind>
                 (\<lambda>_. RETURN (fst xa, workset_update ws e (snd xa)))
                 \<le> SPEC (\<lambda>sws. finite (snd sws) \<and> invar sws))"
     by (simp add: subset_iff workset_update_def)

  from order_trans[OF invar_OK' spec_step]
  show "WORKSET_f cond step sws \<le> SPEC (WORKSET_I invar)"
    unfolding WORKSET_f_def WORKSET_I_def
    apply (intro refine_vcg cond)
    apply (simp add: split_beta)
  done
qed

definition WORKSET_variant_OK where
  "WORKSET_variant_OK cond step invar r \<equiv>
   (wf r \<and>
   (\<forall>s ws e. (invar (s, ws) \<and> e \<in> ws \<and> cond s \<longrightarrow>
     step s e \<le> SPEC (\<lambda>s'N. finite (snd s'N) \<and>
      (invar (fst s'N, (workset_update ws e (snd s'N)))) \<and>
      ((fst s'N, s) \<in> r \<or> ((s = fst s'N) \<and> snd s'N = {}))))))"

definition WORKSET_variant_exists where
  "WORKSET_variant_exists cond step invar \<equiv>
   \<exists>r. WORKSET_variant_OK cond step invar r"

lemma WORKSET_variant_OK___lift_to_while :
fixes invar :: "'S \<times> 'e set \<Rightarrow> bool"
assumes var_OK: "WORKSET_variant_OK cond step invar r"
shows "WHILE_variant_OK (WORKSET_b cond) (WORKSET_f cond step)
                        (WORKSET_I invar) (r <*lex*> measure card)"
proof
  {
    from var_OK have "wf r"
      unfolding WORKSET_variant_OK_def
      by fast
    with wf_subset_mset_rel
    show "wf (r <*lex*> measure card)" by auto
  }

  fix sws :: "'S \<times> 'e set"
  obtain s ws where sws_eq[simp]: "sws = (s, ws)" by fastforce

  assume invar_sws: "WORKSET_I invar sws"
     and cond_sws: "WORKSET_b cond sws"

  from var_OK invar_sws cond_sws have var_OK': "\<And>e. e \<in> ws \<Longrightarrow>
    step s e \<le> SPEC (\<lambda>s'N. finite (snd s'N) \<and> invar (fst s'N, workset_update ws e (snd s'N)) \<and>
             ((fst s'N, s) \<in> r \<or> s = fst s'N \<and> snd s'N = {}))"
    unfolding WORKSET_b_def WORKSET_variant_OK_def WORKSET_I_def by simp

  from invar_sws
  have spec_step: "\<And>e. e \<in> ws \<Longrightarrow>
        SPEC (\<lambda>s'N. finite (snd s'N) \<and> invar (fst s'N, workset_update ws e (snd s'N)) \<and>
             ((fst s'N, s) \<in> r \<or> s = fst s'N \<and> snd s'N = {})) \<le> SPEC
           (\<lambda>xa. ASSERT (finite (snd xa)) \<bind>
                 (\<lambda>_. RETURN (fst xa, workset_update ws e (snd xa)))
                 \<le> SPEC
                    (\<lambda>s'. WORKSET_I invar s' \<and>
                          (s', s, ws) \<in> r <*lex*> measure card)) "
    apply (auto simp add: subset_iff workset_update_def WORKSET_I_def)
    apply (metis card_gt_0_iff diff_Suc_less equals0D)
  done

  from order_trans [OF var_OK' spec_step]
  show "WORKSET_f cond step sws \<le> SPEC (\<lambda>s'. WORKSET_I invar s' \<and> (s', sws) \<in> r <*lex*> measure card)"
    unfolding WORKSET_f_def
    apply (intro refine_vcg cond_sws)
    apply (simp add: split_beta)
  done
qed

lemma WORKSET_variant_exists___lift_to_while :
"WORKSET_variant_exists cond step invar \<Longrightarrow>
 WHILE_variant_exists (WORKSET_b cond) (WORKSET_f cond step) (WORKSET_I invar)"
proof -
  assume "WORKSET_variant_exists cond step invar"
  then obtain r where "WORKSET_variant_OK cond step invar r"
    unfolding WORKSET_variant_exists_def by blast
  from WORKSET_variant_OK___lift_to_while[OF this]
  show "WHILE_variant_exists (WORKSET_b cond) (WORKSET_f cond step) (WORKSET_I invar)"
    unfolding WHILE_variant_exists_def by blast
qed

lemma WORKSETI_rule_manual:
  assumes I0_fin: "finite ws0"
  assumes I0: "I (s0, ws0)"
  assumes IS: "WORKSET_invar_OK b f I"
  assumes II1: "\<And>s ws. \<lbrakk> I (s, ws); finite ws; \<not>b s \<rbrakk> \<Longrightarrow> P (s, ws)"
  assumes II2: "\<And>s. I (s, {}) \<Longrightarrow> P (s, {})"
  shows "WORKSETI I b f (s0, ws0) \<le> SPEC P"
  unfolding WORKSETI_def
  proof (rule WHILEI_rule_manual)
    from I0 I0_fin show "WORKSET_I I (s0, ws0)" unfolding WORKSET_I_def by simp
  next
    from WORKSET_invar_OK___lift_to_while [OF IS]
    show "WHILE_invar_OK (WORKSET_b b) (WORKSET_f b f) (WORKSET_I I)" .
  next
    fix x
    assume "WORKSET_I I x" "\<not> WORKSET_b b x"
    with II1[of "fst x" "snd x"] II2[of "fst x"] show "P x"
      unfolding WORKSET_b_def WORKSET_I_def
      by (cases x, auto)
  qed

lemma WORKSETIT_rule_manual:
  assumes I0_fin: "finite ws0"
  assumes I0: "I (s0, ws0)"
  assumes IS: "WORKSET_variant_exists b f I"
  assumes II1: "\<And>s ws. \<lbrakk> I (s, ws); finite ws; \<not>b s \<rbrakk> \<Longrightarrow> P (s, ws)"
  assumes II2: "\<And>s. I (s, {}) \<Longrightarrow> P (s, {})"
  shows "WORKSETIT I b f (s0, ws0) \<le> SPEC P"
  unfolding WORKSETIT_def
  proof (rule WHILEIT_rule_manual)
    from I0 I0_fin show "WORKSET_I I (s0, ws0)" unfolding WORKSET_I_def by simp
  next
    from WORKSET_variant_exists___lift_to_while [OF IS]
    show "WHILE_variant_exists (WORKSET_b b) (WORKSET_f b f) (WORKSET_I I)" .
  next
    fix x
    assume "WORKSET_I I x" "\<not> WORKSET_b b x"
    with II1[of "fst x" "snd x"] II2[of "fst x"] show "P x"
      unfolding WORKSET_b_def WORKSET_I_def
      by (cases x, auto)
  qed

end


theory Non imports Main BoolRelations begin

abbreviation \<open>sc X Y i \<equiv> (\<forall>p \<in> set X. non_semantics i p) \<longrightarrow> (\<exists>q \<in> set Y. non_semantics i q)\<close>

function mp where
  \<open>mp A B (ProNon n # C) [] = mp (n # A) B C []\<close> |
  \<open>mp A B C (ProNon n # D) = mp A (n # B) C D\<close> |
  \<open>mp A B ((p \<up> q) # C) [] = (mp A B C [p] \<and> mp A B C [q])\<close> |
  \<open>mp A B C ((p \<up> q) # D) = mp A B (p # q # C) D\<close> |
  \<open>mp A B [] [] = common A B\<close>
  by pat_completeness auto
termination by (relation \<open>measure (\<lambda>(_,_,C,D). \<Sum>p \<leftarrow> C @ D. size p)\<close>) auto

theorem main: \<open>(\<forall>i. sc (map ProNon A @ C) (map ProNon B @ D) i) \<longleftrightarrow> mp A B C D\<close>
  by (induct rule: mp.induct) auto

definition \<open>prover p \<equiv> mp [] [] [] [p]\<close>

corollary \<open>(\<forall>i. non_semantics i p) \<longleftrightarrow> prover p\<close>
  unfolding prover_def by (simp flip: main)

definition \<open>main \<equiv> prover (ProNon () \<up> (ProNon () \<up> ProNon ()))\<close>

proposition main by code_simp

export_code main in Haskell

end


theory Preliminaries
  imports MDL
begin

section \<open>Formulas and Satisfiability\<close>

declare [[typedef_overloaded]]

context
begin

qualified datatype ('a, 't :: timestamp) formula = Bool bool | Atom 'a | Neg "('a, 't) formula" |
  Bin "bool \<Rightarrow> bool \<Rightarrow> bool" "('a, 't) formula" "('a, 't) formula" |
  Prev "'t \<I>" "('a, 't) formula" | Next "'t \<I>" "('a, 't) formula" |
  Since "('a, 't) formula" "'t \<I>" "('a, 't) formula" |
  Until "('a, 't) formula" "'t \<I>" "('a, 't) formula" |
  MatchP "'t \<I>" "('a, 't) regex" | MatchF "'t \<I>" "('a, 't) regex"
  and ('a, 't) regex = Test "('a, 't) formula" | Wild |
  Plus "('a, 't) regex" "('a, 't) regex" | Times "('a, 't) regex" "('a, 't) regex" |
  Star "('a, 't) regex"

end

fun mdl2mdl :: "('a, 't :: timestamp) Preliminaries.formula \<Rightarrow> ('a, 't) formula"
  and embed :: "('a, 't) Preliminaries.regex \<Rightarrow> ('a, 't) regex" where
  "mdl2mdl (Preliminaries.Bool b) = Bool b"
| "mdl2mdl (Preliminaries.Atom a) = Atom a"
| "mdl2mdl (Preliminaries.Neg phi) = Neg (mdl2mdl phi)"
| "mdl2mdl (Preliminaries.Bin f phi psi) = Bin f (mdl2mdl phi) (mdl2mdl psi)"
| "mdl2mdl (Preliminaries.Prev I phi) = Prev I (mdl2mdl phi)"
| "mdl2mdl (Preliminaries.Next I phi) = Next I (mdl2mdl phi)"
| "mdl2mdl (Preliminaries.Since phi I psi) = Since (mdl2mdl phi) I (mdl2mdl psi)"
| "mdl2mdl (Preliminaries.Until phi I psi) = Until (mdl2mdl phi) I (mdl2mdl psi)"
| "mdl2mdl (Preliminaries.MatchP I r) = MatchP I (Times (embed r) (Symbol (Bool True)))"
| "mdl2mdl (Preliminaries.MatchF I r) = MatchF I (Times (embed r) (Symbol (Bool True)))"
| "embed (Preliminaries.Test phi) = Lookahead (mdl2mdl phi)"
| "embed Preliminaries.Wild = Symbol (Bool True)"
| "embed (Preliminaries.Plus r s) = Plus (embed r) (embed s)"
| "embed (Preliminaries.Times r s) = Times (embed r) (embed s)"
| "embed (Preliminaries.Star r) = Star (embed r)"

lemma mdl2mdl_wf:
  fixes phi :: "('a, 't :: timestamp) Preliminaries.formula"
  shows "wf_fmla (mdl2mdl phi)"
  by (induction phi rule: mdl2mdl_embed.induct(1)[where ?Q="\<lambda>r. wf_regex (Times (embed r) (Symbol (Bool True))) \<and> (\<forall>phi \<in> atms (embed r). wf_fmla phi)"]) auto

fun embed' :: "(('a, 't :: timestamp) formula \<Rightarrow> ('a, 't) Preliminaries.formula) \<Rightarrow> ('a, 't) regex \<Rightarrow> ('a, 't) Preliminaries.regex" where
  "embed' f (Lookahead phi) = Preliminaries.Test (f phi)"
| "embed' f (Symbol phi) = Preliminaries.Times (Preliminaries.Test (f phi)) Preliminaries.Wild"
| "embed' f (Plus r s) = Preliminaries.Plus (embed' f r) (embed' f s)"
| "embed' f (Times r s) = Preliminaries.Times (embed' f r) (embed' f s)"
| "embed' f (Star r) = Preliminaries.Star (embed' f r)"

lemma embed'_cong[fundef_cong]: "(\<And>phi. phi \<in> atms r \<Longrightarrow> f phi = f' phi) \<Longrightarrow> embed' f r = embed' f' r"
  by (induction r) auto

fun mdl2mdl' :: "('a, 't :: timestamp) formula \<Rightarrow> ('a, 't) Preliminaries.formula" where
  "mdl2mdl' (Bool b) = Preliminaries.Bool b"
| "mdl2mdl' (Atom a) = Preliminaries.Atom a"
| "mdl2mdl' (Neg phi) = Preliminaries.Neg (mdl2mdl' phi)"
| "mdl2mdl' (Bin f phi psi) = Preliminaries.Bin f (mdl2mdl' phi) (mdl2mdl' psi)"
| "mdl2mdl' (Prev I phi) = Preliminaries.Prev I (mdl2mdl' phi)"
| "mdl2mdl' (Next I phi) = Preliminaries.Next I (mdl2mdl' phi)"
| "mdl2mdl' (Since phi I psi) = Preliminaries.Since (mdl2mdl' phi) I (mdl2mdl' psi)"
| "mdl2mdl' (Until phi I psi) = Preliminaries.Until (mdl2mdl' phi) I (mdl2mdl' psi)"
| "mdl2mdl' (MatchP I r) = Preliminaries.MatchP I (embed' mdl2mdl' (rderive r))"
| "mdl2mdl' (MatchF I r) = Preliminaries.MatchF I (embed' mdl2mdl' (rderive r))"

context MDL
begin

fun rvsat :: "('a, 't) Preliminaries.formula \<Rightarrow> nat \<Rightarrow> bool"
  and rvmatch :: "('a, 't) Preliminaries.regex \<Rightarrow> (nat \<times> nat) set" where
  "rvsat (Preliminaries.Bool b) i = b"
| "rvsat (Preliminaries.Atom a) i = (a \<in> \<Gamma> \<sigma> i)"
| "rvsat (Preliminaries.Neg \<phi>) i = (\<not> rvsat \<phi> i)"
| "rvsat (Preliminaries.Bin f \<phi> \<psi>) i = (f (rvsat \<phi> i) (rvsat \<psi> i))"
| "rvsat (Preliminaries.Prev I \<phi>) i = (case i of 0 \<Rightarrow> False | Suc j \<Rightarrow> mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> rvsat \<phi> j)"
| "rvsat (Preliminaries.Next I \<phi>) i = (mem (\<tau> \<sigma> i) (\<tau> \<sigma> (Suc i)) I \<and> rvsat \<phi> (Suc i))"
| "rvsat (Preliminaries.Since \<phi> I \<psi>) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> rvsat \<psi> j \<and> (\<forall>k \<in> {j<..i}. rvsat \<phi> k))"
| "rvsat (Preliminaries.Until \<phi> I \<psi>) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> rvsat \<psi> j \<and> (\<forall>k \<in> {i..<j}. rvsat \<phi> k))"
| "rvsat (Preliminaries.MatchP I r) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> (j, i) \<in> rvmatch r)"
| "rvsat (Preliminaries.MatchF I r) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> (i, j) \<in> rvmatch r)"
| "rvmatch (Preliminaries.Test \<phi>) = {(i, i) | i. rvsat \<phi> i}"
| "rvmatch Preliminaries.Wild = {(i, i + 1) | i. True}"
| "rvmatch (Preliminaries.Plus r s) = rvmatch r \<union> rvmatch s"
| "rvmatch (Preliminaries.Times r s) = rvmatch r O rvmatch s"
| "rvmatch (Preliminaries.Star r) = rtrancl (rvmatch r)"

lemma mdl2mdl_equivalent:
  fixes phi :: "('a, 't :: timestamp) Preliminaries.formula"
  shows "\<And>i. sat (mdl2mdl phi) i \<longleftrightarrow> rvsat phi i"
  by (induction phi rule: mdl2mdl_embed.induct(1)[where ?Q="\<lambda>r. match (embed r) = rvmatch r"]) (auto split: nat.splits)

lemma mdlstar2mdl:
  fixes phi :: "('a, 't :: timestamp) Preliminaries.formula"
  shows "wf_fmla (mdl2mdl phi)" "\<And>i. sat (mdl2mdl phi) i \<longleftrightarrow> rvsat phi i"
  apply (rule mdl2mdl_wf)
  apply (rule mdl2mdl_equivalent)
  done

lemma rvmatch_embed':
  assumes "\<And>phi i. phi \<in> atms r \<Longrightarrow> rvsat (mdl2mdl' phi) i \<longleftrightarrow> sat phi i"
  shows "rvmatch (embed' mdl2mdl' r) = match r"
  using assms
  by (induction r) auto

lemma mdl2mdlstar:
  fixes phi :: "('a, 't :: timestamp) formula"
  assumes "wf_fmla phi"
  shows "\<And>i. rvsat (mdl2mdl' phi) i \<longleftrightarrow> sat phi i"
  using assms
  apply (induction phi rule: mdl2mdl'.induct)
                apply (auto split: nat.splits)[8]
  subgoal for I r i
    by auto (metis atms_rderive match_rderive rvmatch_embed' wf_fmla.simps(1))+
  subgoal for I r i
    by auto (metis atms_rderive match_rderive rvmatch_embed' wf_fmla.simps(1))+
  done

end

end


theory TC_To_XC
imports  "Karp21.TC_To_ChrN" XC_Definition
begin

definition "TC_XC E \<equiv> (if ugraph E
  then (let X = {(v, opt, c). v \<in> \<Union>E
                \<and> (opt = None \<or> (\<exists>u. {v, u} \<in> E \<longrightarrow> opt = Some u) \<or> opt = Some v)
                \<and> (\<exists>c_sets. disjoint c_sets \<and> c \<in> c_sets \<and> card c = 3)};
            S = {}
             in (X,S))
  else ({}, {}))"
(*refinement necessary
{{u_trip, p} | u_trip p. u_trip \<noteq> p \<and> u_trip \<in> X \<and> (\<exists>u c. u_trip = (u, Some u, 3) \<and> p = (u, None, c))}
                \<union> {{p1, p2} | p1 p2. p1 \<noteq> p2 \<and> p1 \<in> X \<and> p2 \<in> X \<and> (\<exists>u v c1 c2. p1 = (v, Some u, c1) \<and> p2 = (u, Some v, c2) \<and> c1 \<noteq> c2)}
                \<union> {{(v, opt, c). opt = None \<or> (\<exists>u. {v, u} \<in> E \<longrightarrow> opt = Some u) \<and> c \<in> {0, 1, 2}} | v. v \<in> \<Union>E}
*)

lemma "({}, {}) \<in> exact_cover"
unfolding exact_cover_def by blast

lemma TC_XC_sound: "E \<in> three_colorability \<Longrightarrow> (TC_XC E) \<in> exact_cover'"
unfolding TC_XC_def apply (auto split: prod.splits)
sorry

(*proof of soundness understood, problem and refinement goal:
the definition of \<chi> does not involve a set of colors, but a direct partition of vertexes*)

lemma TC_XC_complete: "(TC_XC E) \<in> exact_cover' \<Longrightarrow> E \<in> three_colorability"
sorry

lemma "is_reduction TC_XC three_colorability exact_cover'"
using TC_XC_sound TC_XC_complete unfolding is_reduction_def by blast

(*proof of completeness understood, problem: the proof far away from the definition of
the three coloarbility, a formalisation and abstraction is necessary*)

end