(*  Title:      MultiASP.thy
    Author:     Ludovic Henrio and Florian Kammuller
                2014

    Note:       Multi-active object formalisation
                For the moment methods and parameter bindings are done statically,
                  without inheritance but with interfaces
                  this could be improved
*)
(*Conventions:
  l = location in store
  x,y=varname
  locs = local variables
  l_\<alpha> = location in the local store of the active object of \<alpha>
 Stl = statement list
 EContext is an execution context, ie a thread
 EcL = EContext list*)

chapter {* Syntax and Semantics *}

theory MultiASP imports Main AuxiliaryFunctions begin

subsection {* Syntax *}
type_synonym ItfName = string
type_synonym VarName =  string
datatype VarOrThis = This | Id VarName
type_synonym ClassName = string
type_synonym MethodName = string

type_synonym ActName = nat
type_synonym FutName = nat
type_synonym Location = nat

datatype Signature = Method ItfName MethodName  "(ItfName * VarName) list"
  (* signature = Method returnType MethodName (list of parameters)*)

datatype Value = null | ASPInt nat | ASPBool bool (* static values *)
                | ActRef ActName (* runtime values *)
                | ObjRef Location
type_synonym  Object = "(VarName\<rightharpoonup>Value) * ClassName"
abbreviation GetObject:: "Object \<Rightarrow>VarName=>Value option" ("_.[_]")
  where "GetObject ob x \<equiv> (fst ob) x"
abbreviation SetObject:: "Object \<Rightarrow>VarName=>Value\<Rightarrow>Object" ("_.[_]:=_")
  where "SetObject ob x v\<equiv> ((fst ob)(x\<mapsto>v),snd ob)"

datatype Storable = Obj Object | FutRef FutName | StoredVal Value

datatype Expression = Val Value
             | Var VarOrThis
             | Plus Expression Expression ("_+\<^sub>A_" [120,120] 200)
             | And Expression Expression ("_&\<^sub>A_" [100,100] 300)
             | Test Expression Expression ("_==\<^sub>A_" [100,100] 300)

datatype Rhs = Expr Expression
             | Call Expression MethodName "Expression list" ("_.\<^sub>A_'(_')" [440,0,50] 500) (*e.m(e list) *)
             | New ClassName "Expression list" ("new _'(_')" [300,0] 500) (*new C(e list) *)
             | NewActive ClassName "Expression list" ("newActive _'(_')" [300,0] 500) (*newActive C(e list) *)
             | Hole (* runtime term *)

datatype Statement =   Assign VarName Rhs  (infix "=\<^sub>A"  400) (*x=z*)
| Return Expression ("return _" [300] 300)(*return E *)
| If Expression "Statement list" "Statement list" ("IF _ THEN _ ELSE _ " [300,0,0] 300)(*if E then s else s *)
(* skip |  NB: skip and seq are not necessary thanks to the use of statement list
| Seq Statement Statement (infix ";;"  100)*)
abbreviation MakeStatementList:: "Statement \<Rightarrow>Statement list\<Rightarrow>Statement list" (infix ";;" 100)
  where "MakeStatementList s Stl\<equiv> s#Stl"
abbreviation MakeStatementList2:: "Statement \<Rightarrow>Statement\<Rightarrow>Statement list" (infix ";;;" 120)
  where "MakeStatementList2 s s'\<equiv> s#[s']"

(*primrec RedContext:: "Statement\<Rightarrow> Statement \<times>Statement" (* returns basic instruction,context , i.e. the rest of the sequence*)
where
  "RedContext Skip = (Skip,Skip)" |
  "RedContext (x=\<^sub>Az) =  ((x=\<^sub>Az),Skip)" |
  "RedContext (return e) =  (return e,Skip)" |
  "RedContext (IF e THEN s ELSE s') =  (IF e THEN s ELSE s',Skip)" |
  "RedContext ( s ;; s') =  (fst (RedContext s),(snd (RedContext s);;s'))"
*)
(*abbreviation BuildContext::"Statement\<Rightarrow>Statement\<Rightarrow> Statement \<times>Statement" ("_[[_]]" [300, 0] 300)
where "BuildContext R s \<equiv> (s,R)"
*)
record Method =
MethSignature:: Signature
LocalVariables::"(ItfName * VarName) list"
Body::"Statement list"
(*MethDefinition methodname (local variables) body*)

abbreviation Parameters::"Method \<Rightarrow>(ItfName * VarName) list"
where "Parameters m \<equiv> case (MethSignature m) of
        Method ItfName MethodName  param_list\<Rightarrow>param_list"

abbreviation MName:: "Method \<Rightarrow> MethodName"
where "MName m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>MethName"

abbreviation MRType:: "Method \<Rightarrow> ItfName"
where "MRType m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>returnType"

abbreviation MParams:: "Method \<Rightarrow>(ItfName * VarName) list"
where "MParams m \<equiv> case (MethSignature m) of
        (Method returnType MethName listparameters) \<Rightarrow>listparameters"

record Class =
 Name::ClassName
 Interfaces::"(ItfName list) "
 ClassParameters::"((ItfName * VarName) list)"
 StateVariables::"((ItfName * VarName) list)"
 Methods::"(Method list)"
             (*ASPclass name (classparameters) (implementedinterfaces) (statevariables) (listofmethodbodies) *)
record Interface =
  IName:: ItfName
  IMethods:: "(Signature list)"

datatype Program = Prog "Interface list" "Class list" "(ItfName * VarName) list" "Statement list"

(*        --- runtime notions --- *)
type_synonym EContext = " Location * (VarName\<rightharpoonup>Value) * (Statement list)"
                          (*execution context = location of this, local variables, and statements *)
type_synonym Request = "FutName * MethodName * (Value list)"
type_synonym Store = "Location \<rightharpoonup> Storable"
abbreviation EC_location::"EContext \<Rightarrow>Location"
where "EC_location Ec \<equiv> fst Ec"
abbreviation EC_locs:: "EContext \<Rightarrow>(VarName\<rightharpoonup>Value)"
where "EC_locs Ec \<equiv> fst (snd Ec)"
abbreviation EC_Stl:: "EContext \<Rightarrow>Statement list"
where "EC_Stl Ec \<equiv> snd (snd Ec)"
(*datatype Process = Proc Request "Context list" *)

datatype ActiveObject = AO Location Store "Request\<rightharpoonup>(EContext list)" "Request list"
    (* active object location , store, task list, request queue*)

datatype FutValue = Undefined | FutVal Value  Store

datatype Configuration = Cn "ActName\<rightharpoonup>ActiveObject" "FutName\<rightharpoonup>FutValue"

subsection {*finite configuration *}

definition finite_Store :: "Store \<Rightarrow> bool"
  where
    "finite_Store \<sigma> \<equiv> (finite (dom \<sigma>) \<and> (\<forall> loc obj. (\<sigma>(loc)=Some (Obj obj)\<longrightarrow> finite (dom (fst obj)))))"

definition finite_Processes :: "(Request\<rightharpoonup>(EContext list)) \<Rightarrow> bool"
  where
    "finite_Processes (processMap) \<equiv> finite (dom (processMap)) \<and>
       (\<forall> contList\<in>(ran(processMap)). \<forall>cont\<in> set contList. finite (dom(EC_locs(cont))))"

primrec finite_Configuration :: "Configuration => bool"
  where
 " finite_Configuration (Cn AOs Futures) =
      (finite (dom AOs) \<and> finite (dom Futures) \<and>
    (\<forall> futVal\<in>(ran Futures). \<forall> v \<sigma>. (futVal =FutVal v \<sigma> \<longrightarrow> finite_Store \<sigma>)) \<and> (*NB: Undefined futures are finite*)
    (\<forall> ao\<in>(ran AOs). \<forall> l \<sigma> P Q. ao = AO l \<sigma> P Q \<longrightarrow> finite_Store \<sigma> \<and> finite_Processes P))"
declare MultiASP.finite_Configuration.simps[simp del]

text{* Binding and fetching elements *}
definition  fetchClass
where
"fetchClass P C \<equiv>
case P of (Prog Is CL Vars Stl) \<Rightarrow> (List.find  (\<lambda>class.(Name class) = C) CL)
"
definition fetchMethodInClass
where
"fetchMethodInClass  class m \<equiv>
Option.bind
(List.find (\<lambda>method. (MName method = m)) (Methods class))
(\<lambda>method. Some (map snd (MParams method), map snd (LocalVariables method), Body method))
"

definition Bind::"Program\<Rightarrow>Location\<Rightarrow>ClassName\<Rightarrow>MethodName\<Rightarrow>Value list\<Rightarrow> EContext option"
where
 "Bind P l C m value_list\<equiv>
(case fetchClass P C of
  Some class \<Rightarrow>
    (case  fetchMethodInClass class m  of
       Some (param_list,locs,b) \<Rightarrow>
         if length param_list = length value_list then
           ( let locales=  (map_of (zip locs (replicate (length locs) null)))
                    ++ (map_of (zip param_list value_list)) in
                Some ( l, locales,b))
           else None
       | None \<Rightarrow> None)
  | _\<Rightarrow> None)"
definition  fields:: "Program\<Rightarrow>ClassName \<Rightarrow>VarName list"
where
  "fields P C \<equiv>
     case (fetchClass P C) of
  Some class \<Rightarrow>(map snd (StateVariables class))"

definition  params:: "Program\<Rightarrow>ClassName \<Rightarrow>VarName list"
where
  "params P C \<equiv>case (fetchClass P C) of
  Some class \<Rightarrow>(map snd (ClassParameters class))"

definition Interface_set_from_variable_list:: "(ItfName * VarName) list\<Rightarrow>ItfName set"
where
"Interface_set_from_variable_list VL\<equiv> set (map fst VL)"

abbreviation DefinedClassNames
where "DefinedClassNames prog \<equiv>set (case prog of Prog IL CL vl xtl \<Rightarrow>map Name CL)"

subsection {* serialization and location renaming *}

inductive serialize :: "Value \<Rightarrow> Store \<Rightarrow> Store \<Rightarrow> bool"
(*serialize v \<sigma> \<sigma>' is true if the serialization of value v is a subset of \<sigma>' (using store \<sigma>)*)
  where
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (Obj obj) \<and> (\<forall> v\<in> ran(fst(obj)). \<exists>\<sigma>''. (serialize v \<sigma> \<sigma>''\<and> \<sigma>'' \<subseteq>\<^sub>m \<sigma>'))
     \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (FutRef f)  \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (StoredVal v)  \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
     "(serialize (ActRef f) \<sigma> \<sigma>')" |
     "serialize (null) \<sigma> \<sigma>' " |
     "serialize (ASPInt n) \<sigma> \<sigma>'" |
     "serialize (ASPBool b) \<sigma> \<sigma>'"

 definition Referenced_locations_Value:: "Value \<Rightarrow> Location set"
where  "Referenced_locations_Value v \<equiv> (case v of ObjRef l \<Rightarrow>{l} | _ \<Rightarrow> {})"

axiomatization where finite_map: "finite (dom (\<sigma>::Store))"
function (sequential) serialization_filter :: "Location \<Rightarrow> Store \<Rightarrow> Location set \<Rightarrow> Location set"
(*serialize v \<sigma> \<sigma>' is true if the serialization of value v is a subset of \<sigma>' (using store \<sigma>)*)
  where
    "
    (serialization_filter l \<sigma> L) = (if l\<in>L then {} else
      (case \<sigma>(l) of
      Some (Obj obj) \<Rightarrow> listunionMap (\<lambda>x.(serialization_filter x \<sigma> (L\<union>{l})))
                (sorted_list_of_set (\<Union>(Referenced_locations_Value`ran(fst(obj))))) |
      _ \<Rightarrow> {}))"
by auto
termination
apply (relation "measure (\<lambda>(l,\<sigma>,L). card (dom \<sigma> - L))")
apply auto
apply (subgoal_tac "dom \<sigma> - insert l L = (dom \<sigma> - L) - {l}")
apply (subgoal_tac "finite ((dom \<sigma>-L))")
apply (drule_tac x=l in Finite_Set.card.remove)+
apply (insert finite_map)
apply auto
done

primrec subst_Value :: " Value \<Rightarrow> (Location\<Rightarrow>Location) \<Rightarrow> Value"
where
  "subst_Value (ObjRef l) \<psi> = ObjRef (\<psi>(l))" |
  "subst_Value (ActRef a) \<psi> = ActRef a" |
  "subst_Value (null) \<psi> = null" |
  "subst_Value (ASPInt i) \<psi> = ASPInt i" |
  "subst_Value (ASPBool b) \<psi> = ASPBool b"

definition check_subst :: "Store \<Rightarrow> (Location\<Rightarrow>Location) \<Rightarrow> Store \<Rightarrow> bool"
where
  "check_subst  \<sigma> \<psi> \<sigma>' \<equiv>
    ( inj \<psi> \<and> dom \<sigma>' =  \<psi> ` (dom(\<sigma>))
    \<and> (\<forall> obj l . (\<sigma>(l) = Some (Obj obj)
      \<longrightarrow> (\<exists> obj'. (\<sigma>'(\<psi>(l)) = Some (Obj obj') \<and> (\<forall> x  v. (obj.[x]) = Some v \<longrightarrow> (obj'.[x])=Some (subst_Value v \<psi>)))))
    \<and>   (\<forall> f l . (\<sigma>(l) = Some (FutRef f) \<longrightarrow> \<sigma>'(\<psi>(l)) =Some (FutRef f)))
    \<and>   (\<forall> v l . (\<sigma>(l) = Some (StoredVal v) \<longrightarrow>
      \<sigma>'(\<psi>(l)) = Some (StoredVal (subst_Value v \<psi>))))))"

definition rename_value_store :: " Store \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> bool"
 where "rename_value_store \<sigma>\<^sub>0 v \<sigma> v' \<sigma>'  \<equiv> (\<exists>\<psi> . check_subst \<sigma> \<psi> \<sigma>'\<and>v'=subst_Value v \<psi>)\<and>
                                            dom \<sigma>\<^sub>0 \<inter> dom \<sigma>' = {}"

definition serialize_and_rename_list :: " Store \<Rightarrow> Value list \<Rightarrow> Store \<Rightarrow> Value list \<Rightarrow> Store \<Rightarrow> bool"
 where "serialize_and_rename_list \<sigma>\<^sub>0 vl \<sigma> vl' \<sigma>'  \<equiv>
              length vl=length vl' \<and>
              (\<exists>\<psi> \<sigma>''. (\<forall> i<length vl. serialize  (vl!i) \<sigma> \<sigma>''\<and>vl'!i=subst_Value (vl!i) \<psi>) \<and>check_subst \<sigma>'' \<psi> \<sigma>') \<and>
              dom \<sigma>\<^sub>0 \<inter> dom \<sigma>' = {}"

(*locale Generic_Functions = *)

(*consts
  Bind:: "Program\<Rightarrow>Location\<Rightarrow>ClassName\<Rightarrow>MethodName\<Rightarrow>Value list\<Rightarrow> EContext "*)
(* consts
  params:: "Program\<Rightarrow>ClassName \<Rightarrow>VarName list"
 *)
(*consts fetch:: "Class list\<Rightarrow>ClassName\<Rightarrow>MethodName\<Rightarrow>
            ((VarName list) *(VarName list) * (Statement list)) option" *)

(* semantics parameterized by compatibility and binder function*)
axiomatization
  Compatible :: "(Request * Request) set"
where
  symmetric_compatible: "sym Compatible"

lemma COMP[rule_format]: "\<forall>x y. (x,y)\<in>Compatible\<longrightarrow>(y,x)\<in>Compatible"
apply (fold sym_def)
apply (rule symmetric_compatible)
done

section{*SOS*}

(*datatype EvaluatedExpr = Undefined | EVal Value | EObj Object | EFutRef FutName*)

inductive_set EvalValue:: "(Value \<times> Store \<times> Value) set"
where
  Valnull[simp,intro]: "(null, \<sigma>,  null)\<in>EvalValue" |
  Valint[simp,intro]: "(ASPInt i, \<sigma>,  (ASPInt i) )\<in>EvalValue" |
  valbool[simp,intro]: "(ASPBool b, \<sigma>,  (ASPBool b) )\<in>EvalValue" |
  valact[simp,intro]: "(ActRef \<alpha>, \<sigma>,  (ActRef \<alpha>) )\<in>EvalValue" |
  valfut[simp,intro]:"\<sigma>(l) = Some (FutRef f) \<Longrightarrow>(ObjRef l, \<sigma>, ObjRef l)\<in>EvalValue" |
  valobj[simp,intro]:"\<sigma>(l) = Some (Obj obj) \<Longrightarrow>(ObjRef l, \<sigma>, ObjRef l)\<in>EvalValue" |
  valstored[simp,intro]: "\<lbrakk>\<sigma>(l) = Some (StoredVal v);(v,\<sigma>,ee)\<in> EvalValue\<rbrakk> \<Longrightarrow>(ObjRef l, \<sigma>, ee)\<in>EvalValue"

lemma EvalValue_is_deterministic[rule_format,intro]: "(e,\<sigma>,v)\<in>EvalValue \<longrightarrow>(e,\<sigma>,v')\<in>EvalValue \<longrightarrow>v=v'"
apply (rule impI)
apply (erule EvalValue.induct)
apply auto
apply (erule EvalValue.cases,simp+)+
done

inductive_set EvalExpr:: "(Expression \<times> Location \<times> (VarName\<rightharpoonup>Value)\<times>Store \<times> Value) set"
(* (e1,l,locs,\<sigma>,v) is true if e1 EVALUATES to v  in a setting where local variables are locs, store is \<sigma> and l is the location of this*)
 where
   exprval[simp,intro]: "(v,\<sigma>,ev)\<in>EvalValue \<Longrightarrow>(Val v, l, locs, \<sigma>, ev)\<in>EvalExpr" |
   exprlocs[simp,intro]: "\<lbrakk>locs(x)=Some v;(v,\<sigma>,ev)\<in>EvalValue\<rbrakk> \<Longrightarrow>(Var (Id x), l, locs, \<sigma>, ev)\<in>EvalExpr" |
   exprThis[simp,intro]: "\<lbrakk>(ObjRef l,\<sigma>,ev)\<in>EvalValue\<rbrakk> \<Longrightarrow>(Var This, l, locs, \<sigma>, ev)\<in>EvalExpr" |
   exprfield[simp,intro]:
   "\<lbrakk>locs(x)=None; \<sigma> l=Some (Obj ob); ob.[x] = Some v;(v,\<sigma>,ev)\<in>EvalValue\<rbrakk>
                      \<Longrightarrow>(Var (Id x), l, locs, \<sigma>, ev)\<in>EvalExpr" |
   expradd[simp,intro]:"\<lbrakk>(e,l,locs,\<sigma>,ASPInt i)\<in>EvalExpr;(e',l,locs,\<sigma>, ASPInt i')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e +\<^sub>A e', l, locs, \<sigma>, ASPInt (i+i'))\<in>EvalExpr" |
   exprand[simp,intro]:"\<lbrakk>(e,l,locs,\<sigma>,ASPBool b)\<in>EvalExpr;(e',l,locs,\<sigma>,ASPBool b')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e &\<^sub>A e', l, locs, \<sigma>, ASPBool (b\<and>b'))\<in>EvalExpr" |
   exprtest[simp,intro]:"\<lbrakk>(e,l,locs,\<sigma>,ASPInt i)\<in>EvalExpr;(e',l,locs,\<sigma>,ASPInt i')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e ==\<^sub>A e', l, locs, \<sigma>, ASPBool (i=i'))\<in>EvalExpr"

lemma EvalExpr_is_deterministic[rule_format]:
      " (e,l,locs,\<sigma>,v)\<in>EvalExpr \<longrightarrow> (\<forall> v'. (e,l,locs,\<sigma>,v')\<in>EvalExpr \<longrightarrow>v=v')"
apply (rule impI)
apply (erule EvalExpr.induct)
apply auto
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e+\<^sub>Ae'"  in EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e&\<^sub>Ae'"  in EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e==\<^sub>Ae'"  in EvalExpr.cases,auto)
done

abbreviation Ready:: "Request\<Rightarrow>(Request\<rightharpoonup>(EContext list))\<Rightarrow>(Request list)\<Rightarrow>bool"
  (*Ready q,p,Rq returns true if q is ready to be served*)
where
 "Ready R tasks Rq \<equiv>(\<forall> Q\<in>dom(tasks). (R,Q)\<in>Compatible)
                    \<and> (\<forall> Q\<in>set Rq. (R,Q)\<in>Compatible)"

inductive reduction :: "Program\<Rightarrow>[Configuration, Configuration] => bool"  ("_\<turnstile>_\<leadsto>_" 50)
  where
    Serve [simp, intro!]:
      "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> tasks (Rq@R#Rq')) ; R=(f,m,vl);
        Ready R tasks Rq;
         (\<sigma> l_\<alpha>) = Some (Obj (obj,C));
        Bind P l_\<alpha> C m vl = Some EC\<rbrakk>
          \<Longrightarrow> P\<turnstile>Cn Activities Futures
                \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(R\<mapsto>[EC]))) (Rq@Rq'))) Futures" |

    AssignLocal  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l,locs,(x=\<^sub>AExpr e);;Stl)#EcL);
       x\<in>dom locs ; (e,l, locs, \<sigma>,v)\<in>EvalExpr
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l,locs(x\<mapsto>v),Stl)#EcL))) Rq)))  Futures" |

    AssignField  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>AExpr e);;Stl)#EcL);
       x\<notin>dom locs;  \<sigma>(l_this) = Some (Obj obj);     x\<in>dom(fst(obj));
       (e, l_this, locs, \<sigma>,v)\<in>EvalExpr;     \<sigma>'=\<sigma>(l_this\<mapsto>Obj (obj.[x]:=v))
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma>' (tasks(Q\<mapsto>((l_this,locs,Stl)#EcL))) Rq))) Futures" |

     New  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>Anew C(el));;Stl)#EcL);
       field_list=fields P C; param_list=params P C; field_list\<noteq>undefined;
       l\<notin>dom \<sigma>;
       length param_list = length el;length param_list = length value_list;
       \<forall> i<length value_list . (el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr ;
       \<sigma>'=\<sigma>(l\<mapsto> Obj (  (map_of (zip field_list (replicate (length field_list) null)))
                    ++ (map_of (zip param_list value_list)), C ))
      \<rbrakk>
      (* new term to evaluate is artificially complex because obj ref has to be encapsulated in a value and an expression*)
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma>' (tasks(Q\<mapsto>((l_this,locs,(x=\<^sub>AExpr (Val (ObjRef l));;Stl))#EcL))) Rq)) ) Futures" |

     NewActive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>AnewActive C(el));;Stl)#EcL);
       fields P C=field_list; params P C=param_list;
       \<gamma>\<notin>dom Activities;
       length param_list = length el;   length param_list = length value_list;
       \<forall> i<length value_list . ((el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr \<and> serialize (value_list!i) \<sigma> \<sigma>\<^sub>0) ;
        l\<notin>dom \<sigma>\<^sub>0;
       \<sigma>'=\<sigma>\<^sub>0(l\<mapsto> Obj (  (map_of (zip field_list (replicate (length field_list) null)))
                    ++ (map_of (zip param_list value_list)), C ))
     \<rbrakk>
        \<Longrightarrow> P\<turnstile>Cn Activities Futures
             \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l_this,locs,(x=\<^sub>AExpr (Val (ActRef \<gamma>)));;Stl)#EcL))) Rq))
                             (\<gamma>\<mapsto> (AO l \<sigma>' empty [])))  Futures" |
       (* new term to evaluate is artificially complex because obj ref has to be encapsulated in a value and an expression*)

   InvkActive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       Activities \<beta> = Some (AO l\<^sub>\<beta> \<sigma>\<^sub>\<beta> tasks\<^sub>\<beta> Rq\<^sub>\<beta>);
       tasks Q = Some ((l_this,locs,x=\<^sub>A(e.\<^sub>Am(el));;Stl)#EcL);
       \<alpha>\<noteq>\<beta>;
       (e,lt,locs,\<sigma>,ActRef \<beta>)\<in>EvalExpr;
       f\<notin>dom Futures;      l\<notin>dom \<sigma>;
       length value_list = length el;
       \<forall> i<length value_list . ((el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr) ;
       serialize_and_rename_list \<sigma>\<^sub>\<beta> value_list \<sigma> value_list' \<sigma>\<^sub>P;
        \<sigma>'=\<sigma>\<^sub>\<beta> ++ \<sigma>\<^sub>P
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> (\<sigma>(l\<mapsto>FutRef f)) (tasks(Q\<mapsto>((l_this,locs,x=\<^sub>AExpr (Val (ObjRef l));;Stl)#EcL))) Rq)
                             (\<beta>\<mapsto> AO l\<^sub>\<beta> \<sigma>' tasks\<^sub>\<beta> (Rq\<^sub>\<beta>@[(f,m,value_list')]) )) (Futures(f\<mapsto>Undefined))" |

   InvkActive_Self  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,x=\<^sub>A(e.\<^sub>Am(el));;Stl)#EcL);
       (e,l_this,locs,\<sigma>,ActRef \<alpha>)\<in>EvalExpr;
       f\<notin>dom Futures;
       length value_list = length el;
       \<forall> i<length value_list . ((el!i,l_this,locs,\<sigma>,value_list!i)\<in>EvalExpr) ;
       serialize_and_rename_list \<sigma> value_list \<sigma> value_list' \<sigma>\<^sub>P;
       \<sigma>'=\<sigma> ++ \<sigma>\<^sub>P; l\<notin>dom \<sigma>'
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> (\<sigma>'(l\<mapsto>FutRef f)) (tasks(Q\<mapsto>((l_this,locs,x=\<^sub>AExpr (Val (ObjRef l));;Stl)#EcL))) (Rq@[(f,m,value_list')])))
               (Futures(f\<mapsto>Undefined))" |

   InvkPassive  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(x=\<^sub>Ae.\<^sub>Am(el));;Stl) #EcL);
       (e,l_this,locs,\<sigma>,ObjRef l)\<in>EvalExpr;
         (\<sigma> l) = Some (Obj (obj,C));
       length vl = length el; \<forall> i<length vl . ((el!i,l_this,locs,\<sigma>,vl!i)\<in>EvalExpr) ;
        Bind P l C m vl = Some EC
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>(EC#(l_this,locs,x=\<^sub>AHole;;Stl)#EcL))) Rq) ) Futures" |

   ReturnLocal  [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this',locs',return e;;Stl)#(l_this,locs,x=\<^sub>AHole#Stl')#EcL);
       (e,l_this',locs,\<sigma>,v)\<in>EvalExpr
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma>
                             (tasks(Q\<mapsto>((l_this,locs,x=\<^sub>AExpr (Val v)#Stl')#EcL))) Rq) ) Futures" |

   ReturnRequest [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some [(l_this,locs,return e;;Stl)];   Q=(f,m,vl);
       (e,l_this,locs,\<sigma>,v)\<in>EvalExpr;  serialize v \<sigma> \<sigma>\<^sub>f
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma> (tasks|``Q) Rq) ) (Futures(f\<mapsto>FutVal v \<sigma>\<^sub>f))" |

    UpdateFuture [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       \<sigma> l = Some (FutRef f);  Futures f = Some (FutVal v \<sigma>\<^sub>f);
       rename_value_store \<sigma> v \<sigma>\<^sub>f v' \<sigma>\<^sub>r;
       \<sigma>'=(\<sigma>++\<sigma>\<^sub>r)(l\<mapsto>StoredVal v')
      \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma>' tasks Rq)) Futures"   |

    IfThenElseTrue [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(IF e THEN s\<^sub>t ELSE s\<^sub>e);;Stl)#EcL);
       (e,l_this,locs,\<sigma>,ASPBool True)\<in>EvalExpr
   \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
           \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l_this,locs,s\<^sub>t@Stl)#EcL))) Rq))) Futures"  |

    IfThenElseFalse [simp, intro!]:
     "\<lbrakk>Activities \<alpha> = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((l_this,locs,(IF e THEN s\<^sub>t ELSE s\<^sub>e);;Stl)#EcL);
       (e,l_this,locs,\<sigma>,ASPBool False)\<in>EvalExpr
   \<rbrakk>
      \<Longrightarrow> P\<turnstile>Cn Activities Futures
          \<leadsto>Cn (Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((l_this,locs,s\<^sub>e@Stl)#EcL))) Rq))) Futures"

 (*   Skip [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> tasks Rq);
       tasks Q = Some ((locs,S)#EcL);RedContext S = R[[Skip]];R\<noteq>Skip;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (tasks(Q\<mapsto>((locs,R)#EcL))) Rq))
   \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures"
   *)
(*     upd  [simp, intro!]: "l : dom f \<Longrightarrow>\<leadsto>
                         Upd (Obj f T) l a \<rightarrow>\<^sub>\<beta>  Obj (f (l \<mapsto> a)) T" |
    sel  [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Call s l u \<rightarrow>\<^sub>\<beta>  Call t l u" |
    selR [simp, intro!]: "u \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Call s l u \<rightarrow>\<^sub>\<beta>  Call s l t" |
    updL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Upd s l u \<rightarrow>\<^sub>\<beta> Upd t l u" |
    updR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Upd u l s \<rightarrow>\<^sub>\<beta> Upd u l t" |
    obj [simp, intro!]: "\<lbrakk> s \<rightarrow>\<^sub>\<beta> t; l: dom f \<rbrakk> \<Longrightarrow> Obj (f (l \<mapsto> s)) T \<rightarrow>\<^sub>\<beta> Obj (f (l \<mapsto> t)) T" |
  act [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Active s \<rightarrow>\<^sub>\<beta> Active t"
abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "->>" 50) where
  "s ->> t == beta^** s t"

notation (latex)
  beta_reds  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50)
*)

definition emptyObj :: Storable where
"emptyObj \<equiv> Obj (empty,''EmptyObjectClass'')"

definition emptyObjClass  where
"emptyObjClass \<equiv>
\<lparr>Name = ''EmptyObjectClass'',
 Interfaces=[],
 ClassParameters=[],
 StateVariables=[],
 Methods=[]
\<rparr>"

definition BuildInitialConfigurationfromVarsStl:: "(VarName list) \<Rightarrow>Statement list\<Rightarrow> Configuration"
where
  "BuildInitialConfigurationfromVarsStl vl stl \<equiv> Cn (empty(0\<mapsto>(AO 0 (empty(0\<mapsto> emptyObj))
                  (empty((0,''m'',[])\<mapsto>[(0,(map_of (zip vl (replicate (length vl) null))),stl)])) [])))
                  (empty(0\<mapsto>Undefined))"

definition InitialConfiguration:: "Program \<Rightarrow>Configuration"
where
" InitialConfiguration prog \<equiv> case prog of (Prog Is CL Vars Stl) \<Rightarrow> BuildInitialConfigurationfromVarsStl (map snd Vars) Stl"

end


(*  Title:      HOL/Auth/n_german_lemma_inv__16_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__16_on_rules imports n_german_lemma_on_inv__16
begin
section{*All lemmas on causal relation between inv__16*}
lemma lemma_inv__16_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__16  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__0Vsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__1Vsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqEVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__16) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__16) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*<*)
theory Monitor_Impl
  imports Monitor
    Optimized_MTL
    "HOL-Library.Code_Target_Nat"
    Containers.Containers
begin
(*>*)

section \<open>Instantiation of the generic algorithm and code setup\<close>

lemma [code_unfold del, symmetric, code_post del]: "card \<equiv> Cardinality.card'" by simp
declare [[code drop: card]] Set_Impl.card_code[code]

instantiation enat :: set_impl begin
definition set_impl_enat :: "(enat, set_impl) phantom" where
  "set_impl_enat = phantom set_RBT"

instance ..
end

derive ccompare Formula.trm
derive (eq) ceq Formula.trm
derive (rbt) set_impl Formula.trm
derive (eq) ceq Monitor.mregex
derive ccompare Monitor.mregex
derive (rbt) set_impl Monitor.mregex
derive (rbt) mapping_impl Monitor.mregex
derive (no) cenum Monitor.mregex
derive (rbt) set_impl event_data
derive (rbt) mapping_impl event_data

definition add_new_mmuaux' :: "args \<Rightarrow> event_data table \<Rightarrow> event_data table \<Rightarrow> ts \<Rightarrow> event_data mmuaux \<Rightarrow>
  event_data mmuaux" where
  "add_new_mmuaux' = add_new_mmuaux"

interpretation muaux valid_mmuaux init_mmuaux add_new_mmuaux' length_mmuaux eval_mmuaux
  using valid_init_mmuaux valid_add_new_mmuaux valid_length_mmuaux valid_eval_mmuaux
  unfolding add_new_mmuaux'_def
  by unfold_locales assumption+

type_synonym 'a vmsaux = "nat \<times> (nat \<times> 'a table) list"

definition valid_vmsaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmsaux \<Rightarrow>
  (nat \<times> event_data table) list \<Rightarrow> bool" where
  "valid_vmsaux = (\<lambda>_ cur (t, aux) auxlist. t = cur \<and> aux = auxlist)"

definition init_vmsaux :: "args \<Rightarrow> event_data vmsaux" where
  "init_vmsaux = (\<lambda>_. (0, []))"

definition add_new_ts_vmsaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmsaux \<Rightarrow> event_data vmsaux" where
  "add_new_ts_vmsaux = (\<lambda>args nt (t, auxlist). (nt, filter (\<lambda>(t, rel).
    enat (nt - t) \<le> right (args_ivl args)) auxlist))"

definition join_vmsaux :: "args \<Rightarrow> event_data table \<Rightarrow> event_data vmsaux \<Rightarrow> event_data vmsaux" where
  "join_vmsaux = (\<lambda>args rel1 (t, auxlist). (t, map (\<lambda>(t, rel).
    (t, join rel (args_pos args) rel1)) auxlist))"

definition add_new_table_vmsaux :: "args \<Rightarrow> event_data table \<Rightarrow> event_data vmsaux \<Rightarrow>
  event_data vmsaux" where
  "add_new_table_vmsaux = (\<lambda>args rel2 (cur, auxlist). (cur, (case auxlist of
    [] => [(cur, rel2)]
  | ((t, y) # ts) \<Rightarrow> if t = cur then (t, y \<union> rel2) # ts else (cur, rel2) # auxlist)))"

definition result_vmsaux :: "args \<Rightarrow> event_data vmsaux \<Rightarrow> event_data table" where
  "result_vmsaux = (\<lambda>args (cur, auxlist).
    foldr (\<union>) [rel. (t, rel) \<leftarrow> auxlist, left (args_ivl args) \<le> cur - t] {})"

type_synonym 'a vmuaux = "nat \<times> (nat \<times> 'a table \<times> 'a table) list"

definition valid_vmuaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmuaux \<Rightarrow>
  (nat \<times> event_data table \<times> event_data table) list \<Rightarrow> bool" where
  "valid_vmuaux = (\<lambda>_ cur (t, aux) auxlist. t = cur \<and> aux = auxlist)"

definition init_vmuaux :: "args \<Rightarrow> event_data vmuaux" where
  "init_vmuaux = (\<lambda>_. (0, []))"

definition add_new_vmuaux ::  "args \<Rightarrow> event_data table \<Rightarrow> event_data table \<Rightarrow> nat \<Rightarrow>
  event_data vmuaux \<Rightarrow> event_data vmuaux" where
  "add_new_vmuaux = (\<lambda>args rel1 rel2 nt (t, auxlist). (nt, update_until args rel1 rel2 nt auxlist))"

definition length_vmuaux :: "args \<Rightarrow> event_data vmuaux \<Rightarrow> nat" where
  "length_vmuaux = (\<lambda>_ (_, auxlist). length auxlist)"

definition eval_vmuaux :: "args \<Rightarrow> nat \<Rightarrow> event_data vmuaux \<Rightarrow>
  event_data table list \<times> event_data vmuaux" where
  "eval_vmuaux = (\<lambda>args nt (t, auxlist).
    (let (res, auxlist') = eval_until (args_ivl args) nt auxlist in (res, (t, auxlist'))))"

global_interpretation verimon_maux: maux valid_vmsaux init_vmsaux add_new_ts_vmsaux join_vmsaux
  add_new_table_vmsaux result_vmsaux valid_vmuaux init_vmuaux add_new_vmuaux length_vmuaux
  eval_vmuaux
  defines vminit0 = "maux.minit0 (init_vmsaux :: _ \<Rightarrow> event_data vmsaux) (init_vmuaux :: _ \<Rightarrow> event_data vmuaux) :: _ \<Rightarrow> Formula.formula \<Rightarrow> _"
  and vminit = "maux.minit (init_vmsaux :: _ \<Rightarrow> event_data vmsaux) (init_vmuaux :: _ \<Rightarrow> event_data vmuaux) :: Formula.formula \<Rightarrow> _"
  and vminit_safe = "maux.minit_safe (init_vmsaux :: _ \<Rightarrow> event_data vmsaux) (init_vmuaux :: _ \<Rightarrow> event_data vmuaux) :: Formula.formula \<Rightarrow> _"
  and vmupdate_since = "maux.update_since add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> event_data table)"
  and vmeval = "maux.meval add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmstep = "maux.mstep add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmsteps0_stateless = "maux.msteps0_stateless add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmsteps_stateless = "maux.msteps_stateless add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  and vmonitor = "maux.monitor init_vmsaux add_new_ts_vmsaux join_vmsaux add_new_table_vmsaux (result_vmsaux :: _ \<Rightarrow> event_data vmsaux \<Rightarrow> _) init_vmuaux add_new_vmuaux (eval_vmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data vmuaux \<Rightarrow> _)"
  unfolding valid_vmsaux_def init_vmsaux_def add_new_ts_vmsaux_def join_vmsaux_def
    add_new_table_vmsaux_def result_vmsaux_def valid_vmuaux_def init_vmuaux_def add_new_vmuaux_def
    length_vmuaux_def eval_vmuaux_def
  by unfold_locales auto

global_interpretation default_maux: maux valid_mmsaux "init_mmsaux :: _ \<Rightarrow> event_data mmsaux" add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux result_mmsaux
  valid_mmuaux "init_mmuaux :: _ \<Rightarrow> event_data mmuaux" add_new_mmuaux' length_mmuaux eval_mmuaux
  defines minit0 = "maux.minit0 (init_mmsaux :: _ \<Rightarrow> event_data mmsaux) (init_mmuaux :: _ \<Rightarrow> event_data mmuaux) :: _ \<Rightarrow> Formula.formula \<Rightarrow> _"
  and minit = "maux.minit (init_mmsaux :: _ \<Rightarrow> event_data mmsaux) (init_mmuaux :: _ \<Rightarrow> event_data mmuaux) :: Formula.formula \<Rightarrow> _"
  and minit_safe = "maux.minit_safe (init_mmsaux :: _ \<Rightarrow> event_data mmsaux) (init_mmuaux :: _ \<Rightarrow> event_data mmuaux) :: Formula.formula \<Rightarrow> _"
  and mupdate_since = "maux.update_since add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> event_data table)"
  and meval = "maux.meval add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and mstep = "maux.mstep add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and msteps0_stateless = "maux.msteps0_stateless add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and msteps_stateless = "maux.msteps_stateless add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  and monitor = "maux.monitor init_mmsaux add_new_ts_mmsaux gc_join_mmsaux add_new_table_mmsaux (result_mmsaux :: _ \<Rightarrow> event_data mmsaux \<Rightarrow> _) init_mmuaux add_new_mmuaux' (eval_mmuaux :: _ \<Rightarrow> _ \<Rightarrow> event_data mmuaux \<Rightarrow> _)"
  by unfold_locales

lemma image_these: "f ` Option.these X = Option.these (map_option f ` X)"
  by (force simp: in_these_eq Bex_def image_iff map_option_case split: option.splits)

thm default_maux.meval.simps(2)

lemma meval_MPred: "meval n t db (MPred e ts) =
  (case Mapping.lookup db e of None \<Rightarrow> [{}] | Some Xs \<Rightarrow> map (\<lambda>X. \<Union>v \<in> X.
  (set_option (map_option (\<lambda>f. Table.tabulate f 0 n) (match ts v)))) Xs, MPred e ts)"
  by (force split: option.splits simp: Option.these_def image_iff)

lemmas meval_code[code] = default_maux.meval.simps(1) meval_MPred default_maux.meval.simps(3-)

definition mk_db :: "(Formula.name \<times> event_data list set) list \<Rightarrow> _" where
  "mk_db t = Monitor.mk_db (\<Union>n \<in> set (map fst t). (\<lambda>v. (n, v)) ` the (map_of t n))"

definition rbt_fold :: "_ \<Rightarrow> event_data tuple set_rbt \<Rightarrow> _ \<Rightarrow> _" where
  "rbt_fold = RBT_Set2.fold"

definition rbt_empty :: "event_data list set_rbt" where
  "rbt_empty = RBT_Set2.empty"

definition rbt_insert :: "_ \<Rightarrow> _ \<Rightarrow> event_data list set_rbt" where
  "rbt_insert = RBT_Set2.insert"

lemma saturate_commute:
  assumes "\<And>s. r \<in> g s" "\<And>s. g (insert r s) = g s" "\<And>s. r \<in> s \<Longrightarrow> h s = g s"
  and terminates: "mono g" "\<And>X. X \<subseteq> C \<Longrightarrow> g X \<subseteq> C" "finite C"
shows "saturate g {} = saturate h {r}"
proof (cases "g {} = {r}")
  case True
  with assms have "g {r} = {r}" "h {r} = {r}" by auto
  with True show ?thesis
    by (subst (1 2) saturate_code; subst saturate_code) (simp add: Let_def)
next
  case False
  then show ?thesis
    unfolding saturate_def while_def
    using while_option_finite_subset_Some[OF terminates] assms(1-3)
    by (subst while_option_commute_invariant[of "\<lambda>S. S = {} \<or> r \<in> S" "\<lambda>S. g S \<noteq> S" g "\<lambda>S. h S \<noteq> S" "insert r" h "{}", symmetric])
      (auto 4 4 dest: while_option_stop[of "\<lambda>S. g S \<noteq> S" g "{}"])
qed

definition "RPDs_aux = saturate (\<lambda>S. S \<union> \<Union> (RPD ` S))"

lemma RPDs_aux_code[code]:
  "RPDs_aux S = (let S' = S \<union> Set.bind S RPD in if S' \<subseteq> S then S else RPDs_aux S')"
  unfolding RPDs_aux_def bind_UNION
  by (subst saturate_code) auto

declare RPDs_code[code del]
lemma RPDs_code[code]: "RPDs r = RPDs_aux {r}"
  unfolding RPDs_aux_def RPDs_code
  by (rule saturate_commute[where C="RPDs r"])
     (auto 0 3 simp: mono_def subset_singleton_iff RPDs_refl RPDs_trans finite_RPDs)

definition "LPDs_aux = saturate (\<lambda>S. S \<union> \<Union> (LPD ` S))"

lemma LPDs_aux_code[code]:
  "LPDs_aux S = (let S' = S \<union> Set.bind S LPD in if S' \<subseteq> S then S else LPDs_aux S')"
  unfolding LPDs_aux_def bind_UNION
  by (subst saturate_code) auto

declare LPDs_code[code del]
lemma LPDs_code[code]: "LPDs r = LPDs_aux {r}"
  unfolding LPDs_aux_def LPDs_code
  by (rule saturate_commute[where C="LPDs r"])
     (auto 0 3 simp: mono_def subset_singleton_iff LPDs_refl LPDs_trans finite_LPDs)

lemma is_empty_table_unfold [code_unfold]:
  "X = empty_table \<longleftrightarrow> Set.is_empty X"
  "empty_table = X \<longleftrightarrow> Set.is_empty X"
  "Cardinality.eq_set X empty_table \<longleftrightarrow> Set.is_empty X"
  "Cardinality.eq_set empty_table X \<longleftrightarrow> Set.is_empty X"
  "set_eq X empty_table \<longleftrightarrow> Set.is_empty X"
  "set_eq empty_table X \<longleftrightarrow> Set.is_empty X"
  "X = (set_empty impl) \<longleftrightarrow> Set.is_empty X"
  "(set_empty impl) = X \<longleftrightarrow> Set.is_empty X"
  "Cardinality.eq_set X (set_empty impl) \<longleftrightarrow> Set.is_empty X"
  "Cardinality.eq_set (set_empty impl) X \<longleftrightarrow> Set.is_empty X"
  "set_eq X (set_empty impl) \<longleftrightarrow> Set.is_empty X"
  "set_eq (set_empty impl) X \<longleftrightarrow> Set.is_empty X"
  unfolding set_eq_def set_empty_def empty_table_def Set.is_empty_def Cardinality.eq_set_def by auto

lemma tabulate_rbt_code[code]: "Monitor.mrtabulate (xs :: mregex list) f =
  (case ID CCOMPARE(mregex) of None \<Rightarrow> Code.abort (STR ''tabulate RBT_Mapping: ccompare = None'') (\<lambda>_. Monitor.mrtabulate (xs :: mregex list) f)
  | _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.bulkload (List.map_filter (\<lambda>k. let fk = f k in if fk = empty_table then None else Some (k, fk)) xs)))"
  unfolding mrtabulate.abs_eq RBT_Mapping_def
  by (auto split: option.splits)

lemma combine_Mapping[code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.combine f (RBT_Mapping t) (RBT_Mapping u) =
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''combine RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.combine f (RBT_Mapping t) (RBT_Mapping u))
                     | Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.join (\<lambda>_. f) t u))"
  by (auto simp add: Mapping.combine.abs_eq Mapping_inject lookup_join split: option.split)

lemma upd_set_empty[simp]: "upd_set m f {} = m"
  by transfer auto

lemma upd_set_insert[simp]: "upd_set m f (insert x A) = Mapping.update x (f x) (upd_set m f A)"
  by (rule mapping_eqI) (auto simp: Mapping_lookup_upd_set Mapping.lookup_update')

lemma upd_set_fold:
  assumes "finite A"
  shows "upd_set m f A = Finite_Set.fold (\<lambda>a. Mapping.update a (f a)) m A"
proof -
  interpret comp_fun_idem "\<lambda>a. Mapping.update a (f a)"
    by unfold_locales (transfer; auto simp: fun_eq_iff)+
  from assms show ?thesis
    by (induct A arbitrary: m rule: finite.induct) auto
qed

lift_definition upd_cfi :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, ('a, 'b) mapping) comp_fun_idem"
  is "\<lambda>f a m. Mapping.update a (f a) m"
  by unfold_locales (transfer; auto simp: fun_eq_iff)+

lemma upd_set_code[code]:
  "upd_set m f A = (if finite A then set_fold_cfi (upd_cfi f) m A else Code.abort (STR ''upd_set: infinite'') (\<lambda>_. upd_set m f A))"
  by (transfer fixing: m) (auto simp: upd_set_fold)

lemma lexordp_eq_code[code]: "lexordp_eq xs ys \<longleftrightarrow> (case xs of [] \<Rightarrow> True
  | x # xs \<Rightarrow> (case ys of [] \<Rightarrow> False
    | y # ys \<Rightarrow> if x < y then True else if x > y then False else lexordp_eq xs ys))"
  by (subst lexordp_eq.simps) (auto split: list.split)

definition "filter_set m X t = Mapping.filter (filter_cond X m t) m"

declare [[code drop: shift_end]]
declare shift_end.simps[folded filter_set_def, code]

lemma upd_set'_empty[simp]: "upd_set' m d f {} = m"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup)

lemma upd_set'_insert: "d = f d \<Longrightarrow> (\<And>x. f (f x) = f x) \<Longrightarrow> upd_set' m d f (insert x A) =
  (let m' = (upd_set' m d f A) in case Mapping.lookup m' x of None \<Rightarrow> Mapping.update x d m'
  | Some v \<Rightarrow> Mapping.update x (f v) m')"
  by (rule mapping_eqI) (auto simp: upd_set'_lookup Mapping.lookup_update' split: option.splits)

lemma upd_set'_aux1: "upd_set' Mapping.empty d f {b. b = k \<or> (a, b) \<in> A} =
  Mapping.update k d (upd_set' Mapping.empty d f {b. (a, b) \<in> A})"
  by (rule mapping_eqI) (auto simp add: Let_def upd_set'_lookup Mapping.lookup_update'
      Mapping.lookup_empty split: option.splits)

lemma upd_set'_aux2: "Mapping.lookup m k = None \<Longrightarrow> upd_set' m d f {b. b = k \<or> (a, b) \<in> A} =
  Mapping.update k d (upd_set' m d f {b. (a, b) \<in> A})"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup Mapping.lookup_update' split: option.splits)

lemma upd_set'_aux3: "Mapping.lookup m k = Some v \<Longrightarrow> upd_set' m d f {b. b = k \<or> (a, b) \<in> A} =
  Mapping.update k (f v) (upd_set' m d f {b. (a, b) \<in> A})"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup Mapping.lookup_update' split: option.splits)

lemma upd_set'_aux4: "k \<notin> fst ` A \<Longrightarrow> upd_set' Mapping.empty d f {b. (k, b) \<in> A} = Mapping.empty"
  by (rule mapping_eqI) (auto simp add: upd_set'_lookup Mapping.lookup_update' Domain.DomainI fst_eq_Domain
      split: option.splits)

lemma upd_nested_empty[simp]: "upd_nested m d f {} = m"
  by (rule mapping_eqI) (auto simp add: upd_nested_lookup split: option.splits)

definition upd_nested_step :: "'c \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> ('a, ('b, 'c) mapping) mapping \<Rightarrow>
  ('a, ('b, 'c) mapping) mapping" where
  "upd_nested_step d f x m = (case x of (k, k') \<Rightarrow>
    (case Mapping.lookup m k of Some m' \<Rightarrow>
      (case Mapping.lookup m' k' of Some v \<Rightarrow> Mapping.update k (Mapping.update k' (f v) m') m
      | None \<Rightarrow> Mapping.update k (Mapping.update k' d m') m)
    | None \<Rightarrow> Mapping.update k (Mapping.update k' d Mapping.empty) m))"

lemma upd_nested_insert:
  "d = f d \<Longrightarrow> (\<And>x. f (f x) = f x) \<Longrightarrow> upd_nested m d f (insert x A) =
  upd_nested_step d f x (upd_nested m d f A)"
  unfolding upd_nested_step_def
  using upd_set'_aux1[of d f _ _ A] upd_set'_aux2[of _ _ d f _ A] upd_set'_aux3[of _ _ _ d f _ A]
    upd_set'_aux4[of _ A d f]
  by (auto simp add: Let_def upd_nested_lookup upd_set'_lookup Mapping.lookup_update'
      Mapping.lookup_empty split: option.splits prod.splits if_splits intro!: mapping_eqI)

definition upd_nested_max_tstp where
  "upd_nested_max_tstp m d X = upd_nested m d (max_tstp d) X"

lemma upd_nested_max_tstp_fold:
  assumes "finite X"
  shows "upd_nested_max_tstp m d X = Finite_Set.fold (upd_nested_step d (max_tstp d)) m X"
proof -
  interpret comp_fun_idem "upd_nested_step d (max_tstp d)"
    by (unfold_locales; rule ext)
      (auto simp add: comp_def upd_nested_step_def Mapping.lookup_update' Mapping.lookup_empty
       update_update max_tstp_d_d max_tstp_idem' split: option.splits)
  note upd_nested_insert' = upd_nested_insert[of d "max_tstp d",
    OF max_tstp_d_d[symmetric] max_tstp_idem']
  show ?thesis
    using assms
    by (induct X arbitrary: m rule: finite.induct)
       (auto simp add: upd_nested_max_tstp_def upd_nested_insert')
qed

lift_definition upd_nested_max_tstp_cfi ::
  "ts + tp \<Rightarrow> ('a \<times> 'b, ('a, ('b, ts + tp) mapping) mapping) comp_fun_idem"
  is "\<lambda>d. upd_nested_step d (max_tstp d)"
  by (unfold_locales; rule ext)
    (auto simp add: comp_def upd_nested_step_def Mapping.lookup_update' Mapping.lookup_empty
      update_update max_tstp_d_d max_tstp_idem' split: option.splits)

lemma upd_nested_max_tstp_code[code]:
  "upd_nested_max_tstp m d X = (if finite X then set_fold_cfi (upd_nested_max_tstp_cfi d) m X
    else Code.abort (STR ''upd_nested_max_tstp: infinite'') (\<lambda>_. upd_nested_max_tstp m d X))"
  by transfer (auto simp add: upd_nested_max_tstp_fold)

declare [[code drop: add_new_mmuaux']]
declare add_new_mmuaux'_def[unfolded add_new_mmuaux.simps, folded upd_nested_max_tstp_def, code]

lemma filter_set_empty[simp]: "filter_set m {} t = m"
  unfolding filter_set_def
  by transfer (auto simp: fun_eq_iff split: option.splits)

lemma filter_set_insert[simp]: "filter_set m (insert x A) t = (let m' = filter_set m A t in
  case Mapping.lookup m' x of Some u \<Rightarrow> if t = u then Mapping.delete x m' else m' | _ \<Rightarrow> m')"
  unfolding filter_set_def
  by transfer (auto simp: fun_eq_iff Let_def Map_To_Mapping.map_apply_def split: option.splits)

lemma filter_set_fold:
  assumes "finite A"
  shows "filter_set m A t = Finite_Set.fold (\<lambda>a m.
    case Mapping.lookup m a of Some u \<Rightarrow> if t = u then Mapping.delete a m else m | _ \<Rightarrow> m) m A"
proof -
  interpret comp_fun_idem "\<lambda>a m.
    case Mapping.lookup m a of Some u \<Rightarrow> if t = u then Mapping.delete a m else m | _ \<Rightarrow> m"
    by unfold_locales
      (transfer; auto simp: fun_eq_iff Map_To_Mapping.map_apply_def split: option.splits)+
  from assms show ?thesis
    by (induct A arbitrary: m rule: finite.induct) (auto simp: Let_def)
qed

lift_definition filter_cfi :: "'b \<Rightarrow> ('a, ('a, 'b) mapping) comp_fun_idem"
  is "\<lambda>t a m.
    case Mapping.lookup m a of Some u \<Rightarrow> if t = u then Mapping.delete a m else m | _ \<Rightarrow> m"
  by unfold_locales
    (transfer; auto simp: fun_eq_iff Map_To_Mapping.map_apply_def split: option.splits)+

lemma filter_set_code[code]:
  "filter_set m A t = (if finite A then set_fold_cfi (filter_cfi t) m A else Code.abort (STR ''upd_set: infinite'') (\<lambda>_. filter_set m A t))"
  by (transfer fixing: m) (auto simp: filter_set_fold)

lemma filter_Mapping[code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.filter P (RBT_Mapping t) =
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''filter RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.filter P (RBT_Mapping t))
                     | Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.filter (case_prod P) t))"
  by (auto simp add: Mapping.filter.abs_eq Mapping_inject split: option.split)

definition "filter_join pos X m = Mapping.filter (join_filter_cond pos X) m"

declare [[code drop: join_mmsaux]]
declare join_mmsaux.simps[folded filter_join_def, code]

lemma filter_join_False_empty: "filter_join False {} m = m"
  unfolding filter_join_def
  by transfer (auto split: option.splits)

lemma filter_join_False_insert: "filter_join False (insert a A) m =
  filter_join False A (Mapping.delete a m)"
proof -
  {
    fix x
    have "Mapping.lookup (filter_join False (insert a A) m) x =
      Mapping.lookup (filter_join False A (Mapping.delete a m)) x"
      by (auto simp add: filter_join_def Mapping.lookup_filter Mapping_lookup_delete
          split: option.splits)
  }
  then show ?thesis
    by (simp add: mapping_eqI)
qed

lemma filter_join_False:
  assumes "finite A"
  shows "filter_join False A m = Finite_Set.fold Mapping.delete m A"
proof -
  interpret comp_fun_idem "Mapping.delete"
    by (unfold_locales; transfer) (fastforce simp add: comp_def)+
  from assms show ?thesis
    by (induction A arbitrary: m rule: finite.induct)
       (auto simp add: filter_join_False_empty filter_join_False_insert fold_fun_left_comm)
qed

lift_definition filter_not_in_cfi :: "('a, ('a, 'b) mapping) comp_fun_idem" is "Mapping.delete"
  by (unfold_locales; transfer) (fastforce simp add: comp_def)+

lemma filter_join_code[code]:
  "filter_join pos A m =
    (if \<not>pos \<and> finite A \<and> card A < Mapping.size m then set_fold_cfi filter_not_in_cfi m A
    else Mapping.filter (join_filter_cond pos A) m)"
  unfolding filter_join_def
  by (transfer fixing: m) (use filter_join_False in \<open>auto simp add: filter_join_def\<close>)

definition set_minus :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "set_minus X Y = X - Y"

lift_definition remove_cfi :: "('a, 'a set) comp_fun_idem"
  is "\<lambda>b a. a - {b}"
  by unfold_locales auto

lemma set_minus_finite:
  assumes fin: "finite Y"
  shows "set_minus X Y = Finite_Set.fold (\<lambda>a X. X - {a}) X Y"
proof -
  interpret comp_fun_idem "\<lambda>a X. X - {a}"
    by unfold_locales auto
  from assms show ?thesis
    by (induction Y arbitrary: X rule: finite.induct) (auto simp add: set_minus_def)
qed

lemma set_minus_code[code]: "set_minus X Y =
  (if finite Y \<and> card Y < card X then set_fold_cfi remove_cfi X Y else X - Y)"
  by transfer (use set_minus_finite in \<open>auto simp add: set_minus_def\<close>)

declare [[code drop: bin_join]]
declare bin_join.simps[folded set_minus_def, code]

definition remove_Union where
  "remove_Union A X B = A - (\<Union>x \<in> X. B x)"

lemma remove_Union_finite:
  assumes "finite X"
  shows "remove_Union A X B = Finite_Set.fold (\<lambda>x A. A - B x) A X"
proof -
  interpret comp_fun_idem "\<lambda>x A. A - B x"
    by unfold_locales auto
  from assms show ?thesis
    by (induct X arbitrary: A rule: finite_induct) (auto simp: remove_Union_def)
qed

lift_definition remove_Union_cfi :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a, 'b set) comp_fun_idem" is "\<lambda>B x A. A - B x"
  by unfold_locales auto

lemma remove_Union_code[code]: "remove_Union A X B =
  (if finite X then set_fold_cfi (remove_Union_cfi B) A X else A - (\<Union>x \<in> X. B x))"
  by (transfer fixing: A X B) (use remove_Union_finite[of X A B] in \<open>auto simp add: remove_Union_def\<close>)

lemma tabulate_remdups: "Mapping.tabulate xs f = Mapping.tabulate (remdups xs) f"
  by (transfer fixing: xs f) (auto simp: map_of_map_restrict)

lift_definition clearjunk :: "(String.literal \<times> event_data list set) list \<Rightarrow> (String.literal, event_data list set list) alist" is
  "\<lambda>t. List.map_filter (\<lambda>(p, X). if X = {} then None else Some (p, [X])) (AList.clearjunk t)"
  unfolding map_filter_def o_def list.map_comp
  by (subst map_cong[OF refl, of _ _ fst]) (auto simp: map_filter_def distinct_map_fst_filter split: if_splits)

lemma map_filter_snd_map_filter: "List.map_filter (\<lambda>(a, b). if P b then None else Some (f a b)) xs =
    map (\<lambda>(a, b). f a b) (filter (\<lambda>x. \<not> P (snd x)) xs)"
  by (simp add: map_filter_def prod.case_eq_if)

lemma mk_db_code_alist:
  "mk_db t = Assoc_List_Mapping (clearjunk t)"
  unfolding mk_db_def Assoc_List_Mapping_def
  by (transfer' fixing: t)
    (auto simp: map_filter_snd_map_filter fun_eq_iff map_of_map image_iff map_of_clearjunk
      map_of_filter_apply dest: weak_map_of_SomeI intro!: bexI[rotated, OF map_of_SomeD]
      split: if_splits option.splits)

lemma mk_db_code[code]:
  "mk_db t = Mapping.of_alist (List.map_filter (\<lambda>(p, X). if X = {} then None else Some (p, [X])) (AList.clearjunk t))"
  unfolding mk_db_def
  by (transfer' fixing: t) (auto simp: map_filter_snd_map_filter fun_eq_iff map_of_map image_iff
      map_of_clearjunk map_of_filter_apply dest: weak_map_of_SomeI intro!: bexI[rotated, OF map_of_SomeD]
      split: if_splits option.splits)

declare [[code drop: New_max_getIJ_genericJoin New_max_getIJ_wrapperGenericJoin]]
declare New_max.genericJoin.simps[folded remove_Union_def, code]
declare New_max.wrapperGenericJoin.simps[folded remove_Union_def, code]

(*<*)
end
(*>*)