header{* Guard-Based Encodings  *}
theory G
imports T_G_Prelim Mcalc2C
begin

subsection{* The guard translation *}

text{* The extension of the function symbols with type witnesses: *}

datatype ('fsym,'tp) efsym = Oldf 'fsym | Wit 'tp

text{* The extension of the predicate symbols with type guards: *}

datatype ('psym,'tp) epsym = Oldp 'psym | Guard 'tp

text{* Extension of the partitioned infinitely augmented problem
for dealing with guards: *}

locale ProblemIkTpartG =
Ik : ProblemIkTpart wtFsym wtPsym arOf resOf parOf \<Phi> infTp prot protFw
for wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and prot and protFw +
fixes (* Further refinement of prot: *)
    protCl :: "'tp \<Rightarrow> bool" (* types aimed to be classically protected *)
assumes
    protCl_prot[simp]: "\<And> \<sigma>. protCl \<sigma> \<Longrightarrow> prot \<sigma>"
    (* In order to add classical (implicational) guards, one needs
      backwards closure on the ranks of function symbols*)
and protCl_fsym: "\<And> f. protCl (resPf f) \<Longrightarrow> list_all protCl (arOf f)"

locale ModelIkTpartG =
Ik : ProblemIkTpartG wtFsym wtPsym arOf resOf parOf \<Phi> infTp prot protFw protCl +
Ik : ModelIkTpart wtFsym wtPsym arOf resOf parOf \<Phi> infTp prot protFw intT intF intP
for wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and prot and protFw and protCl
and intT and intF and intP

context ProblemIkTpartG
begin

lemma protCl_resOf_arOf[simp]:
assumes "protCl (resOf f)" and "i < length (arOf f)"
shows "protCl (arOf f ! i)"
using assms protCl_fsym unfolding list_all_length by auto

text{* ``GE'' stands for ``guard encoding'': *}

fun GE_wtFsym where
 "GE_wtFsym (Oldf f) \<longleftrightarrow> wtFsym f"
|"GE_wtFsym (Wit \<sigma>) \<longleftrightarrow> \<not> isRes \<sigma> \<or> protCl \<sigma>"

fun GE_arOf where
 "GE_arOf (Oldf f) = arOf f"
|"GE_arOf (Wit \<sigma>) = []"

fun GE_resOf where
 "GE_resOf (Oldf f) = resOf f"
|"GE_resOf (Wit \<sigma>) = \<sigma>"

fun GE_wtPsym where
 "GE_wtPsym (Oldp p) \<longleftrightarrow> wtPsym p"
|"GE_wtPsym (Guard \<sigma>) \<longleftrightarrow> \<not> unprot \<sigma>"

fun GE_parOf where
 "GE_parOf (Oldp p) = parOf p"
|"GE_parOf (Guard \<sigma>) = [\<sigma>]"

lemma countable_GE_wtFsym: "countable (Collect GE_wtFsym)" (is "countable ?K")
proof-
  let ?F = "\<lambda> ef. case ef of Oldf f \<Rightarrow> Inl f | Wit \<sigma> \<Rightarrow> Inr \<sigma>"
  let ?U = "UNIV::'tp set"  let ?L = "(Collect wtFsym) <+> ?U"
  have "inj_on ?F ?K" unfolding inj_on_def apply clarify
  apply(case_tac x, simp_all) by (case_tac y, simp_all)+
  moreover have "?F ` ?K \<subseteq> ?L" apply clarify by (case_tac ef, auto)
  ultimately have "|?K| \<le>o |?L|" unfolding card_of_ordLeq[symmetric] by auto
  moreover have "countable ?L" using countable_wtFsym countable_tp
  by (metis countable_Plus)
  ultimately show ?thesis by(rule countable_ordLeq)
qed

end (* context ProblemIkTpartG *)

sublocale ProblemIkTpartG < GE : Signature
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym
and arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
apply default
using countable_tp countable_GE_wtFsym countable_GE_wtPsym by auto

context ProblemIkTpartG
begin

text{* The guarding literal of a variable: *}

definition grdLit :: "var \<Rightarrow> (('fsym, 'tp) efsym, ('psym, 'tp) epsym) lit"
where "grdLit x \<equiv> Neg (Pr (Guard (tpOfV x)) [Var x])"

text{* The (set of) guarding literals of a literal and of a clause: *}

(* of a literal: *)
fun glitOfL ::
"('fsym, 'psym) lit \<Rightarrow> (('fsym, 'tp) efsym, ('psym, 'tp) epsym) lit set"
where
"glitOfL (Pos at) =
 {grdLit x | x. x \<in> varsA at \<and> (prot (tpOfV x) \<or> (protFw (tpOfV x) \<and> x \<in> nvA at))}"
|
"glitOfL (Neg at) = {grdLit x | x. x \<in> varsA at \<and> prot (tpOfV x)}"

(* of a clause: *)
definition "glitOfC c \<equiv> \<Union> set (map glitOfL c)"

lemma finite_glitOfL[simp]: "finite (glitOfL l)"
proof-
  have "glitOfL l \<subseteq> grdLit ` {x . x \<in> varsL l}" by (cases l, auto)
  thus ?thesis by (metis Collect_mem_eq finite_surj finite_varsL)
qed

lemma finite_glitOfC[simp]: "finite (glitOfC c)"
unfolding glitOfC_def apply(rule finite_Union) using finite_glitOfL by auto

fun gT where
"gT (Var x) = Var x"
|
"gT (Fn f Tl) = Fn (Oldf f) (map gT Tl)"

fun gA where
"gA (Eq T1 T2) = Eq (gT T1) (gT T2)"
|
"gA (Pr p Tl) = Pr (Oldp p) (map gT Tl)"

fun gL where
"gL (Pos at) = Pos (gA at)"
|
"gL (Neg at) = Neg (gA at)"

definition "gC c \<equiv> (map gL c) @ (list (glitOfC c))"

lemma set_gC[simp]: "set (gC c) = gL ` (set c) \<union> glitOfC c"
unfolding gC_def by simp

text{* The extra axioms: *}

text{* The function axioms: *}

(* conclusion (atom): *)
definition "cOfFax f = Pr (Guard (resOf f)) [Fn (Oldf f) (getTvars (arOf f))]"
(* hypotheses (list of atoms): *)
definition "hOfFax f = map2 (Pr o Guard) (arOf f) (map singl (getTvars (arOf f)))"
(* The axiom (clause) for non-classically-decorated (lightweight and featherweigh) types: *)
definition "fax f \<equiv> [Pos (cOfFax f)]"
(* The axiom (clause) for classically-decorated types: *)
definition "faxCD f \<equiv> map Neg (hOfFax f) @ fax f"
(* The set of axioms: *)
definition
"Fax \<equiv> {fax f | f. wtFsym f \<and> \<not> unprot (resOf f) \<and> \<not> protCl (resOf f)} \<union>
       {faxCD f | f. wtFsym f \<and> protCl (resOf f)}"

text{* The witness axioms: *}

(* The axiom (clause): *)
definition "wax \<sigma> \<equiv> [Pos (Pr (Guard \<sigma>) [Fn (Wit \<sigma>) []])]"
(* The set of axioms: *)
definition "Wax \<equiv> {wax \<sigma> | \<sigma>. \<not> unprot \<sigma> \<and> (\<not> isRes \<sigma> \<or> protCl \<sigma>)}"

definition "gPB = gC ` \<Phi> \<union> Fax \<union> Wax"

text{* Well-typedness of the translation: *}

lemma tpOf_g[simp]: "GE.tpOf (gT T) = Ik.tpOf T"
by (cases T) auto

lemma wt_g[simp]: "Ik.wt T \<Longrightarrow> GE.wt (gT T)"
by (induct T, auto simp add: list_all_iff)

lemma wtA_gA[simp]: "Ik.wtA at \<Longrightarrow> GE.wtA (gA at)"
by (cases at, auto simp add: list_all_iff)

lemma wtL_gL[simp]: "Ik.wtL l \<Longrightarrow> GE.wtL (gL l)"
by (cases l, auto)

lemma wtC_map_gL[simp]: "Ik.wtC c \<Longrightarrow> GE.wtC (map gL c)"
unfolding Ik.wtC_def GE.wtC_def by (induct c, auto)

lemma wtL_grdLit_unprot[simp]: "\<not> unprot (tpOfV x) \<Longrightarrow> GE.wtL (grdLit x)"
unfolding grdLit_def by auto

lemma wtL_grdLit[simp]: "prot (tpOfV x) \<or> protFw (tpOfV x) \<Longrightarrow> GE.wtL (grdLit x)"
apply(rule wtL_grdLit_unprot) unfolding unprot_def by auto

lemma wtL_glitOfL[simp]: "l' \<in> glitOfL l \<Longrightarrow> GE.wtL l'"
by (cases l, auto)

lemma wtL_glitOfC[simp]: "l' \<in> glitOfC c \<Longrightarrow> GE.wtL l'"
unfolding glitOfC_def GE.wtC_def by (induct c, auto)

lemma wtC_list_glitOfC[simp]: "GE.wtC (list (glitOfC c))"
unfolding glitOfC_def GE.wtC_def by auto

lemma wtC_gC[simp]: "Ik.wtC c \<Longrightarrow> GE.wtC (gC c)"
unfolding gC_def by simp

lemma wtA_cOfFax_unprot[simp]: "\<lbrakk>wtFsym f; \<not> unprot (resOf f)\<rbrakk> \<Longrightarrow> GE.wtA (cOfFax f)"
unfolding cOfFax_def by simp

lemma wtA_cOfFax[simp]:
"\<lbrakk>wtFsym f; prot (resOf f) \<or> protFw (resOf f)\<rbrakk> \<Longrightarrow> GE.wtA (cOfFax f)"
apply(rule wtA_cOfFax_unprot) unfolding unprot_def by auto

lemma wtA_hOfFax[simp]:
"\<lbrakk>wtFsym f; protCl (resOf f)\<rbrakk> \<Longrightarrow> list_all GE.wtA (hOfFax f)"
unfolding hOfFax_def unfolding list_all_length
by (auto simp add: singl_def unprot_def)

lemma wtC_fax_unprot[simp]: "\<lbrakk>wtFsym f; \<not> unprot (resOf f)\<rbrakk> \<Longrightarrow> GE.wtC (fax f)"
unfolding fax_def GE.wtC_def by auto

lemma wtC_fax[simp]: "\<lbrakk>wtFsym f; prot (resOf f) \<or> protFw (resOf f)\<rbrakk> \<Longrightarrow> GE.wtC (fax f)"
apply(rule wtC_fax_unprot) unfolding unprot_def by auto

lemma wtC_faxCD[simp]: "\<lbrakk>wtFsym f; protCl (resOf f)\<rbrakk> \<Longrightarrow> GE.wtC (faxCD f)"
unfolding faxCD_def GE.wtC_append apply(rule conjI)
  using wtA_hOfFax[unfolded list_all_length] apply(simp add: GE.wtC_def list_all_length)
  by simp

lemma wtPB_Fax[simp]: "GE.wtPB Fax"
unfolding Fax_def GE.wtPB_def by auto

lemma wtC_wax_unprot[simp]: "\<lbrakk>\<not> unprot \<sigma>; \<not> isRes \<sigma> \<or> protCl \<sigma>\<rbrakk> \<Longrightarrow> GE.wtC (wax \<sigma>)"
unfolding wax_def GE.wtC_def by simp

lemma wtC_wax[simp]: "\<lbrakk>prot \<sigma> \<or> protFw \<sigma>; \<not> isRes \<sigma> \<or> protCl \<sigma>\<rbrakk> \<Longrightarrow> GE.wtC (wax \<sigma>)"
apply(rule wtC_wax_unprot) unfolding unprot_def by auto

lemma wtPB_Wax[simp]: "GE.wtPB Wax"
unfolding Wax_def GE.wtPB_def by auto

lemma wtPB_gC_\<Phi>[simp]: "GE.wtPB (gC ` \<Phi>)"
using Ik.wt_\<Phi> unfolding Ik.wtPB_def GE.wtPB_def by auto

lemma wtA_Guard:
assumes "GE.wtA (Pr (Guard \<sigma>) Tl)"
shows "\<exists> T. Tl = [T] \<and> GE.wt T \<and> tpOf T = \<sigma>"
using assms by simp (metis (hide_lams, no_types) list.inject map_eq_Cons_conv
                           list_all_simps map_is_Nil_conv neq_Nil_conv)

lemma tpOf_Wit: "GE.tpOf (Fn (Wit \<sigma>) Tl) = \<sigma>" by simp

end (* context ProblemIkTpartG *)

subsection{* Soundness *}

context ModelIkTpartG begin

(* The identity-guard extension of a given structure of the original signature *)
fun GE_intF where
 "GE_intF (Oldf f) al = intF f al"
|"GE_intF (Wit \<sigma>) al = pickT \<sigma>"
(* note: for witnesses, we only care about al being [] *)

fun GE_intP where
 "GE_intP (Oldp p) al = intP p al"
|"GE_intP (Guard \<sigma>) al = True"
(* note: for guards, we only care about al being a singleton *)

end (* context ModelIkTpartG *)

sublocale ModelIkTpartG < GE : Struct
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym and
arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
and intF = GE_intF and intP = GE_intP
proof default
  fix ef al assume "GE_wtFsym ef" and "list_all2 intT (GE_arOf ef) al"
  thus "intT (GE_resOf ef) (GE_intF ef al)"
  using intF by (cases ef, auto)
qed auto

context ModelIkTpartG begin

lemma g_int[simp]: "GE.int \<xi> (gT T) = Ik.int \<xi> T"
proof (induct T)
  case (Fn f Tl)
  hence 0: "map (GE.int \<xi> \<circ> gT) Tl = map (Ik.int \<xi>) Tl"
  unfolding list_eq_iff list_all_iff by auto
  show ?case by (simp add: 0)
qed auto

lemma map_g_int[simp]: "map (GE.int \<xi> \<circ> gT) Tl = map (Ik.int \<xi>) Tl"
unfolding list_eq_iff list_all_iff by auto

lemma gA_satA[simp]: "GE.satA \<xi> (gA at) \<longleftrightarrow> Ik.satA \<xi> at"
apply(cases at) by auto

lemma gL_satL[simp]: "GE.satL \<xi> (gL l) \<longleftrightarrow> Ik.satL \<xi> l"
apply(cases l) by auto

lemma map_gL_satC[simp]: "GE.satC \<xi> (map gL c) \<longleftrightarrow> Ik.satC \<xi> c"
unfolding GE.satC_def Ik.satC_def by (induct c, auto)

lemma gC_satC[simp]:
assumes "Ik.satC \<xi> c"  shows "GE.satC \<xi> (gC c)"
using assms unfolding gC_def by simp

lemma gC_\<Phi>_satPB[simp]:
assumes "Ik.satPB \<xi> \<Phi>"  shows "GE.satPB \<xi> (gC ` \<Phi>)"
using assms unfolding GE.satPB_def Ik.satPB_def by auto

lemma Fax_Wax_satPB:
"GE.satPB \<xi> (Fax) \<and> GE.satPB \<xi> (Wax)"
unfolding GE.satPB_def GE.satC_def Fax_def Wax_def
by (auto simp add: cOfFax_def hOfFax_def fax_def faxCD_def wax_def)

lemmas Fax_satPB[simp] = Fax_Wax_satPB[THEN conjunct1]
lemmas Wax_satPB[simp] = Fax_Wax_satPB[THEN conjunct2]

end (* context ModelIkTpartG *)

(* Soundness theorem in sublocale form: Given a problem (with indicated
type partition) and a model for it, we obtain a model of the tag-extended (GE)
problem: *)
sublocale ModelIkTpartG < GE : Model
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym and
arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
and \<Phi> = gPB and intF = GE_intF and intP = GE_intP
using G_soundness .

subsection{* Completeness  *}

(* Problem with type partition and model of its guard-encoding translation: *)
locale ProblemIkTpartG_GEModel =
Ik : ProblemIkTpartG wtFsym wtPsym arOf resOf parOf \<Phi> infTp prot protFw protCl +
GE : Model "ProblemIkTpartG.GE_wtFsym wtFsym resOf protCl"
           "ProblemIkTpartG.GE_wtPsym wtPsym prot protFw"
           "ProblemIkTpartG.GE_arOf arOf" "ProblemIkTpartG.GE_resOf resOf"
           "ProblemIkTpartG.GE_parOf parOf"
           gPB eintT eintF eintP
for wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and prot and protFw and protCl
and eintT and eintF and eintP

context ProblemIkTpartG_GEModel begin

text{* The reduct structure of a given structure in the guard-extended signature: *}
definition
"intT \<sigma> a \<equiv>
 if unprot \<sigma> then eintT \<sigma> a
 else eintT \<sigma> a \<and> eintP (Guard \<sigma>) [a]"
definition
"intF f al \<equiv> eintF (Oldf f) al"
definition
"intP p al \<equiv> eintP (Oldp p) al"

(* Semantic rephrasings of the fact that the (guarded problem) model satisfies
   Fax and Wax *)
lemma GE_Guard_all: (* fixme: messy proof *)
assumes f: "wtFsym f"
and al: "list_all2 eintT (arOf f) al"
shows
"(\<not> unprot (resOf f) \<and> \<not> protCl (resOf f)
  \<longrightarrow> eintP (Guard (resOf f)) [eintF (Oldf f) al])
 \<and>
 (protCl (resOf f) \<longrightarrow>
  list_all2 (eintP \<circ> Guard) (arOf f) (map singl al)
  \<longrightarrow> eintP (Guard (resOf f)) [eintF (Oldf f) al])"
(is "(?A1 \<longrightarrow> ?C) \<and>
     (?A2 \<longrightarrow> ?H2 \<longrightarrow> ?C)")
proof(intro conjI impI)
  def xl \<equiv> "getVars (arOf f)"
  have l[simp]: "length xl = length al" "length al = length (arOf f)"
                "length (getTvars (arOf f)) = length (arOf f)"
  unfolding xl_def using al unfolding list_all2_iff by auto
  have 1[simp]: "\<And> i. i < length (arOf f) \<Longrightarrow> tpOfV (xl!i) = (arOf f)!i"
  unfolding xl_def by auto
  have xl[simp]: "distinct xl" unfolding xl_def using distinct_getVars by auto
  def \<xi> \<equiv> "pickE xl al"
  have \<xi>: "GE.wtE \<xi>" unfolding \<xi>_def apply(rule wtE_pickE) using al list_all2_nthD by auto
  have [simp]: "\<And> i. i < length (arOf f) \<Longrightarrow> \<xi> (xl ! i) = al ! i"
  using al unfolding \<xi>_def by (auto simp: list_all2_length intro: pickE)
  have 0: "map (GE.int \<xi>) (getTvars (arOf f)) = al"
  apply(rule nth_equalityI)
  using al by (auto simp: list_all2_length getTvars_def xl_def[symmetric])
  have 1:
  "GE.satC \<xi> (map Neg (map2 (Pr \<circ> Guard) (arOf f) (map singl (getTvars (arOf f))))) \<longleftrightarrow>
   \<not> list_all2 (eintP \<circ> Guard) (arOf f) (map singl al)"
  unfolding GE.satC_def list_ex_length list_all2_map2 singl_def
  unfolding list_all2_length
  by (auto simp add: map2_def map_zip_map2 singl_def getTvars_def xl_def[symmetric])
  have Fax: "GE.satPB \<xi> Fax" using GE.sat_\<Phi>[OF \<xi>] unfolding gPB_def by simp
  {assume ?A1
   hence "GE.satC \<xi> (fax f)" using f Fax unfolding GE.satPB_def Fax_def by auto
   thus ?C unfolding fax_def cOfFax_def GE.satC_def by (simp add: 0)
  }
  {assume ?A2 and ?H2
   hence "GE.satC \<xi> (faxCD f)" using f Fax unfolding GE.satPB_def Fax_def by auto
   thus ?C using `?H2`
   unfolding faxCD_def fax_def cOfFax_def hOfFax_def
   unfolding GE.satC_append 1 unfolding GE.satC_def by (simp add: 0)
  }
qed

lemma GE_Guard_not_unprot_protCl:
assumes f: "wtFsym f" and f2: "\<not> unprot (resOf f)" "\<not> protCl (resOf f)"
and al: "list_all2 eintT (arOf f) al"
shows "eintP (Guard (resOf f)) [intF f al]"
using GE_Guard_all[OF f al] f2 unfolding intF_def by auto

lemma GE_Guard_protCl:
assumes f: "wtFsym f" and f2: "protCl (resOf f)" and al: "list_all2 eintT (arOf f) al"
and H: "list_all2 (eintP \<circ> Guard) (arOf f) (map singl al)"
shows "eintP (Guard (resOf f)) [intF f al]"
using GE_Guard_all[OF f al] f2 H unfolding intF_def by auto

lemma GE_Guard_not_unprot:
assumes f: "wtFsym f" and f2: "\<not> unprot (resOf f)" and al: "list_all2 eintT (arOf f) al"
and H: "list_all2 (eintP \<circ> Guard) (arOf f) (map singl al)"
shows "eintP (Guard (resOf f)) [intF f al]"
apply(cases "protCl (resOf f)")
  using GE_Guard_protCl[OF f _ al H] apply fastforce
  using GE_Guard_not_unprot_protCl[OF f f2 _ al] by simp

lemma GE_Wit:
assumes \<sigma>: "\<not> unprot \<sigma>" "\<not> isRes \<sigma> \<or> protCl \<sigma>"
shows "eintP (Guard \<sigma>) [eintF (Wit \<sigma>) []]"
proof-
  def \<xi> \<equiv> "pickE [] []"
  have \<xi>: "GE.wtE \<xi>" unfolding \<xi>_def apply(rule wtE_pickE) by auto
  have "GE.satPB \<xi> Wax" using GE.sat_\<Phi>[OF \<xi>] unfolding gPB_def by simp
  hence "GE.satC \<xi> (wax \<sigma>)" unfolding Wax_def GE.satPB_def using \<sigma> by auto
  thus ?thesis unfolding satC_def wax_def by simp
qed

lemma NE_intT_forget: "NE (intT \<sigma>)"
proof-
  obtain a where a: "eintT \<sigma> a" using GE.NE_intT by blast
  show ?thesis proof(cases "unprot \<sigma>")
    case True thus ?thesis using a unfolding intT_def by auto
  next
    case False note unprot = False show ?thesis proof(cases "isRes \<sigma>")
      case True then obtain f where f: "wtFsym f" and \<sigma>: "\<sigma> = resOf f"
      unfolding isRes_def by auto
      def al \<equiv> "map pickT (arOf f)"  have al: "list_all2 eintT (arOf f) al"
      unfolding al_def list_all2_map2 unfolding list_all2_length by auto
      def a \<equiv> "intF f al"
      have a: "eintT \<sigma> a" unfolding a_def \<sigma> intF_def using f al
      by (metis GE_arOf.simps GE_resOf.simps GE_wtFsym.simps GE.intF)
      show ?thesis proof (cases "protCl \<sigma>")
        case True def a \<equiv> "eintF (Wit \<sigma>) []"
        have "eintT \<sigma> a" unfolding a_def
        by (metis True GE_arOf.simps GE_resOf.simps GE_wtFsym.simps intF list_all2_Nil)
        moreover have "eintP (Guard \<sigma>) [a]"
        unfolding a_def using GE_Wit[OF unprot] True by simp
        ultimately show ?thesis using unprot unfolding intT_def by auto
      next
        case False
        hence "eintP (Guard \<sigma>) [a]"
        using unprot GE_Guard_not_unprot_protCl[OF f _ _ al] unfolding \<sigma> a_def by simp
        thus ?thesis using unprot a unfolding intT_def by auto
      qed
    next
      case False def a \<equiv> "eintF (Wit \<sigma>) []"
      have "eintT \<sigma> a" unfolding a_def
      by (metis False GE_arOf.simps GE_resOf.simps GE_wtFsym.simps intF list_all2_Nil)
      moreover have "eintP (Guard \<sigma>) [a]"
      unfolding a_def using GE_Wit[OF unprot] False by simp
      ultimately show ?thesis using unprot unfolding intT_def by auto
    qed
  qed
qed

lemma wt_intF:
assumes f: "wtFsym f" and al: "list_all2 intT (arOf f) al"
shows "intT (resOf f) (intF f al)"
proof-
  have 0: "list_all2 eintT (arOf f) al"
  using al unfolding intT_def[abs_def] list_all2_length by metis
  hence "eintT (resOf f) (eintF (Oldf f) al)"
  by (metis GE_arOf.simps GE_resOf.simps GE_wtFsym.simps f al GE.intF)
  hence 1: "eintT (resOf f) (intF f al)" unfolding intF_def by simp
  show ?thesis  proof(cases "unprot (resOf f)")
    case True thus ?thesis unfolding intT_def by (simp add: 1)
  next
    case False note unprot = False
    have "eintP (Guard (resOf f)) [intF f al]"
    proof(cases "protCl (resOf f)")
      case False show ?thesis using GE_Guard_not_unprot_protCl[OF f unprot False 0] .
    next
      case True
      hence "list_all protCl (arOf f)" using protCl_fsym by simp
      hence "list_all (\<lambda> \<sigma>. \<not> unprot \<sigma>) (arOf f)"
      unfolding list_all_length unprot_def by auto
      hence 2: "list_all2 (eintP \<circ> Guard) (arOf f) (map singl al)"
      using al unfolding intT_def[abs_def] list_all2_length list_all_length
      singl_def[abs_def] by auto
      show ?thesis using GE_Guard_protCl[OF f True 0 2] .
    qed
    thus ?thesis using unprot unfolding intT_def by (simp add: 1)
  qed
qed

lemma Struct: "Struct wtFsym wtPsym arOf resOf intT intF intP"
apply default using NE_intT_forget wt_intF by auto

end (* context ProblemIkTpartG_GEModel *)

sublocale ProblemIkTpartG_GEModel < Ik : Struct
where intT = intT and intF = intF and intP = intP
using Struct .

context ProblemIkTpartG_GEModel begin

lemma wtE[simp]: "Ik.wtE \<xi> \<Longrightarrow> GE.wtE \<xi>"
unfolding Ik.wtE_def GE.wtE_def intT_def by metis

lemma int_g[simp]: "GE.int \<xi> (gT T) = Ik.int \<xi> T"
proof (induct T)
  case (Fn f Tl)
  let ?ar = "arOf f" let ?r = "resOf f"
  have 0: "map (Ik.int \<xi>) Tl = map (GE.int \<xi> \<circ> gT) Tl"
  apply(rule nth_equalityI) using Fn unfolding list_all_length by auto
  show ?case
  unfolding Ik.int.simps GE.int.simps gT.simps unfolding intF_def
  using Fn by (simp add: 0)
qed auto

lemma map_int_g[simp]:
"map (Ik.int \<xi>) Tl = map (GE.int \<xi> \<circ> gT) Tl"
apply(rule nth_equalityI) unfolding list_all_length by auto

lemma satA_gA[simp]: "GE.satA \<xi> (gA at) \<longleftrightarrow> Ik.satA \<xi> at"
using assms by (cases at) (auto simp add: intP_def)

lemma satL_gL[simp]: "GE.satL \<xi> (gL l) \<longleftrightarrow> Ik.satL \<xi> l"
using assms apply(cases l) by auto

lemma satC_map_gL[simp]: "GE.satC \<xi> (map gL c) \<longleftrightarrow> Ik.satC \<xi> c"
unfolding GE.satC_def Ik.satC_def using assms by (induct c, auto)

lemma wtE_not_grdLit_unprot[simp]: (* crucial: *)
assumes "Ik.wtE \<xi>" and "\<not> unprot (tpOfV x)"
shows "\<not> GE.satL \<xi> (grdLit x)"
using assms unfolding Ik.wtE_def intT_def grdLit_def by simp

lemma wtE_not_grdLit[simp]:
assumes "Ik.wtE \<xi>" and "prot (tpOfV x) \<or> protFw (tpOfV x)"
shows "\<not> GE.satL \<xi> (grdLit x)"
apply(rule wtE_not_grdLit_unprot) using assms unfolding unprot_def by auto

lemma wtE_not_glitOfL[simp]:
assumes "Ik.wtE \<xi>"
shows "\<not> GE.satC \<xi> (list (glitOfL l))"
using assms unfolding GE.satC_def list_ex_list[OF finite_glitOfL]
by (cases l, auto)

lemma wtE_not_glitOfC[simp]:
assumes "Ik.wtE \<xi>"
shows "\<not> GE.satC \<xi> (list (glitOfC c))"
using wtE_not_glitOfL[OF assms]
unfolding GE.satC_def list_ex_list[OF finite_glitOfC] list_ex_list[OF finite_glitOfL]
unfolding glitOfC_def by auto

lemma satC_gC[simp]:
assumes "Ik.wtE \<xi>" and "GE.satC \<xi> (gC c)"
shows "Ik.satC \<xi> c"
using assms unfolding gC_def by simp

lemma satPB_gPB[simp]:
assumes "Ik.wtE \<xi>" and "GE.satPB \<xi> (gC ` \<Phi>)"
shows "Ik.satPB \<xi> \<Phi>"
using Ik.wt_\<Phi> assms unfolding GE.satPB_def Ik.satPB_def by (auto simp add: Ik.wtPB_def)

lemma completeness: "Ik.SAT \<Phi>"
unfolding Ik.SAT_def proof safe
  fix \<xi> assume \<xi>: "Ik.wtE \<xi>" hence "GE.wtE \<xi>" by simp
  hence "GE.satPB \<xi> gPB" by (rule GE.sat_\<Phi>)
  hence "GE.satPB \<xi> (gC ` \<Phi>)" unfolding gPB_def by simp
  thus "Ik.satPB \<xi> \<Phi>" using \<xi> by simp
qed

lemma G_completeness: "Model wtFsym wtPsym arOf resOf parOf \<Phi> intT intF intP"
apply default using completeness .

end (* context ProblemIkTpartG_GEModel *)

(* Completeness theorem in sublocale form: Given a problem (with indicated
type partition) and a model for its guard-translated problem,
we obtain a model of the original problem: *)

sublocale ProblemIkTpartG_GEModel < Ik : Model
where intT = intT and intF = intF and intP = intP
using G_completeness .

subsection{* The result of the guard translation is an infiniteness-augmented problem *}

(* An observation similar to the corresponding one for tags applies here.  *)

sublocale ProblemIkTpartG < GE : Problem
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym
and arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
and \<Phi> = gPB
apply default by auto

sublocale ProblemIkTpartG < GE : ProblemIk
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym
and arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
and \<Phi> = gPB
proof default
  fix \<sigma> eintT eintF eintP a  assume \<sigma>: "infTp \<sigma>"
  assume M: "Model GE_wtFsym GE_wtPsym GE_arOf GE_resOf GE_parOf gPB eintT eintF eintP"
  let ?GE_intT = "ProblemIkTpartG_GEModel.intT prot protFw eintT eintP"
  let ?GE_intF = "ProblemIkTpartG_GEModel.intF eintF"
  let ?GE_intP = "ProblemIkTpartG_GEModel.intP eintP"
  have 0: "ProblemIkTpartG_GEModel wtFsym wtPsym arOf resOf parOf
                                   \<Phi> infTp prot protFw protCl eintT eintF eintP"
  using M unfolding ProblemIkTpartG_GEModel_def apply safe by default
  hence MM: "Ik.MModel ?GE_intT ?GE_intF ?GE_intP"
  by (rule ProblemIkTpartG_GEModel.G_completeness)
  have "infinite {a. ?GE_intT \<sigma> a}" using infTp[OF \<sigma> MM] .
  moreover have "{a. ?GE_intT \<sigma> a} \<subseteq> {a. eintT \<sigma> a}"
  using ProblemIkTpartG_GEModel.intT_def[OF 0] by auto
  ultimately show "infinite {a. eintT \<sigma> a}" using infinite_super by blast
qed

subsection{* The verification of the second monotonicity calculus criterion
for the guarded problem  *}

context ProblemIkTpartG begin

fun pol where
"pol _ (Oldp p) = Cext"
|
"pol _ (Guard \<sigma>) = Fext"

lemma pol_ct: "pol \<sigma>1 p = pol \<sigma>2 p"
by(cases p, auto)

definition "grdOf c l x = grdLit x"
end

sublocale ProblemIkTpartG < GE: ProblemIkPol
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym
and arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
and \<Phi> = gPB and pol = pol and grdOf = grdOf by default

context ProblemIkTpartG begin

lemma nv2_nv[simp]: "GE.nv2T (gT T) = GE.nvT T"
apply (induct T) by auto

lemma nv2L_nvL[simp]: "GE.nv2L (gL l) = GE.nvL l"
proof(cases l)
  case (Pos at) thus ?thesis by (cases at, simp_all)
next
  case (Neg at) thus ?thesis by (cases at, auto)
qed

lemma nv2L:
assumes "l \<in> set c" and mc: "GE.mcalc \<sigma> c"
shows "infTp \<sigma> \<or> (\<forall> x \<in> GE.nv2L (gL l). tpOfV x \<noteq> \<sigma>)"
using assms mc nv2L_nvL unfolding GE.mcalc_iff GE.nvC_def apply simp
using nv2L_nvL[of l]
by (metis empty_subsetI equalityI nv2L_nvL)

(* The guarding literals are guarded: *)
lemma isGuard_grdLit[simp]: "GE.isGuard x (grdLit x)"
unfolding grdLit_def by auto

lemma nv2L_grdLit[simp]: "GE.nv2L (grdLit x) = {}"
unfolding grdLit_def by auto

lemma mcalc_mcalc2: "GE.mcalc \<sigma> c \<Longrightarrow> GE.mcalc2 \<sigma> (gC c)"
using nv2L unfolding GE.mcalc2_iff gC_def glitOfC_def grdOf_def by auto

lemma nv2L_wax[simp]: "l' \<in> set (wax \<sigma>) \<Longrightarrow> GE.nv2L l' = {}"
unfolding wax_def by auto

lemma nv2L_Wax:
assumes "c' \<in> Wax" and "l' \<in> set c'"
shows "GE.nv2L l' = {}"
using assms unfolding Wax_def by auto

lemma nv2L_cOfFax[simp]: "GE.nv2L (Pos (cOfFax \<sigma>)) = {}"
unfolding cOfFax_def by auto

lemma nv2L_hOfFax[simp]:
assumes "at \<in> set (hOfFax \<sigma>)"
shows "GE.nv2L (Neg at) = {}"
using assms unfolding hOfFax_def map2_def by auto

lemma nv2L_fax[simp]: "l \<in> set (fax \<sigma>) \<Longrightarrow> GE.nv2L l = {}"
unfolding fax_def by auto

lemma nv2L_faxCD[simp]: "l \<in> set (faxCD \<sigma>) \<Longrightarrow> GE.nv2L l = {}"
unfolding faxCD_def by auto

lemma nv2L_Fax:
assumes "c' \<in> Fax" and "l' \<in> set c'"
shows "GE.nv2L l' = {}"
using assms unfolding Fax_def by auto

lemma mcalc2:
assumes c': "c' \<in> gPB"
shows "GE.mcalc2 \<sigma> c'"
proof(cases "c' \<in> Fax \<union> Wax")
  case True thus ?thesis using nv2L_Wax nv2L_Fax
  unfolding GE.mcalc2_iff by fastforce
next
  case False hence c': "c' \<in> gPB" using c' unfolding gPB_def by auto
  show ?thesis unfolding GE.mcalc2_iff using grdOf[OF c'] by auto
qed

end (* context ProblemIkTpartG *)

sublocale ProblemIkTpartG < GE: ProblemIkPolMcalc2C
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym
and arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
and \<Phi> = gPB and pol = pol and grdOf = grdOf
apply default using grdOf mcalc2 by (auto simp: pol_ct)

(* We already know that ProblemIkMcalc < MonotProblem, so by transitivity we obtain
the following main theorem, stating that the guard translation yields a monotonic
problem *)

context ProblemIkTpartG begin

theorem G_monotonic:
"MonotProblem GE_wtFsym GE_wtPsym GE_arOf GE_resOf GE_parOf gPB"
by default

end (* context ProblemIkTpartG *)

(* Also in sublocale form: *)

sublocale ProblemIkTpartG < GE: MonotProblem
where wtFsym = GE_wtFsym and wtPsym = GE_wtPsym
and arOf = GE_arOf and resOf = GE_resOf and parOf = GE_parOf
and \<Phi> = gPB
using G_monotonic .

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               February 2006               |
            |                  April 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                  May 2016  (modified)     |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_nf_def
imports CSP_F_Main
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)

declare split_if  [split del]

(*****************************************************************

         1. definition of full normalisation
         2.
         3.

 *****************************************************************)

(*----------------------------------------------------------------------*
 |                         full normal form                             |
 *----------------------------------------------------------------------*)

definition
  fnfF_set_condition  :: "'a set => 'a set set => bool"
  where
  fnfF_set_condition_def :
   "fnfF_set_condition A Ys ==
    (ALL Y. ((EX Y0:Ys. Y0 <= Y) & Y <= A Un Union Ys) --> Y:Ys)"

definition
  fnfF_set_completion :: "'a set => 'a set set => 'a set set"
  where
  fnfF_set_completion_def :
   "fnfF_set_completion A Ys == {Y. (EX Y0:Ys. Y0 <= Y) & Y <= (A Un Union Ys)}"

(* Isabelle 2005
consts
  fnfF_proc      :: "('p,'a) proc set"

inductive "fnfF_proc"
intros
fnfF_proc_rule:
  "[| (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) ;
      fnfF_set_condition A Ys ; Union Ys <= A ;
      Q = SKIP | Q = DIV |]
   ==> ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV))
        : fnfF_proc"
*)

inductive_set
  fnfF_proc      :: "('p,'a) proc set"
where
fnfF_proc_rule:
  "[| (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) ;
      fnfF_set_condition A Ys ; Union Ys <= A ;
      Q = SKIP | Q = DIV |]
   ==> ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV))
        : fnfF_proc"

(* .elims ---> .cases *)

definition
  XfnfF_proc           :: "('p,'a) proc set"
  where
  XfnfF_proc_def :
   "XfnfF_proc == {!nat n .. Pf n |Pf.
                  (ALL n. Pf n =F (!nat n .. Pf n) |. n) &
                  (ALL n. Pf n : fnfF_proc) }"

(*** convenient lemmas ***)

lemma fnfF_set_completion_sat_condition[simp]:
  "fnfF_set_condition A (fnfF_set_completion A Ys)"
apply (simp add: fnfF_set_condition_def)
apply (intro allI impI)
apply (elim conjE bexE)

apply (simp add: fnfF_set_completion_def)
apply (elim conjE bexE)
apply (rule conjI)
apply (rule_tac x="Y0a" in bexI)
apply (simp)
apply (simp)

apply (rule subsetI)
apply (erule subsetE)
apply (drule_tac x="x" in bspec, simp)
apply (simp)
apply (elim disjE conjE exE bexE)
apply (simp)

apply (rotate_tac 5)
apply (erule subsetE)
apply (simp)
done

lemma fnfF_set_completion_subset:
  "Ys <= fnfF_set_completion A Ys"
by (auto simp add: fnfF_set_completion_def)

lemma fnfF_set_completion_Union_subset:
  "Union Ys <= A ==>
   Union (fnfF_set_completion A Ys) <= A"
apply (auto simp add: fnfF_set_completion_def)
apply (subgoal_tac "x : A Un Union Ys")
apply (simp)
apply (erule disjE)
apply (auto)
done

(*----------------------------------------------------------*
 |                   intro, elim, simp                      |
 *----------------------------------------------------------*)

lemma fnfF_proc_iff:
  "(NP : fnfF_proc) =
     (EX A Ys Pf Q.
      NP = ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV)) &
      (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) &
       fnfF_set_condition A Ys & Union Ys <= A &
       (Q = SKIP | Q = DIV))"
apply (rule iffI)

(* => *)
(* apply (erule fnfF_proc.elims) *)
 apply (erule fnfF_proc.cases)
 apply (force)

(* <= *)
 apply (elim conjE exE)
 apply (simp add: fnfF_proc.intros)
done

lemma fnfF_proc_EX_I:
     "(EX A Ys Pf Q.
      NP = ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV)) &
      (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) &
       fnfF_set_condition A Ys & Union Ys <= A &
       (Q = SKIP | Q = DIV))
    ==> NP : fnfF_proc"
apply (simp add: fnfF_proc_iff[of NP])
done

lemma fnfF_proc_EX_E:
  "[| NP : fnfF_proc ;
     (EX A Ys Pf Q.
      NP = ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV)) &
      (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) &
       fnfF_set_condition A Ys & Union Ys <= A &
       (Q = SKIP | Q = DIV))
      ==> S |]
    ==> S"
apply (simp add: fnfF_proc_iff[of NP])
done

(*----------------------------------------------------------*
 |                 ALL fnfF_proc_iff                   |
 *----------------------------------------------------------*)

lemma ALL_fnfF_proc_only_if:
  "ALL x:X. NPf x : fnfF_proc
   ==>
     (EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))"
apply (simp add: fnfF_proc_iff)
apply (simp add: choice_BALL_EX)
apply (elim exE)
apply (rule_tac x="f" in exI)
apply (rule_tac x="fa" in exI)
apply (rule_tac x="fb" in exI)
apply (rule_tac x="fc" in exI)

(* NPf *)
apply (rule conjI)
apply (simp add: fun_eq_iff)
apply (rule allI)
apply (case_tac "x:X")
apply (simp_all)

apply (intro allI ballI)
apply (drule_tac x="x" in bspec, simp)
apply (elim conjE)
apply (drule_tac x="a" in spec)
apply (simp)
done

lemma ALL_fnfF_proc_iff:
  "(ALL x:X. NPf x : fnfF_proc)
   =
     (EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))"
apply (rule)
apply (simp add: ALL_fnfF_proc_only_if)

apply (elim conjE exE)
apply (intro ballI)
apply (simp add: fun_eq_iff)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in bspec, simp)+
apply (simp)
apply (simp add: fnfF_proc.intros)
done

lemma ALL_fnfF_procI:
  "(EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))
   ==> ALL x:X. NPf x : fnfF_proc"
apply (simp add: ALL_fnfF_proc_iff)
done

lemma ALL_fnfF_procE:
  "[| ALL x:X. NPf x : fnfF_proc ;
      (EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))
   ==> S |] ==> S"
apply (simp add: ALL_fnfF_proc_iff)
done

(*======================================================*
 |         function to decompose : fnfF_decompo         |
 *======================================================*)
(*
isabelle 2011

consts
  fnfF_A ::
     "('p,'a) proc => ('a set)"
  fnfF_Ys ::
     "('p,'a) proc => ('a set set)"
  fnfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
  fnfF_Q ::
     "('p,'a) proc => ('p,'a) proc"

(* they are partial functions *)

recdef fnfF_A "{}"
  "fnfF_A (((? :A -> Pf) [+] Q) |~| R) = A"

recdef fnfF_Ys "{}"
  "fnfF_Ys (P |~| !! : type1 Ys .. Pf) = Ys"

recdef fnfF_Pf "{}"
  "fnfF_Pf (((? :A -> Pf) [+] Q) |~| R) = Pf"

recdef fnfF_Q "{}"
  "fnfF_Q (((? :A -> Pf) [+] Q) |~| R) = Q"
*)

(* they are partial functions *)

fun
  fnfF_A ::
     "('p,'a) proc => ('a set)"
where
  "fnfF_A (((? :A -> Pf) [+] Q) |~| R) = A"

fun
  fnfF_Ys ::
     "('p,'a) proc => ('a set set)"
where
  "fnfF_Ys (P |~| !! : type1 Ys .. Pf) = Ys"

fun
  fnfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
where
  "fnfF_Pf (((? :A -> Pf) [+] Q) |~| R) = Pf"

fun
  fnfF_Q ::
     "('p,'a) proc => ('p,'a) proc"
where
  "fnfF_Q (((? :A -> Pf) [+] Q) |~| R) = Q"

lemma fnfF_Ys_get[simp]:
  "fnfF_Ys (P |~| !set :Ys .. Pf) = Ys"
by (simp add: Rep_int_choice_ss_def)

(*------------------------*
 |     decomposition      |
 *------------------------*)

lemma cspF_fnfF_nat_decompo:
   "P : fnfF_proc ==>
    P =F ((? : (fnfF_A P) -> (fnfF_Pf P)) [+] fnfF_Q P)
         |~| (!set Y: fnfF_Ys P .. (? a:Y -> DIV))"
(* apply (erule fnfF_proc.elims) *)
apply (erule fnfF_proc.cases)
apply (simp)
done

(*--------------------------------------*
 |   properties of fnfF decomposition   |
 *--------------------------------------*)

lemma fnfF_Pf_A:
   "[| P : fnfF_proc ; a : (fnfF_A P) |]
    ==> (fnfF_Pf P) a : fnfF_proc"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_Pf_DIV:
   "[| P : fnfF_proc ; a ~: (fnfF_A P) |]
    ==> (fnfF_Pf P) a = DIV"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_Q_range:
   "P : fnfF_proc
    ==> (fnfF_Q P) = SKIP | (fnfF_Q P) = DIV"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_condition_A_Ys:
   "P : fnfF_proc ==>
    fnfF_set_condition (fnfF_A P) (fnfF_Ys P)"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_Union_Ys_A:
   "P : fnfF_proc ==>
    Union (fnfF_Ys P)  <= (fnfF_A P)"
apply (erule fnfF_proc.cases)
apply (simp)
done

(*-----------------------*
 |    DIV, SKIP, STOP    |
 *-----------------------*)

definition
  NSKIP     :: "('p,'a) proc"
  where
  NSKIP_def : "NSKIP == ((? a:{} -> DIV) [+] SKIP) |~| (!set Y:{} .. (? a:Y -> DIV))"

definition
  NDIV      :: "('p,'a) proc"
  where
  NDIV_def  : "NDIV  == ((? a:{} -> DIV) [+] DIV)  |~| (!set Y:{} .. (? a:Y -> DIV))"

definition
  NSTOP     :: "('p,'a) proc"
  where
  NSTOP_def : "NSTOP == ((? a:{} -> DIV) [+] DIV)  |~| (!set Y:{{}} .. (? a:Y -> DIV))"

(*** in fnfF ***)

lemma fnfF_NSKIP[simp]: "NSKIP : fnfF_proc"
apply (simp add: NSKIP_def)
apply (rule fnfF_proc.intros)
apply (simp_all add: fnfF_set_condition_def)
done

lemma fnfF_NDIV[simp]: "NDIV : fnfF_proc"
apply (simp add: NDIV_def)
apply (rule fnfF_proc.intros)
apply (simp_all add: fnfF_set_condition_def)
done

lemma fnfF_NSTOP[simp]: "NSTOP : fnfF_proc"
apply (simp add: NSTOP_def)
apply (rule fnfF_proc.intros)
apply (simp_all add: fnfF_set_condition_def)
done

(*** eqF ***)

lemma cspF_NSKIP_eqF: "SKIP =F NSKIP"
apply (simp add: NSKIP_def)
apply (rule cspF_rw_right)
apply (rule cspF_decompo)
apply (rule cspF_choice_rule)
apply (rule cspF_Rep_int_choice_DIV)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_reflex)
done

lemma cspF_NDIV_eqF: "DIV =F NDIV"
apply (simp add: NDIV_def)
apply (rule cspF_rw_right)
apply (rule cspF_decompo)
apply (rule cspF_choice_rule)
apply (rule cspF_Rep_int_choice_DIV)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_reflex)
done

lemma cspF_NSTOP_eqF: "STOP =F NSTOP"
apply (simp add: NSTOP_def)
apply (rule cspF_rw_right)
apply (rule cspF_decompo)
apply (rule cspF_choice_rule)
apply (rule cspF_Rep_int_choice_singleton)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_step)
done

(*==============================================================*
 |               convenient rules for fnfF                      |
 *==============================================================*)

lemma cspF_fnfF_Depth_rest_dist:
  "Q = SKIP | Q = DIV ==>
   (? :A -> Pf [+] Q
   |~| !set Y:Ys .. ? a:Y -> DIV) |. Suc n
  =F
   (? a:A -> (Pf a |. n) [+] Q
   |~| !set Y:Ys .. ? a:Y -> DIV)"
apply (rule cspF_rw_left)
apply (rule cspF_dist)
apply (rule cspF_decompo)
apply (rule cspF_rw_left)
apply (rule cspF_Ext_dist)
apply (rule cspF_decompo)
apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (rule cspF_reflex)
apply (erule disjE)
apply (simp_all)

apply (rule cspF_rw_left)
apply (rule cspF_Dist)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_DIV_Depth_rest)
done

(* left DIV *)

lemma cspF_fsfF_left_DIV:
  "(? a:{} -> DIV [+] DIV) |~| P =F P"
apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (rule cspF_Ext_choice_rule)
apply (rule cspF_reflex)
apply (rule cspF_unit)
done

lemma cspF_fsfF_right_DIV:
  "P |~| (!set :{} .. Pf) =F P"
apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (rule cspF_reflex)
apply (rule cspF_Rep_int_choice_DIV)
apply (rule cspF_unit)
done

(****************** to add them again ******************)

declare split_if    [split]
declare disj_not1   [simp]

end


section {* Host Properties *}

theory Wasm_Axioms imports Wasm begin

(* these were originally axioms, but memory now has a concrete representation in the model *)
lemma mem_grow_size:
  assumes "mem_grow m n = m'"
  shows "(mem_size m + (64000 * n)) = mem_size m'"
  using assms Abs_mem_inverse Abs_bytes_inverse
  unfolding mem_grow_def mem_size_def mem_append_def bytes_replicate_def
  by auto

lemma load_size:
  "(load m n off l = None) = (mem_size m < (off + n + l))"
  unfolding load_def
  by (cases "n + off + l \<le> mem_size m") auto

lemma load_packed_size:
  "(load_packed sx m n off lp l = None) = (mem_size m < (off + n + lp))"
  using load_size
  unfolding load_packed_def
  by (cases "n + off + l \<le> mem_size m") auto

lemma store_size1:
  "(store m n off v l = None) = (mem_size m < (off + n + l))"
  unfolding store_def
  by (cases "n + off + l \<le> mem_size m") auto

lemma store_size:
  assumes "(store m n off v l = Some m')"
  shows "mem_size m = mem_size m'"
  using assms Abs_mem_inverse Abs_bytes_inverse
  unfolding store_def write_bytes_def bytes_takefill_def
  by (cases "n + off + l \<le> mem_size m") (auto simp add: mem_size_def)

lemma store_packed_size1:
  "(store_packed m n off v l = None) = (mem_size m < (off + n + l))"
  using store_size1
  unfolding store_packed_def
  by simp

lemma store_packed_size:
  assumes "(store_packed m n off v l = Some m')"
  shows "mem_size m = mem_size m'"
  using assms store_size
  unfolding store_packed_def
  by simp

axiomatization where
  wasm_deserialise_type:"typeof (wasm_deserialise bs t) = t"

axiomatization where
    host_apply_preserve_store:" list_all2 types_agree t1s vs \<Longrightarrow> host_apply s (t1s _> t2s) f vs hs = Some (s', vs') \<Longrightarrow> store_extension s s'"
and host_apply_respect_type:"list_all2 types_agree t1s vs \<Longrightarrow> host_apply s (t1s _> t2s) f vs hs = Some (s', vs') \<Longrightarrow> list_all2 types_agree t2s vs'"
and host_trust_security_Some:"store_public_agree s s' \<Longrightarrow> publics_agree vs vs' \<Longrightarrow> host_apply s (t1s _> t2s) f vs hs = Some (s_a, vs_a) \<Longrightarrow>
                                \<exists>s'_a vs'_a. host_apply s' (t1s _> t2s) f vs' hs' = Some (s'_a, vs'_a) \<and>
                                             store_public_agree s_a s'_a \<and>
                                             publics_agree vs_a vs'_a"
and host_trust_security_None:"store_public_agree s s' \<Longrightarrow> publics_agree vs vs' \<Longrightarrow> host_apply s (t1s _> t2s) f vs hs = None \<Longrightarrow>
                                       host_apply s' (t1s _> t2s) f vs' hs' = None"
end