(*<*)
theory Formula
  imports
    Event_Data
    Regex
    "MFOTL_Monitor_Devel.Interval"
    "MFOTL_Monitor_Devel.Trace"
    "MFOTL_Monitor_Devel.Abstract_Monitor"
    "HOL-Library.Mapping"
    Containers.Set_Impl
begin
(*>*)

section \<open>Metric first-order dynamic logic\<close>

subsection \<open> Instantiations \<close>

derive (eq) ceq enat

instantiation enat :: ccompare begin
definition ccompare_enat :: "enat comparator option" where
  "ccompare_enat = Some (\<lambda>x y. if x = y then order.Eq else if x < y then order.Lt else order.Gt)"

instance by intro_classes
    (auto simp: ccompare_enat_def split: if_splits intro!: comparator.intro)
end

instantiation enat :: card_UNIV begin
definition "finite_UNIV = Phantom(enat) False"
definition "card_UNIV = Phantom(enat) 0"
instance by intro_classes (simp_all add: finite_UNIV_enat_def card_UNIV_enat_def infinite_UNIV_char_0)
end

datatype rec_safety = Unused | PastRec | NonFutuRec | AnyRec

instantiation rec_safety :: "{finite, bounded_semilattice_sup_bot, monoid_mult, mult_zero}"
begin

fun less_eq_rec_safety where
  "Unused \<le> _ = True"
| "PastRec \<le> PastRec = True"
| "PastRec \<le> NonFutuRec = True"
| "PastRec \<le> AnyRec = True"
| "NonFutuRec \<le> NonFutuRec = True"
| "NonFutuRec \<le> AnyRec = True"
| "AnyRec \<le> AnyRec = True"
| "(_::rec_safety) \<le> _ = False"

definition "(x::rec_safety) < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

definition [code_unfold]: "\<bottom> = Unused"

fun sup_rec_safety where
  "AnyRec \<squnion> _ = AnyRec"
| "_ \<squnion> AnyRec = AnyRec"
| "NonFutuRec \<squnion> _ = NonFutuRec"
| "_ \<squnion> NonFutuRec = NonFutuRec"
| "PastRec \<squnion> _ = PastRec"
| "_ \<squnion> PastRec = PastRec"
| "Unused \<squnion> Unused = Unused"

definition [code_unfold]: "0 = Unused"
definition [code_unfold]: "1 = NonFutuRec"

fun times_rec_safety where
  "Unused * _ = Unused"
| "_ * Unused = Unused"
| "AnyRec * _ = AnyRec"
| "_ * AnyRec = AnyRec"
| "PastRec * _ = PastRec"
| "_ * PastRec = PastRec"
| "NonFutuRec * NonFutuRec = NonFutuRec"

instance proof
  fix x y z :: rec_safety
  have "x \<in> {Unused, PastRec, NonFutuRec, AnyRec}" for x
    by (cases x) simp_all
  then have UNIV_alt: "UNIV = \<dots>" by blast
  show "finite (UNIV :: rec_safety set)"
    unfolding UNIV_alt by blast
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    unfolding less_rec_safety_def
    by (cases x; cases y) simp_all
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "\<bottom> \<le> x"
    unfolding bot_rec_safety_def
    by (cases x) simp_all
  show "(x * y) * z = x * (y * z)"
    by (cases x; cases y; cases z) simp_all
  show "1 * x = x"
    unfolding one_rec_safety_def
    by (cases x) simp_all
  show "x * 1 = x"
    unfolding one_rec_safety_def
    by (cases x) simp_all
  show "0 * x = 0"
    unfolding zero_rec_safety_def by simp
  show "x * 0 = 0"
    unfolding zero_rec_safety_def
    by (cases x) simp_all
qed

end

instantiation rec_safety :: Sup
begin

definition "\<Squnion> A = Finite_Set.fold (\<squnion>) Unused A"

instance ..

end

lemma (in semilattice_sup) comp_fun_idem_on_sup: "comp_fun_idem_on UNIV sup"
  using comp_fun_idem_sup by (simp add: comp_fun_idem_def')

lemma Sup_rec_safety_empty[simp]: "\<Squnion> {} = Unused"
  by (simp add: Sup_rec_safety_def)

lemma Sup_rec_safety_insert[simp]: "\<Squnion>(insert (x::rec_safety) A) = x \<squnion> \<Squnion>A"
  by (simp add: Sup_rec_safety_def comp_fun_idem_on.fold_insert_idem[OF comp_fun_idem_on_sup])

lemma Sup_rec_safety_union: "\<Squnion>((A::rec_safety set) \<union> B) = \<Squnion>A \<squnion> \<Squnion>B"
  unfolding Sup_rec_safety_def
  using finite[of A]
  by (induction A rule: finite_induct) (simp_all flip: bot_rec_safety_def
      add: comp_fun_idem_on.fold_insert_idem[OF comp_fun_idem_on_sup] sup_assoc)

context begin

subsection \<open>Syntax and semantics\<close>

qualified type_synonym name = string8
qualified type_synonym event = "(name \<times> event_data list)"
qualified type_synonym database = "event set"
qualified type_synonym prefix = "database prefix"
qualified type_synonym trace = "database trace"

qualified type_synonym env = "event_data list"

subsubsection \<open>Terms\<close>

qualified datatype trm = is_Var: Var nat | is_Const: Const event_data
  | Plus trm trm | Minus trm trm | UMinus trm | Mult trm trm | Div trm trm | Mod trm trm
  | F2i trm | I2f trm

lemma trm_exhaust: "(\<And>x. t = Var x \<Longrightarrow> P (Var x))
  \<Longrightarrow> (\<And>a. t = Const a \<Longrightarrow> P (Const a))
  \<Longrightarrow> (\<And>t1 t2. t = Plus t1 t2 \<Longrightarrow> P (Plus t1 t2))
  \<Longrightarrow> (\<And>t1 t2. t = Minus t1 t2 \<Longrightarrow> P (Minus t1 t2))
  \<Longrightarrow> (\<And>t1. t = UMinus t1 \<Longrightarrow> P (UMinus t1))
  \<Longrightarrow> (\<And>t1 t2. t = Mult t1 t2 \<Longrightarrow> P (Mult t1 t2))
  \<Longrightarrow> (\<And>t1 t2. t = Div t1 t2 \<Longrightarrow> P (Div t1 t2))
  \<Longrightarrow> (\<And>t1 t2. t = Mod t1 t2 \<Longrightarrow> P (Mod t1 t2))
  \<Longrightarrow> (\<And>t1. t = F2i t1 \<Longrightarrow> P (F2i t1))
  \<Longrightarrow> (\<And>t1. t = I2f t1 \<Longrightarrow> P (I2f t1))
  \<Longrightarrow> P t"
  by (cases t, simp_all)

text \<open> In this implementation of MFODL, to use De Bruijn indices, binding operators increase the
value of the bounding number @{term b} (that starts at $0$) and this number is subtracted from
all free variables (type @{typ nat}) greater than @{term b}. For instance, the free variable of
$\exists.\ P\, (Var 0) \land Q\, (Var 1)$ is @{term "Var 0"} because the existential makes $b=1$
and this value is subtracted from $Q$s argument while that of $P$ is not even taken into account. \<close>

qualified primrec fvi_trm :: "nat \<Rightarrow> trm \<Rightarrow> nat set" where
  "fvi_trm b (Var x) = (if b \<le> x then {x - b} else {})"
| "fvi_trm b (Const _) = {}"
| "fvi_trm b (Plus x y) = fvi_trm b x \<union> fvi_trm b y"
| "fvi_trm b (Minus x y) = fvi_trm b x \<union> fvi_trm b y"
| "fvi_trm b (UMinus x) = fvi_trm b x"
| "fvi_trm b (Mult x y) = fvi_trm b x \<union> fvi_trm b y"
| "fvi_trm b (Div x y) = fvi_trm b x \<union> fvi_trm b y"
| "fvi_trm b (Mod x y) = fvi_trm b x \<union> fvi_trm b y"
| "fvi_trm b (F2i x) = fvi_trm b x"
| "fvi_trm b (I2f x) = fvi_trm b x"

abbreviation "fv_trm \<equiv> fvi_trm 0"

qualified primrec eval_trm :: "env \<Rightarrow> trm \<Rightarrow> event_data" where
  "eval_trm v (Var x) = v ! x"
| "eval_trm v (Const x) = x"
| "eval_trm v (Plus x y) = eval_trm v x + eval_trm v y"
| "eval_trm v (Minus x y) = eval_trm v x - eval_trm v y"
| "eval_trm v (UMinus x) = - eval_trm v x"
| "eval_trm v (Mult x y) = eval_trm v x * eval_trm v y"
| "eval_trm v (Div x y) = eval_trm v x div eval_trm v y"
| "eval_trm v (Mod x y) = eval_trm v x mod eval_trm v y"
| "eval_trm v (F2i x) = EInt (integer_of_event_data (eval_trm v x))"
| "eval_trm v (I2f x) = EFloat (double_of_event_data (eval_trm v x))"

lemma eval_trm_fv_cong: "\<forall>x\<in>fv_trm t. v ! x = v' ! x \<Longrightarrow> eval_trm v t = eval_trm v' t"
  by (induction t) simp_all

subsubsection \<open>Formulas\<close>

text \<open> Aggregation operators @{term "Agg nat agg_op nat trm formula"} are special
formulas with five parameters:
\begin{itemize}
\item Variable @{term "y::nat"} that saves the value of the aggregation operation.
\item Type of aggregation (sum, avg, min, max, ...).
\item Binding number @{term "b::nat"} for many variables in the next two arguments.
\item Term @{term "t::trm"} that represents an operation to be aggregated.
\item Formula @{term "\<phi>"} that restricts the domain where the aggregation takes place.
\end{itemize} \<close>

datatype ty = TInt | TFloat | TString

qualified datatype agg_type = Agg_Cnt | Agg_Min | Agg_Max | Agg_Sum | Agg_Avg | Agg_Med
qualified type_synonym 't agg_op = "agg_type \<times> 't"

definition flatten_multiset :: "(event_data \<times> enat) set \<Rightarrow> event_data list" where
  "flatten_multiset M = concat (map (\<lambda>(x, c). replicate (the_enat c) x) (csorted_list_of_set M))"

definition finite_multiset :: "(event_data \<times> enat) set \<Rightarrow> bool" where
"finite_multiset M = (finite M \<and> \<not>(\<exists>s. (s,\<infinity>) \<in> M ))"

definition aggreg_default_value :: "agg_type \<Rightarrow> ty \<Rightarrow> event_data" where
  "aggreg_default_value op t = (case (op, t) of
    (Agg_Min, TFloat) \<Rightarrow> EFloat Code_Double.infinity |
    (Agg_Max, TFloat) \<Rightarrow> EFloat (-Code_Double.infinity) |
    (_, TFloat) \<Rightarrow> EFloat 0 |
    (_, TInt) \<Rightarrow> EInt 0 |
    (_, TString) \<Rightarrow> EString empty_string)"

fun eval_agg_op :: "ty agg_op \<Rightarrow> (event_data \<times> enat) set \<Rightarrow> event_data" where
  "eval_agg_op (Agg_Cnt, ty) M = (let y0 = aggreg_default_value Agg_Cnt ty in
    case (flatten_multiset M, finite_multiset M) of
    (_, False) \<Rightarrow> y0
    |    ([],_) \<Rightarrow> y0
    | (xs,_) \<Rightarrow> EInt (integer_of_int (length xs)))"
| "eval_agg_op (Agg_Min, ty) M = (let y0 = aggreg_default_value Agg_Min ty in
    case  (flatten_multiset M, finite_multiset M) of
    (_, False) \<Rightarrow> y0
    |    ([],_) \<Rightarrow> y0
    | (x # xs,_) \<Rightarrow> foldl min x xs)"
| "eval_agg_op (Agg_Max, ty) M = (let y0 = aggreg_default_value Agg_Max ty in
    case  (flatten_multiset M, finite_multiset M) of
    (_, False) \<Rightarrow> y0
    |    ([],_) \<Rightarrow> y0
    | (x # xs,_) \<Rightarrow> foldl max x xs)"
| "eval_agg_op (agg_type.Agg_Sum, ty) M = (let y0 = aggreg_default_value Agg_Sum ty in
    case  (flatten_multiset M, finite_multiset M) of
    (_, False) \<Rightarrow> y0
    |    ([],_) \<Rightarrow> y0
    | (x # xs,_) \<Rightarrow> foldl (+) x xs)"
| "eval_agg_op (Agg_Avg, ty) M =(let y0 = aggreg_default_value Agg_Avg ty in
    case  (flatten_multiset M, finite_multiset M) of
    (_, False) \<Rightarrow> y0
    |    ([],_) \<Rightarrow> y0
    | (x#xs,_) \<Rightarrow> EFloat ( double_of_event_data_agg (foldl plus x xs) / double_of_int (length (x#xs))))"
| "eval_agg_op (Agg_Med, ty) M =(let y0 = aggreg_default_value Agg_Med ty in
    case (flatten_multiset M, finite_multiset M) of
    (_, False) \<Rightarrow> y0
    |    ([],_) \<Rightarrow> y0
    | (xs,_) \<Rightarrow> EFloat (let u = length xs;  u' = u div 2 in
          if even u then
            (double_of_event_data_agg (xs ! (u'-1)) + double_of_event_data_agg (xs ! u')) / double_of_int 2
          else double_of_event_data_agg (xs ! u')))"

qualified datatype (discs_sels) 't formula = Pred name "trm list"
  | Let name "'t formula" "'t formula"
  | LetPast name "'t formula" "'t formula"
  | Eq trm trm | Less trm trm | LessEq trm trm
  | Neg "'t formula" | Or "'t formula" "'t formula" | And "'t formula" "'t formula" | Ands "'t formula list" | Exists 't "'t formula"
  | Agg nat "'t agg_op" "'t list" trm "'t formula"
  | Prev \<I> "'t formula" | Next \<I> "'t formula"
  | Since "'t formula" \<I> "'t formula" | Until "'t formula" \<I> "'t formula"
  | MatchF \<I> "'t formula Regex.regex" | MatchP \<I> "'t formula Regex.regex"
  | TP trm | TS trm

qualified definition "FF = Eq (Const (EInt 0)) (Const (EInt 1))"
qualified definition "TT \<equiv> Eq (Const (EInt 0)) (Const (EInt 0))"

qualified fun fvi :: "nat \<Rightarrow> 't formula \<Rightarrow> nat set" where
  "fvi b (Pred r ts) = (\<Union>t\<in>set ts. fvi_trm b t)"
| "fvi b (Let p \<phi> \<psi>) = fvi b \<psi>"
| "fvi b (LetPast p \<phi> \<psi>) = fvi b \<psi>"
| "fvi b (Eq t1 t2) = fvi_trm b t1 \<union> fvi_trm b t2"
| "fvi b (Less t1 t2) = fvi_trm b t1 \<union> fvi_trm b t2"
| "fvi b (LessEq t1 t2) = fvi_trm b t1 \<union> fvi_trm b t2"
| "fvi b (Neg \<phi>) = fvi b \<phi>"
| "fvi b (Or \<phi> \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
| "fvi b (And \<phi> \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
| "fvi b (Ands \<phi>s) = (let xs = map (fvi b) \<phi>s in \<Union>x\<in>set xs. x)"
| "fvi b (Exists t \<phi>) = fvi (Suc b) \<phi>"
| "fvi b (Agg y \<omega> tys f \<phi>) = fvi (b + length tys) \<phi> \<union> fvi_trm (b + length tys) f \<union> (if b \<le> y then {y - b} else {})"
| "fvi b (Prev I \<phi>) = fvi b \<phi>"
| "fvi b (Next I \<phi>) = fvi b \<phi>"
| "fvi b (Since \<phi> I \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
| "fvi b (Until \<phi> I \<psi>) = fvi b \<phi> \<union> fvi b \<psi>"
| "fvi b (MatchF I r) = Regex.fv_regex (fvi b) r"
| "fvi b (MatchP I r) = Regex.fv_regex (fvi b) r"
| "fvi b (TP t) = fvi_trm b t"
| "fvi b (TS t) = fvi_trm b t"

abbreviation "fv \<equiv> fvi 0"
abbreviation "fv_regex \<equiv> Regex.fv_regex fv"

lemma fv_abbrevs[simp]: "fv TT = {}" "fv FF = {}"
  unfolding TT_def FF_def by auto

lemma fv_subset_Ands: "\<phi> \<in> set \<phi>s \<Longrightarrow> fv \<phi> \<subseteq> fv (Ands \<phi>s)"
  by auto

lemma finite_fvi_trm[simp]: "finite (fvi_trm b t)"
  by (induction t) simp_all

lemma finite_fvi[simp]: "finite (fvi b \<phi>)"
  by (induction \<phi> arbitrary: b) simp_all

lemma fvi_trm_plus: "x \<in> fvi_trm (b + c) t \<longleftrightarrow> x + c \<in> fvi_trm b t"
  by (induction t) auto

lemma fvi_trm_minus: "x \<in> fvi_trm b t \<and> x \<ge> c \<longrightarrow> x-c \<in> fvi_trm (b+c) t"
  by (induction t) auto

lemma fvi_trm_iff_fv_trm: "x \<in> fvi_trm b t \<longleftrightarrow> x + b \<in> fv_trm t"
  using fvi_trm_plus[where b=0 and c=b] by simp_all

lemma fvi_plus: "x \<in> fvi (b + c) \<phi> \<longleftrightarrow> x + c \<in> fvi b \<phi>"
proof (induction \<phi> arbitrary: b rule: formula.induct)
  case (Exists \<phi>)
  then show ?case by force
next
  case (Agg y \<omega> tys f \<phi>)
  let ?b' = "length tys"
  have *: "b + c + ?b' = b + ?b' + c" by simp
  from Agg show ?case by (force simp: * fvi_trm_plus)
qed (auto simp add: fvi_trm_plus fv_regex_commute[where g = "\<lambda>x. x + c"])

lemma fvi_minus: "x \<in> fvi b \<phi> \<and> x \<ge> c \<longrightarrow> x - c \<in> fvi (b+c) \<phi>"
  by (simp add: fvi_plus)

lemma fvi_Suc: "x \<in> fvi (Suc b) \<phi> \<longleftrightarrow> Suc x \<in> fvi b \<phi>"
  using fvi_plus[where c=1] by simp

lemma fvi_plus_bound:
  assumes "\<forall>i\<in>fvi (b + c) \<phi>. i < n"
  shows "\<forall>i\<in>fvi b \<phi>. i < c + n"
proof
  fix i
  assume "i \<in> fvi b \<phi>"
  show "i < c + n"
  proof (cases "i < c")
    case True
    then show ?thesis by simp
  next
    case False
    then obtain i' where "i = i' + c"
      using nat_le_iff_add by (auto simp: not_less)
    with assms \<open>i \<in> fvi b \<phi>\<close> show ?thesis by (simp add: fvi_plus)
  qed
qed

lemma fvi_Suc_bound:
  assumes "\<forall>i\<in>fvi (Suc b) \<phi>. i < n"
  shows "\<forall>i\<in>fvi b \<phi>. i < Suc n"
  using assms fvi_plus_bound[where c=1] by simp

lemma fvi_iff_fv: "x \<in> fvi b \<phi> \<longleftrightarrow> x + b \<in> fv \<phi>"
  using fvi_plus[where b=0 and c=b] by simp_all

qualified definition nfv :: "'t formula \<Rightarrow> nat" where
  "nfv \<phi> = Max (insert 0 (Suc ` fv \<phi>))"

qualified abbreviation nfv_regex where
  "nfv_regex \<equiv> Regex.nfv_regex fv"

qualified definition envs :: "'t formula \<Rightarrow> env set" where
  "envs \<phi> = {v. length v = nfv \<phi>}"

lemma nfv_simps[simp]:
  "nfv (Let p \<phi> \<psi>) = nfv \<psi>"
  "nfv (LetPast p \<phi> \<psi>) = nfv \<psi>"
  "nfv (Neg \<phi>) = nfv \<phi>"
  "nfv (Or \<phi> \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  "nfv (And \<phi> \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  "nfv (Prev I \<phi>) = nfv \<phi>"
  "nfv (Next I \<phi>) = nfv \<phi>"
  "nfv (Since \<phi> I \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  "nfv (Until \<phi> I \<psi>) = max (nfv \<phi>) (nfv \<psi>)"
  "nfv (MatchP I r) = Regex.nfv_regex fv r"
  "nfv (MatchF I r) = Regex.nfv_regex fv r"
  "nfv_regex (Regex.Skip n) = 0"
  "nfv_regex (Regex.Test \<phi>) = Max (insert 0 (Suc ` fv \<phi>))"
  "nfv_regex (Regex.Plus r s) = max (nfv_regex r) (nfv_regex s)"
  "nfv_regex (Regex.Times r s) = max (nfv_regex r) (nfv_regex s)"
  "nfv_regex (Regex.Star r) = nfv_regex r"
  unfolding nfv_def Regex.nfv_regex_def by (simp_all add: image_Un Max_Un[symmetric])

lemma nfv_Ands[simp]: "nfv (Ands l) = Max (insert 0 (nfv ` set l))"
proof (induction l)
  case Nil
  then show ?case unfolding nfv_def by simp
next
  case (Cons a l)
  have "fv (Ands (a # l)) = fv a \<union> fv (Ands l)" by simp
  then have "nfv (Ands (a # l)) = max (nfv a) (nfv (Ands l))"
    unfolding nfv_def
    by (auto simp: image_Un Max.union[symmetric])
  with Cons.IH show ?case
    by (cases l) auto
qed

lemma fvi_less_nfv: "\<forall>i\<in>fv \<phi>. i < nfv \<phi>"
  unfolding nfv_def
  by (auto simp add: Max_gr_iff intro: max.strict_coboundedI2)

lemma fvi_less_nfv_regex: "\<forall>i\<in>fv_regex \<phi>. i < nfv_regex \<phi>"
  unfolding Regex.nfv_regex_def
  by (auto simp add: Max_gr_iff intro: max.strict_coboundedI2)

fun contains_pred :: "name \<times> nat \<Rightarrow> 't formula \<Rightarrow> bool" where
   "contains_pred p (Eq t1 t2) = False"
|  "contains_pred p (Less t1 t2) = False"
|  "contains_pred p (LessEq t1 t2) = False"
|  "contains_pred p (Pred e ts) = (p = (e, length ts))"
|  "contains_pred p (Let e \<phi> \<psi>) = ((contains_pred p \<phi> \<and> contains_pred (e, nfv \<phi>) \<psi>) \<or> (p \<noteq> (e, nfv \<phi>) \<and> contains_pred p \<psi>))"
|  "contains_pred p (LetPast e \<phi> \<psi>) =  (p \<noteq> (e, nfv \<phi>) \<and> ((contains_pred p \<phi> \<and> contains_pred (e, nfv \<phi>) \<psi>) \<or> contains_pred p \<psi>))"
|  "contains_pred p (Neg \<phi>) = contains_pred p \<phi>"
|  "contains_pred p (Or \<phi> \<psi>) = (contains_pred p \<phi> \<or> contains_pred p \<psi>)"
|  "contains_pred p (And \<phi> \<psi>) = (contains_pred p \<phi> \<or> contains_pred p \<psi>)"
|  "contains_pred p (Ands l) = (\<exists>\<phi>\<in>set l. contains_pred p \<phi>)"
|  "contains_pred p (Exists t \<phi>) = contains_pred p \<phi>"
|  "contains_pred p (Agg y \<omega> tys f \<phi>) = contains_pred p \<phi>"
|  "contains_pred p (Prev I \<phi>) = contains_pred p \<phi>"
|  "contains_pred p (Next I \<phi>) = contains_pred p \<phi>"
|  "contains_pred p (Since \<phi> I \<psi>) = (contains_pred p \<phi> \<or> contains_pred p \<psi>)"
|  "contains_pred p (Until \<phi> I \<psi>) = (contains_pred p \<phi> \<or> contains_pred p \<psi>)"
|  "contains_pred p (MatchP I r) = (\<exists>\<phi>\<in>Regex.atms r. contains_pred p \<phi>)"
|  "contains_pred p (MatchF I r) =  (\<exists>\<phi>\<in>Regex.atms r. contains_pred p \<phi>)"
|  "contains_pred p (TP t) = False"
|  "contains_pred p (TS t) = False"

subsubsection \<open>Semantics\<close>

definition "ecard A = (if finite A then card A else \<infinity>)"

declare conj_cong[fundef_cong]
fun letpast_sat where
  "letpast_sat sat v (i::nat) = sat (\<lambda>w j. j < i \<and> letpast_sat sat w j) v i"
declare letpast_sat.simps[simp del]

lemma V_subst_letpast_sat:
  "(\<And>X v j. j \<le> i \<Longrightarrow> f X v j = g X v j) \<Longrightarrow>
  Formula.letpast_sat f v i = Formula.letpast_sat g v i"
  by (induct f v i rule: letpast_sat.induct) (subst (1 2) letpast_sat.simps, auto cong: conj_cong)

qualified fun sat :: "trace \<Rightarrow> (name \<times> nat \<rightharpoonup> env \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> env \<Rightarrow> nat \<Rightarrow> ty formula \<Rightarrow> bool" where
  "sat \<sigma> V v i (Pred r ts) = (case V (r, length ts) of
       None \<Rightarrow> (r, map (eval_trm v) ts) \<in> \<Gamma> \<sigma> i
     | Some X \<Rightarrow> X (map (eval_trm v) ts) i)"
| "sat \<sigma> V v i (Let p \<phi> \<psi>) = sat \<sigma> (V((p, nfv \<phi>) \<mapsto> \<lambda>w j. sat \<sigma> V w j \<phi>)) v i \<psi>"
| "sat \<sigma> V v i (LetPast p \<phi> \<psi>) =
    (let pn = (p, nfv \<phi>) in
    sat \<sigma> (V(pn \<mapsto> letpast_sat (\<lambda>X u k. sat \<sigma> (V(pn \<mapsto> X)) u k \<phi>))) v i \<psi>)"
| "sat \<sigma> V v i (Eq t1 t2) = (eval_trm v t1 = eval_trm v t2)"
| "sat \<sigma> V v i (Less t1 t2) = (eval_trm v t1 < eval_trm v t2)"
| "sat \<sigma> V v i (LessEq t1 t2) = (eval_trm v t1 \<le> eval_trm v t2)"
| "sat \<sigma> V v i (Neg \<phi>) = (\<not> sat \<sigma> V v i \<phi>)"
| "sat \<sigma> V v i (Or \<phi> \<psi>) = (sat \<sigma> V v i \<phi> \<or> sat \<sigma> V v i \<psi>)"
| "sat \<sigma> V v i (And \<phi> \<psi>) = (sat \<sigma> V v i \<phi> \<and> sat \<sigma> V v i \<psi>)"
| "sat \<sigma> V v i (Ands l) = (\<forall>\<phi> \<in> set l. sat \<sigma> V v i \<phi>)"
| "sat \<sigma> V v i (Exists t \<phi>) = (\<exists>z. sat \<sigma> V (z # v) i \<phi>)"
| "sat \<sigma> V v i (Agg y \<omega> tys f \<phi>) =
    (let M = {(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> sat \<sigma> V (zs @ v) i \<phi> \<and> eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}
    in (M = {} \<longrightarrow> fv \<phi> \<subseteq> {0..<length tys}) \<and> v ! y = eval_agg_op \<omega> M)"
| "sat \<sigma> V v i (Prev I \<phi>) = (case i of 0 \<Rightarrow> False | Suc j \<Rightarrow> mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> sat \<sigma> V v j \<phi>)"
| "sat \<sigma> V v i (Next I \<phi>) = (mem I ((\<tau> \<sigma> (Suc i) - \<tau> \<sigma> i)) \<and> sat \<sigma> V v (Suc i) \<phi>)"
| "sat \<sigma> V v i (Since \<phi> I \<psi>) = (\<exists>j\<le>i. mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> sat \<sigma> V v j \<psi> \<and> (\<forall>k \<in> {j <.. i}. sat \<sigma> V v k \<phi>))"
| "sat \<sigma> V v i (Until \<phi> I \<psi>) = (\<exists>j\<ge>i. mem I (\<tau> \<sigma> j - \<tau> \<sigma> i) \<and> sat \<sigma> V v j \<psi> \<and> (\<forall>k \<in> {i ..< j}. sat \<sigma> V v k \<phi>))"
| "sat \<sigma> V v i (MatchP I r) = (\<exists>j\<le>i. mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> Regex.match (sat \<sigma> V v) r j i)"
| "sat \<sigma> V v i (MatchF I r) = (\<exists>j\<ge>i. mem I (\<tau> \<sigma> j - \<tau> \<sigma> i) \<and> Regex.match (sat \<sigma> V v) r i j)"
| "sat \<sigma> V v i (TP t) = (eval_trm v t = EInt (integer_of_nat i))"
| "sat \<sigma> V v i (TS t) = (eval_trm v t = EInt (integer_of_nat (\<tau> \<sigma> i)))"

lemma sat_abbrevs[simp]:
  "sat \<sigma> V v i TT" "\<not> sat \<sigma> V v i FF"
  unfolding TT_def FF_def by auto

lemma sat_Ands: "sat \<sigma> V v i (Ands l) \<longleftrightarrow> (\<forall>\<phi>\<in>set l. sat \<sigma> V v i \<phi>)"
  by (simp add: list_all_iff)

lemma sat_Until_rec: "sat \<sigma> V v i (Until \<phi> I \<psi>) \<longleftrightarrow>
  memL I 0 \<and> sat \<sigma> V v i \<psi> \<or>
  (memR I (\<Delta> \<sigma> (i + 1)) \<and> sat \<sigma> V v i \<phi> \<and> sat \<sigma> V v (i + 1) (Until \<phi> (subtract (\<Delta> \<sigma> (i + 1)) I) \<psi>))"
  (is "?L \<longleftrightarrow> ?R")
proof (rule iffI; (elim disjE conjE)?)
  assume ?L
  then obtain j where j: "i \<le> j" "mem I (\<tau> \<sigma> j - \<tau> \<sigma> i)" "sat \<sigma> V v j \<psi>" "\<forall>k \<in> {i ..< j}. sat \<sigma> V v k \<phi>"
    by auto
  then show ?R
  proof (cases "i = j")
    case False
    with j(1,2) have "memR I (\<Delta> \<sigma> (i + 1))"
      by (auto elim: order_trans[rotated] simp: diff_le_mono)
    moreover from False j(1,4) have "sat \<sigma> V v i \<phi>" by auto
    moreover from False j have "sat \<sigma> V v (i + 1) (Until \<phi> (subtract (\<Delta> \<sigma> (i + 1)) I) \<psi>)"
      by (auto intro!: exI[of _ j])
    ultimately show ?thesis by blast
  qed simp
next
  assume \<Delta>: "memR I (\<Delta> \<sigma> (i + 1))" and now: "sat \<sigma> V v i \<phi>" and
   "next": "sat \<sigma> V v (i + 1) (Until \<phi> (subtract (\<Delta> \<sigma> (i + 1)) I) \<psi>)"
  from "next" obtain j where j: "i + 1 \<le> j" "mem ((subtract (\<Delta> \<sigma> (i + 1)) I)) (\<tau> \<sigma> j - \<tau> \<sigma> (i + 1))"
      "sat \<sigma> V v j \<psi>" "\<forall>k \<in> {i + 1 ..< j}. sat \<sigma> V v k \<phi>"
    by (auto simp: diff_le_mono memL_mono)
  from \<Delta> j(1,2) have "mem I (\<tau> \<sigma> j - \<tau> \<sigma> i)"
    by auto
  with now j(1,3,4) show ?L by (auto simp: le_eq_less_or_eq[of i] intro!: exI[of _ j])
qed auto

lemma sat_Since_rec: "sat \<sigma> V v i (Since \<phi> I \<psi>) \<longleftrightarrow>
  mem I 0 \<and> sat \<sigma> V v i \<psi> \<or>
  (i > 0 \<and> memR I (\<Delta> \<sigma> i) \<and> sat \<sigma> V v i \<phi> \<and> sat \<sigma> V v (i - 1) (Since \<phi> (subtract (\<Delta> \<sigma> i) I) \<psi>))"
  (is "?L \<longleftrightarrow> ?R")
proof (rule iffI; (elim disjE conjE)?)
  assume ?L
  then obtain j where j: "j \<le> i" "mem I (\<tau> \<sigma> i - \<tau> \<sigma> j)" "sat \<sigma> V v j \<psi>" "\<forall>k \<in> {j <.. i}. sat \<sigma> V v k \<phi>"
    by auto
  then show ?R
  proof (cases "i = j")
    case False
    with j(1) obtain k where [simp]: "i = k + 1"
      by (cases i) auto
    with j(1,2) False have "memR I (\<Delta> \<sigma> i)"
      by (auto elim: order_trans[rotated] simp: diff_le_mono2 le_Suc_eq)
    moreover from False j(1,4) have "sat \<sigma> V v i \<phi>" by auto
    moreover from False j have "sat \<sigma> V v (i - 1) (Since \<phi> (subtract (\<Delta> \<sigma> i) I) \<psi>)"
      by (auto intro!: exI[of _ j])
    ultimately show ?thesis by auto
  qed simp
next
  assume i: "0 < i" and \<Delta>: "memR I (\<Delta> \<sigma> i)" and now: "sat \<sigma> V v i \<phi>" and
   "prev": "sat \<sigma> V v (i - 1) (Since \<phi> (subtract (\<Delta> \<sigma> i) I) \<psi>)"
  from "prev" obtain j where j: "j \<le> i - 1" "mem (subtract (\<Delta> \<sigma> i) I) (\<tau> \<sigma> (i - 1) - \<tau> \<sigma> j)"
      "sat \<sigma> V v j \<psi>" "\<forall>k \<in> {j <.. i - 1}. sat \<sigma> V v k \<phi>"
    by (auto simp: diff_le_mono2 memL_mono)
  from \<Delta> i j(1,2) have "mem I (\<tau> \<sigma> i - \<tau> \<sigma> j)"
    by auto
  with now i j(1,3,4) show ?L by (auto simp: le_Suc_eq gr0_conv_Suc intro!: exI[of _ j])
qed auto

lemma sat_MatchF_rec: "sat \<sigma> V v i (MatchF I r) \<longleftrightarrow> memL I 0 \<and> Regex.eps (sat \<sigma> V v) i r \<or>
  memR I (\<Delta> \<sigma> (i + 1)) \<and> (\<exists>s \<in> Regex.lpd (sat \<sigma> V v) i r. sat \<sigma> V v (i + 1) (MatchF (subtract (\<Delta> \<sigma> (i + 1)) I) s))"
  (is "?L \<longleftrightarrow> ?R1 \<or> ?R2")
proof (rule iffI; (elim disjE conjE bexE)?)
  assume ?L
  then obtain j where j: "j \<ge> i" "mem I (\<tau> \<sigma> j - \<tau> \<sigma> i)" and "Regex.match (sat \<sigma> V v) r i j" by auto
  then show "?R1 \<or> ?R2"
  proof (cases "i < j")
    case True
    with \<open>Regex.match (sat \<sigma> V v) r i j\<close> lpd_match[of i j "sat \<sigma> V v" r]
    obtain s where "s \<in> Regex.lpd (sat \<sigma> V v) i r" "Regex.match (sat \<sigma> V v) s (i + 1) j" by auto
    with True j have ?R2
      by (auto simp: le_diff_conv le_diff_conv2 intro!: exI[of _ j] elim: le_trans[rotated])
    then show ?thesis by blast
  qed (auto simp: eps_match)
next
  assume "memR I (\<Delta> \<sigma> (i + 1))"
  moreover
  fix s
  assume [simp]: "s \<in> Regex.lpd (sat \<sigma> V v) i r" and "sat \<sigma> V v (i + 1) (MatchF (subtract (\<Delta> \<sigma> (i + 1)) I) s)"
  then obtain j where "j > i" "Regex.match (sat \<sigma> V v) s (i + 1) j"
    "mem (subtract (\<Delta> \<sigma> (i + 1)) I) (\<tau> \<sigma> j - \<tau> \<sigma> (Suc i))"
    by (auto simp: diff_le_mono memL_mono Suc_le_eq)
  ultimately show ?L
    by (auto simp: le_diff_conv lpd_match intro!: exI[of _ j] bexI[of _ s])
qed (auto simp: eps_match intro!: exI[of _ i])

lemma sat_MatchP_rec: "sat \<sigma> V v i (MatchP I r) \<longleftrightarrow> memL I 0 \<and> Regex.eps (sat \<sigma> V v) i r \<or>
  i > 0 \<and> memR I (\<Delta> \<sigma> i) \<and> (\<exists>s \<in> Regex.rpd (sat \<sigma> V v) i r. sat \<sigma> V v (i - 1) (MatchP (subtract (\<Delta> \<sigma> i) I) s))"
  (is "?L \<longleftrightarrow> ?R1 \<or> ?R2")
proof (rule iffI; (elim disjE conjE bexE)?)
  assume ?L
  then obtain j where j: "j \<le> i" "mem I (\<tau> \<sigma> i - \<tau> \<sigma> j)" and "Regex.match (sat \<sigma> V v) r j i" by auto
  then show "?R1 \<or> ?R2"
  proof (cases "j < i")
    case True
    with \<open>Regex.match (sat \<sigma> V v) r j i\<close> rpd_match[of j i "sat \<sigma> V v" r]
    obtain s where "s \<in> Regex.rpd (sat \<sigma> V v) i r" "Regex.match (sat \<sigma> V v) s j (i - 1)" by auto
    with True j have ?R2
      by (auto simp: diff_le_mono2 intro!: exI[of _ j])
    then show ?thesis by blast
  qed (auto simp: eps_match)
next
  assume "memR I (\<Delta> \<sigma> i)"
  moreover
  fix s
  assume [simp]: "s \<in> Regex.rpd (sat \<sigma> V v) i r" and "sat \<sigma> V v (i - 1) (MatchP (subtract (\<Delta> \<sigma> i) I) s)" "i > 0"
  then obtain j where "j < i" "Regex.match (sat \<sigma> V v) s j (i - 1)"
    "mem (subtract (\<Delta> \<sigma> i) I) (\<tau> \<sigma> (i - 1) - \<tau> \<sigma> j)" by (auto simp: gr0_conv_Suc less_Suc_eq_le)
  ultimately show ?L
    by (auto simp: rpd_match intro!: exI[of _ j] bexI[of _ s])
qed (auto simp: eps_match intro!: exI[of _ i])

lemma sat_Since_0: "sat \<sigma> V v 0 (Since \<phi> I \<psi>) \<longleftrightarrow> memL I 0 \<and> sat \<sigma> V v 0 \<psi>"
  by auto

lemma sat_MatchP_0: "sat \<sigma> V v 0 (MatchP I r) \<longleftrightarrow> memL I 0 \<and> Regex.eps (sat \<sigma> V v) 0 r"
  by (auto simp: eps_match)

lemma sat_Since_point: "sat \<sigma> V v i (Since \<phi> I \<psi>) \<Longrightarrow>
    (\<And>j. j \<le> i \<Longrightarrow> mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<Longrightarrow> sat \<sigma> V v i (Since \<phi> (point (\<tau> \<sigma> i - \<tau> \<sigma> j)) \<psi>) \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto intro: diff_le_self)

lemma sat_MatchP_point: "sat \<sigma> V v i (MatchP I r) \<Longrightarrow>
    (\<And>j. j \<le> i \<Longrightarrow> mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<Longrightarrow> sat \<sigma> V v i (MatchP (point (\<tau> \<sigma> i - \<tau> \<sigma> j)) r) \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto intro: diff_le_self)

lemma sat_Since_pointD: "sat \<sigma> V v i (Since \<phi> (point t) \<psi>) \<Longrightarrow> mem I t \<Longrightarrow> sat \<sigma> V v i (Since \<phi> I \<psi>)"
  by auto

lemma sat_MatchP_pointD: "sat \<sigma> V v i (MatchP (point t) r) \<Longrightarrow> mem I t \<Longrightarrow> sat \<sigma> V v i (MatchP I r)"
  by auto

lemma sat_fv_cong: "\<forall>x\<in>fv \<phi>. v!x = v'!x \<Longrightarrow> sat \<sigma> V v i \<phi> = sat \<sigma> V v' i \<phi>"
proof (induct \<phi> arbitrary: V v v' i rule: formula.induct)
  case (Pred n ts)
  show ?case by (simp cong: map_cong eval_trm_fv_cong[OF Pred[simplified, THEN bspec]] split: option.splits)
next
  case (Let p \<phi> \<psi>)
  then show ?case
    by auto
next
  case (Eq x1 x2)
  then show ?case unfolding fvi.simps sat.simps by (metis UnCI eval_trm_fv_cong)
next
  case (Less x1 x2)
  then show ?case unfolding fvi.simps sat.simps by (metis UnCI eval_trm_fv_cong)
next
  case (LessEq x1 x2)
  then show ?case unfolding fvi.simps sat.simps by (metis UnCI eval_trm_fv_cong)
next
  case (Ands l)
  have "\<And>\<phi>. \<phi> \<in> set l \<Longrightarrow> sat \<sigma> V v i \<phi> = sat \<sigma> V v' i \<phi>"
  proof -
    fix \<phi> assume "\<phi> \<in> set l"
    then have "fv \<phi> \<subseteq> fv (Ands l)" using fv_subset_Ands by blast
    then have "\<forall>x\<in>fv \<phi>. v!x = v'!x" using Ands.prems by blast
    then show "sat \<sigma> V v i \<phi> = sat \<sigma> V v' i \<phi>" using Ands.hyps \<open>\<phi> \<in> set l\<close> by blast
  qed
  then show ?case using sat_Ands by blast
next
  case (Exists t \<phi>)
  then show ?case unfolding sat.simps by (intro iff_exI) (simp add: fvi_Suc nth_Cons')
next
  case (Agg y \<omega> tys f \<phi>)
  let ?b = "length tys"
  have "v ! y = v' ! y"
    using Agg.prems by simp
  moreover have "sat \<sigma> V (zs @ v) i \<phi> = sat \<sigma> V (zs @ v') i \<phi>" if "length zs = ?b" for zs
    using that Agg.prems by (simp add: Agg.hyps[where v="zs @ v" and v'="zs @ v'"]
        nth_append fvi_iff_fv(1)[where b= ?b])
  moreover have "eval_trm (zs @ v) f = eval_trm (zs @ v') f" if "length zs = ?b" for zs
    using that Agg.prems by (auto intro!: eval_trm_fv_cong[where v="zs @ v" and v'="zs @ v'"]
        simp: nth_append fvi_iff_fv(1)[where b= ?b] fvi_trm_iff_fv_trm[where b= ?b])
  ultimately show ?case
    by (simp cong: conj_cong)
next
  case (MatchF I r)
  then have "Regex.match (sat \<sigma> V v) r = Regex.match (sat \<sigma> V v') r"
    by (intro match_fv_cong) (auto simp: fv_regex_alt)
  then show ?case
    by auto
next
  case (MatchP I r)
  then have "Regex.match (sat \<sigma> V v) r = Regex.match (sat \<sigma> V v') r"
    by (intro match_fv_cong) (auto simp: fv_regex_alt)
  then show ?case
    by auto
next
  case (TP t)
  then show ?case unfolding fvi.simps sat.simps by (metis eval_trm_fv_cong)
next
  case (TS t)
  then show ?case unfolding fvi.simps sat.simps by (metis eval_trm_fv_cong)
qed (auto 10 0 simp: Let_def split: nat.splits intro!: iff_exI)

lemma sat_the_restrict: "fv \<phi> \<subseteq> A \<Longrightarrow> Formula.sat \<sigma> V (map the (restrict A v)) i \<phi> = Formula.sat \<sigma> V (map the v) i \<phi>"
  by (rule sat_fv_cong) (auto intro!: map_the_restrict)

lemma match_fv_cong:
  "\<forall>x\<in>fv_regex r. v!x = v'!x \<Longrightarrow> Regex.match (sat \<sigma> V v) r = Regex.match (sat \<sigma> V v') r"
  by (rule match_fv_cong, rule sat_fv_cong) (auto simp: fv_regex_alt)

lemma eps_fv_cong:
  "\<forall>x\<in>fv_regex r. v!x = v'!x \<Longrightarrow> Regex.eps (sat \<sigma> V v) i r = Regex.eps (sat \<sigma> V v') i r"
  unfolding eps_match by (erule match_fv_cong[THEN fun_cong, THEN fun_cong])

subsection \<open>Past-only formulas\<close>

fun past_only :: "'t formula \<Rightarrow> bool" where
  "past_only (Pred _ _) = True"
| "past_only (Eq _ _) = True"
| "past_only (Less _ _) = True"
| "past_only (LessEq _ _) = True"
| "past_only (Let _ \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (LetPast _ \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (Neg \<psi>) = past_only \<psi>"
| "past_only (Or \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (And \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (Ands l) = (\<forall>\<alpha>\<in>set l. past_only \<alpha>)"
| "past_only (Exists _ \<psi>) = past_only \<psi>"
| "past_only (Agg _ _ _ _ \<psi>) = past_only \<psi>"
| "past_only (Prev _ \<psi>) = past_only \<psi>"
| "past_only (Next _ _) = False"
| "past_only (Since \<alpha> _ \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (Until \<alpha> _ \<beta>) = False"
| "past_only (MatchP _ r) = Regex.pred_regex past_only r"
| "past_only (MatchF _ _) = False"
| "past_only (TP _) = True"
| "past_only (TS _) = True"

lemma past_only_sat:
  assumes "prefix_of \<pi> \<sigma>" "prefix_of \<pi> \<sigma>'"
  shows "i < plen \<pi> \<Longrightarrow> dom V = dom V' \<Longrightarrow>
     (\<And>p v i. p \<in> dom V \<Longrightarrow> i < plen \<pi> \<Longrightarrow> the (V p) v i = the (V' p) v i) \<Longrightarrow>
     past_only \<phi> \<Longrightarrow> sat \<sigma> V v i \<phi> = sat \<sigma>' V' v i \<phi>"
proof (induction \<phi> arbitrary: V V' v i)
  case (Pred e ts)
  let ?en = "(e, length ts)"
  show ?case proof (cases "V ?en")
    case None
    then have "V' (e, length ts) = None" using \<open>dom V = dom V'\<close> by auto
    with None \<Gamma>_prefix_conv[OF assms(1,2) Pred(1)] show ?thesis by simp
  next
    case (Some a)
    moreover obtain a' where "V' ?en = Some a'"
      using Some \<open>dom V = dom V'\<close> by auto
    moreover have "the (V ?en) w i = the (V' ?en) w i" for w
      using Some Pred(1,3) by (fastforce intro: domI)
    ultimately show ?thesis by simp
  qed
next
  case (Let p \<phi> \<psi>)
  let ?pn = "(p, nfv \<phi>)"
  let ?V = "\<lambda>V \<sigma>. (V(?pn \<mapsto> \<lambda>w j. sat \<sigma> V w j \<phi>))"
  show ?case unfolding sat.simps proof (rule Let.IH(2))
    show "i < plen \<pi>" by fact
    from Let.prems show "past_only \<psi>" by simp
    from Let.prems show "dom (?V V \<sigma>) = dom (?V V' \<sigma>')"
      by (simp del: fun_upd_apply)
  next
    fix p' v i
    assume *: "p' \<in> dom (?V V \<sigma>)" "i < plen \<pi>"
    show "the (?V V \<sigma> p') v i = the (?V V' \<sigma>' p') v i" proof (cases "p' = ?pn")
      case True
      with Let \<open>i < plen \<pi>\<close> show ?thesis by auto
    next
      case False
      with * show ?thesis by (auto intro!: Let.prems(3))
    qed
  qed
next
  case (LetPast p \<phi> \<psi>)
  let ?pn = "(p, nfv \<phi>)"
  let ?V = "\<lambda>V \<sigma>. V(?pn \<mapsto> letpast_sat (\<lambda>X u k. sat \<sigma> (V(?pn \<mapsto> X)) u k \<phi>))"
  show ?case unfolding sat.simps Let_def proof (rule LetPast.IH(2))
    show "i < plen \<pi>" by fact
    from LetPast.prems show "past_only \<psi>" by simp
    from LetPast.prems show "dom (?V V \<sigma>) = dom (?V V' \<sigma>')"
      by (simp del: fun_upd_apply)
  next
    fix p' v i'
    assume *: "p' \<in> dom (?V V \<sigma>)" "i' < plen \<pi>"
    show "the (?V V \<sigma> p') v i' = the (?V V' \<sigma>' p') v i'"
    proof (cases "p' = ?pn")
      case True
      then have "?pn \<in> dom (?V V \<sigma>)" by simp
      then have "letpast_sat (\<lambda>X u k. sat \<sigma> (V(?pn \<mapsto> X)) u k \<phi>) v j =
            letpast_sat (\<lambda>X u k. sat \<sigma>' (V'(?pn \<mapsto> X)) u k \<phi>) v j"
        if "j < plen \<pi>" for j
        using that
      proof (induct "\<lambda>X u k. sat \<sigma> (V(?pn \<mapsto> X)) u k \<phi>" v j rule: letpast_sat.induct)
        case (1 v j)
        show ?case
        proof (subst (1 2) letpast_sat.simps, rule LetPast.IH(1), goal_cases plen dom eq past_only)
          case plen
          from "1" show ?case by simp
        next
          case dom
          from LetPast.prems show ?case by (auto simp add: dom_def)
        next
          case (eq p'' v' j')
          with "1" LetPast.prems(3)[of p'' j' v'] show ?case
            by (cases "p'' = ?pn") fastforce+
        next
          case past_only
          from LetPast.prems show ?case by simp
        qed
      qed
      with True \<open>i' < plen \<pi>\<close>
      show ?thesis by simp
    next
      case False
      with * show ?thesis by (auto intro!: LetPast.prems(3))
    qed
  qed
next
  case (Ands l)
  with \<Gamma>_prefix_conv[OF assms] show ?case by simp
next
  case (Prev I \<phi>)
  with \<tau>_prefix_conv[OF assms] show ?case by (simp split: nat.split)
next
  case (Since \<phi>1 I \<phi>2)
  with \<tau>_prefix_conv[OF assms] show ?case by auto
next
  case (MatchP I r)
  then have "Regex.match (sat \<sigma> V v) r a b = Regex.match (sat \<sigma>' V' v) r a b" if "b < plen \<pi>" for a b
    using that by (intro Regex.match_cong_strong) (auto simp: regex.pred_set)
  with \<tau>_prefix_conv[OF assms] MatchP(2) show ?case by auto
next
  case (TP t)
  with \<tau>_prefix_conv[OF assms] show ?case by simp
next
  case (TS t)
  with \<tau>_prefix_conv[OF assms] show ?case by simp
qed auto

subsection \<open>Well-formed formulas\<close>

fun wf_formula :: "'t formula \<Rightarrow> bool"
  where "wf_formula (Let p \<phi> \<psi>) = ({0..<nfv \<phi>} \<subseteq> fv \<phi> \<and> wf_formula \<phi> \<and> wf_formula \<psi>)"
| "wf_formula (LetPast p \<phi> \<psi>) = ({0..<nfv \<phi>} \<subseteq> fv \<phi> \<and> wf_formula \<phi> \<and> wf_formula \<psi>)"
| "wf_formula (Neg \<phi>) =  wf_formula \<phi>"
| "wf_formula (Or \<phi> \<psi>) = (wf_formula \<phi> \<and> wf_formula \<psi>)"
| "wf_formula (And \<phi> \<psi>) = (wf_formula \<phi> \<and> wf_formula \<psi> )"
| "wf_formula (Ands l) = (list_all wf_formula l)"
| "wf_formula (Exists x \<phi>) = (wf_formula \<phi> \<and> 0 \<in> fv \<phi>)"
| "wf_formula (Agg y \<omega> tys f \<phi>) = (wf_formula \<phi> \<and> y + length tys \<notin> fv \<phi> \<and> {0..< length tys} \<subseteq> fv \<phi> )"
| "wf_formula (Prev I \<phi>) = (wf_formula \<phi>)"
| "wf_formula (Next I \<phi>) = (wf_formula \<phi>)"
| "wf_formula (Since \<phi> I \<psi>) = (wf_formula \<phi> \<and> wf_formula \<psi>)"
| "wf_formula (Until \<phi> I \<psi>) = (wf_formula \<phi> \<and> wf_formula \<psi>)"
| "wf_formula (MatchP I r) = Regex.pred_regex wf_formula r"
| "wf_formula (MatchF I r) = Regex.pred_regex wf_formula r"
| "wf_formula _ = True"

end (* context *)

subsection \<open> Notation \<close>

context
begin

abbreviation "eval_trm_option v t \<equiv> Formula.eval_trm (map the v) t"

abbreviation "sat_the \<sigma> V v i \<equiv> Formula.sat \<sigma> V (map the v) i"

end

bundle MFODL_no_notation
begin

no_notation trm.Var ("\<^bold>v")
     and trm.Const ("\<^bold>c")

no_notation formula.Pred ("_ \<dagger> _" [85, 85] 85)
     and formula.Eq (infixl "=\<^sub>F" 75)
     and formula.LessEq ("(_/ \<le>\<^sub>F _)" [76,76] 75)
     and formula.Less ("(_/ <\<^sub>F _)" [76,76] 75)
     and formula.Neg ("\<not>\<^sub>F _" [82] 82)
     and formula.And (infixr "\<and>\<^sub>F" 80)
     and formula.Or (infixr "\<or>\<^sub>F" 80)
     and formula.Exists ("\<exists>\<^sub>F:_. _" [70,70] 70)
     and formula.Ands ("\<And>\<^sub>F _" [70] 70)
     and formula.Prev ("\<^bold>Y _ _" [55, 65] 65)
     and formula.Next ("\<^bold>X _ _" [55, 65] 65)
     and formula.Since ("_ \<^bold>S _ _" [60,55,60] 60)
     and formula.Until ("_ \<^bold>U _ _" [60,55,60] 60)

no_notation Formula.fv_trm ("FV\<^sub>t")
     and Formula.fv ("FV")
     and eval_trm_option ("_\<lbrakk>_\<rbrakk>\<^sub>M" [51,89] 89)
     and sat_the ("\<langle>_, _, _, _\<rangle> \<Turnstile>\<^sub>M _" [56, 56, 56, 56, 56] 55)
     and Formula.sat ("\<langle>_, _, _, _\<rangle> \<Turnstile> _" [56, 56, 56, 56, 56] 55)
     and Interval.interval ("\<^bold>[_,_\<^bold>]")

end

bundle MFODL_notation
begin

notation trm.Var ("\<^bold>v")
     and trm.Const ("\<^bold>c")

notation formula.Pred ("_ \<dagger> _" [85, 85] 85)
     and formula.Eq (infixl "=\<^sub>F" 75)
     and formula.LessEq ("(_/ \<le>\<^sub>F _)" [76,76] 75)
     and formula.Less ("(_/ <\<^sub>F _)" [76,76] 75)
     and formula.Neg ("\<not>\<^sub>F _" [82] 82)
     and formula.And (infixr "\<and>\<^sub>F" 80)
     and formula.Or (infixr "\<or>\<^sub>F" 80)
     and formula.Exists ("\<exists>\<^sub>F:_. _" [70,70] 70)
     and formula.Ands ("\<And>\<^sub>F _" [70] 70)
     and formula.Prev ("\<^bold>Y _ _" [55, 65] 65)
     and formula.Next ("\<^bold>X _ _" [55, 65] 65)
     and formula.Since ("_ \<^bold>S _ _" [60,55,60] 60)
     and formula.Until ("_ \<^bold>U _ _" [60,55,60] 60)

notation Formula.fv_trm ("FV\<^sub>t")
     and Formula.fv ("FV")
     and eval_trm_option ("_\<lbrakk>_\<rbrakk>\<^sub>M" [51,89] 89)
     and sat_the ("\<langle>_, _, _, _\<rangle> \<Turnstile>\<^sub>M _" [56, 56, 56, 56, 56] 55)
     and Formula.sat ("\<langle>_, _, _, _\<rangle> \<Turnstile> _" [56, 56, 56, 56, 56] 55)
     and Interval.interval ("\<^bold>[_,_\<^bold>]")

end

unbundle MFODL_notation \<comment> \<open> enable notation \<close>

term "\<^bold>c (EInt 0) =\<^sub>F \<^bold>c (EInt 0)"
term "v\<lbrakk>\<^bold>c t\<rbrakk>\<^sub>M"
term "\<And>\<^sub>F [\<exists>\<^sub>F:t. (trm =\<^sub>F \<^bold>v x) \<and>\<^sub>F (a \<le>\<^sub>F \<^bold>c z), \<phi> \<^bold>U I \<psi>]"

term "\<langle>\<sigma>, V, v, i + length v\<rangle> \<Turnstile>\<^sub>M \<^bold>Y I (\<not>\<^sub>F (P \<dagger> [\<^bold>c a, \<^bold>v 0])
  \<and>\<^sub>F (Q \<dagger> [\<^bold>v y])) \<^bold>S (point n) ((\<^bold>X \<^bold>[2,3\<^bold>] (P \<dagger> [\<^bold>c b, \<^bold>v 0])) \<or>\<^sub>F Q \<dagger> [\<^bold>v y])"

unbundle MFODL_no_notation \<comment> \<open> disable notation \<close>

(*<*)
end
(*>*)


(*  Title:       Noninterference Security in Communicating Sequential Processes
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "CSP noninterference vs. generalized noninterference"

theory GeneralizedNoninterference
imports ClassicalNoninterference
begin

text \<open>
\null

The purpose of this section is to compare CSP noninterference security as defined previously with
McCullough's notion of generalized noninterference security as formulated in \<^cite>\<open>"R4"\<close>. It will be
shown that this security property is weaker than both CSP noninterference security for a generic
process, and classical noninterference security for classical processes, viz. it is a necessary but
not sufficient condition for them. This renders CSP noninterference security preferable as an
extension of classical noninterference security to nondeterministic systems.

For clarity, all the constants and fact names defined in this section, with the possible exception
of datatype constructors and main theorems, contain prefix \<open>g_\<close>.
\<close>

subsection "Generalized noninterference"

text \<open>
The original formulation of generalized noninterference security as contained in \<^cite>\<open>"R4"\<close> focuses
on systems whose events, split in inputs and outputs, are mapped into either of two security levels,
\emph{high} and \emph{low}. Such a system is said to be secure just in case, for any trace
\<open>xs\<close> and any high-level input \<open>x\<close>, the set of the \emph{possible low-level futures} of
\<open>xs\<close>, i.e. of the sequences of low-level events that may succeed \<open>xs\<close> in the traces of
the system, is equal to the set of the possible low-level futures of \<open>xs @ [x]\<close>.

This definition requires the following corrections:

\begin{itemize}

\item
Variable \<open>x\<close> must range over all high-level events rather than over high-level inputs alone,
since high-level outputs must not be allowed to affect low-level futures as well.

\item
For any \<open>x\<close>, the range of trace \<open>xs\<close> must be restricted to the traces of the system that
may be succeeded by \<open>x\<close>, viz. trace \<open>xs\<close> must be such that event list \<open>xs @ [x]\<close>
be itself a trace.
\\Otherwise, a system that admits both high-level and low-level events in its alphabet but never
accepts any high-level event, always accepting any low-level one instead, would turn out not to be
secure, which is paradoxical since \emph{high} can by no means affect \emph{low} in a system never
engaging in high-level events. The cause of the paradox is that, for each trace \<open>xs\<close> and each
high-level event \<open>x\<close> of such a system, the set of the possible low-level futures of \<open>xs\<close>
matches the Kleene closure of the set of low-level events, whereas the set of the possible low-level
futures of \<open>xs @ [x]\<close> matches the empty set as \<open>xs @ [x]\<close> is not a trace.

\end{itemize}

Observe that the latter correction renders it unnecessary to explicitly assume that event list
\<open>xs\<close> be a trace of the system, as this follows from the assumption that \<open>xs @ [x]\<close> be
such.

Here below is a formal definition of the notion of generalized noninterference security for
processes, amended in accordance with the previous considerations.

\null
\<close>

datatype g_level = High | Low

definition g_secure :: "'a process \<Rightarrow> ('a \<Rightarrow> g_level) \<Rightarrow> bool" where
"g_secure P L \<equiv> \<forall>xs x. xs @ [x] \<in> traces P \<and> L x = High \<longrightarrow>
  {ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]} =
  {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]}"

text \<open>
\null

It is possible to prove that a weaker sufficient (as well as necessary, as obvious) condition for
generalized noninterference security is that the set of the possible low-level futures of trace
\<open>xs\<close> be included in the set of the possible low-level futures of trace \<open>xs @ [x]\<close>,
because the latter is always included in the former.

In what follows, such security property is defined formally and its sufficiency for generalized
noninterference security to hold is demonstrated in the form of an introduction rule, which will
turn out to be useful in subsequent proofs.

\null
\<close>

definition g_secure_suff :: "'a process \<Rightarrow> ('a \<Rightarrow> g_level) \<Rightarrow> bool" where
"g_secure_suff P L \<equiv> \<forall>xs x. xs @ [x] \<in> traces P \<and> L x = High \<longrightarrow>
  {ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]} \<subseteq>
  {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]}"

lemma g_secure_suff_implies_g_secure:
  assumes S: "g_secure_suff P L"
  shows "g_secure P L"
proof (simp add: g_secure_def, (rule allI)+, rule impI, erule conjE)
  fix xs x
  assume
    A: "xs @ [x] \<in> traces P" and
    B: "L x = High"
  show "{ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys . L y = Low]} =
    {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys . L y = Low]}"
   (is "{ys'. \<exists>ys. ?Q ys ys'} = {ys'. \<exists>ys. ?Q' ys ys'}")
  proof (rule equalityI, rule_tac [2] subsetI, simp_all, erule_tac [2] exE,
   erule_tac [2] conjE)
    show "{ys'. \<exists>ys. ?Q ys ys'} \<subseteq> {ys'. \<exists>ys. ?Q' ys ys'}"
     using S and A and B by (simp add: g_secure_suff_def)
  next
    fix ys ys'
    assume "xs @ x # ys \<in> traces P"
    moreover assume "ys' = [y\<leftarrow>ys. L y = Low]"
    hence "ys' = [y\<leftarrow>x # ys. L y = Low]" using B by simp
    ultimately have "?Q (x # ys) ys'" ..
    thus "\<exists>ys. ?Q ys ys'" ..
  qed
qed

subsection "Comparison between security properties"

text \<open>
In the continuation, it will be proven that CSP noninterference security is a sufficient condition
for generalized noninterference security for any process whose events are mapped into either
security domain \<open>High\<close> or \<open>Low\<close>, under the policy that \<open>High\<close> may not affect
\<open>Low\<close>.

Particularly, this is the case for any such classical process. This fact, along with the equivalence
between CSP noninterference security and classical noninterference security for classical processes,
is used to additionally prove that the classical noninterference security of a deterministic state
machine is a sufficient condition for the generalized noninterference security of the corresponding
classical process under the aforesaid policy.

\null
\<close>

definition g_I :: "(g_level \<times> g_level) set" where
"g_I \<equiv> {(High, High), (Low, Low), (Low, High)}"

lemma g_I_refl: "refl g_I"
proof (simp add: refl_on_def, rule allI)
  fix x
  show "(x, x) \<in> g_I" by (cases x, simp_all add: g_I_def)
qed

lemma g_sinks: "sinks g_I L High xs \<subseteq> {High}"
proof (induction xs rule: rev_induct, simp)
  fix x xs
  assume A: "sinks g_I L High xs \<subseteq> {High}"
  show "sinks g_I L High (xs @ [x]) \<subseteq> {High}"
  proof (cases "L x")
    assume "L x = High"
    thus ?thesis using A by simp
  next
    assume B: "L x = Low"
    have "\<not> ((High, L x) \<in> g_I \<or> (\<exists>v \<in> sinks g_I L High xs. (v, L x) \<in> g_I))"
    proof (rule notI, simp add: B, erule disjE)
      assume "(High, Low) \<in> g_I"
      moreover have "(High, Low) \<notin> g_I" by (simp add: g_I_def)
      ultimately show False by contradiction
    next
      assume "\<exists>v \<in> sinks g_I L High xs. (v, Low) \<in> g_I"
      then obtain v where C: "v \<in> sinks g_I L High xs" and D: "(v, Low) \<in> g_I" ..
      have "v \<in> {High}" using A and C ..
      hence "(High, Low) \<in> g_I" using D by simp
      moreover have "(High, Low) \<notin> g_I" by (simp add: g_I_def)
      ultimately show False by contradiction
    qed
    thus ?thesis using A by simp
  qed
qed

lemma g_ipurge_tr: "ipurge_tr g_I L High xs = [x\<leftarrow>xs. L x = Low]"
proof (induction xs rule: rev_induct, simp)
  fix x xs
  assume A: "ipurge_tr g_I L High xs = [x'\<leftarrow>xs. L x' = Low]"
  show "ipurge_tr g_I L High (xs @ [x]) = [x'\<leftarrow>xs @ [x]. L x' = Low]"
  proof (cases "L x")
    assume B: "L x = High"
    hence "ipurge_tr g_I L High (xs @ [x]) = ipurge_tr g_I L High xs"
     by (simp add: g_I_def)
    moreover have "[x'\<leftarrow>xs @ [x]. L x' = Low] = [x'\<leftarrow>xs. L x' = Low]"
     using B by simp
    ultimately show ?thesis using A by simp
  next
    assume B: "L x = Low"
    have "L x \<notin> sinks g_I L High (xs @ [x])"
    proof (rule notI, simp only: B)
      have "sinks g_I L High (xs @ [x]) \<subseteq> {High}" by (rule g_sinks)
      moreover assume "Low \<in> sinks g_I L High (xs @ [x])"
      ultimately have "Low \<in> {High}" ..
      thus False by simp
    qed
    hence "ipurge_tr g_I L High (xs @ [x]) = ipurge_tr g_I L High xs @ [x]"
     by simp
    moreover have "[x'\<leftarrow>xs @ [x]. L x' = Low] = [x'\<leftarrow>xs. L x' = Low] @ [x]"
     using B by simp
    ultimately show ?thesis using A by simp
  qed
qed

theorem secure_implies_g_secure:
  assumes S: "secure P g_I L"
  shows "g_secure P L"
proof (rule g_secure_suff_implies_g_secure, simp add: g_secure_suff_def, (rule allI)+,
 rule impI, rule subsetI, simp, erule exE, (erule conjE)+)
  fix xs x ys ys'
  assume "xs @ [x] \<in> traces P"
  hence "\<exists>X. ([x], X) \<in> futures P xs"
   by (simp add: traces_def Domain_iff futures_def)
  then obtain X where "([x], X) \<in> futures P xs" ..
  moreover assume "xs @ ys \<in> traces P"
  hence "\<exists>Y. (ys, Y) \<in> futures P xs"
   by (simp add: traces_def Domain_iff futures_def)
  then obtain Y where "(ys, Y) \<in> futures P xs" ..
  ultimately have "(x # ipurge_tr g_I L (L x) ys,
    ipurge_ref g_I L (L x) ys Y) \<in> futures P xs"
   (is "(_, ?Y') \<in> futures P xs") using S by (simp add: secure_def)
  moreover assume "L x = High" and A: "ys' = [y\<leftarrow>ys. L y = Low]"
  ultimately have "(x # ys', ?Y') \<in> futures P xs" by (simp add: g_ipurge_tr)
  hence "\<exists>Y'. (x # ys', Y') \<in> futures P xs" ..
  hence "xs @ x # ys' \<in> traces P"
   by (simp add: traces_def Domain_iff futures_def)
  moreover have "ys' = [y\<leftarrow>ys'. L y = Low]" using A by simp
  ultimately have "xs @ x # ys' \<in> traces P \<and> ys' = [y\<leftarrow>ys'. L y = Low]" ..
  thus "\<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]" ..
qed

theorem c_secure_implies_g_secure:
 "c_secure step out s\<^sub>0 g_I L \<Longrightarrow> g_secure (c_process step out s\<^sub>0) (c_dom L)"
by (rule secure_implies_g_secure, rule c_secure_implies_secure, rule g_I_refl)

text \<open>
\null

Since the definition of generalized noninterference security does not impose any explicit
requirement on process refusals, intuition suggests that this security property is likely to be
generally weaker than CSP noninterference security for nondeterministic processes, which are such
that even a complete specification of their traces leaves underdetermined their refusals. This is
not the case for deterministic processes, so the aforesaid security properties might in principle
be equivalent as regards such processes.

However, a counterexample proving the contrary is provided by a deterministic state machine
resembling systems \emph{A} and \emph{B} described in \<^cite>\<open>"R4"\<close>, section 3.1. This machine is proven
not to be classical noninterference-secure, whereas the corresponding classical process turns out to
be generalized noninterference-secure, which proves that the generalized noninterference security of
a classical process is not a sufficient condition for the classical noninterference security of the
associated deterministic state machine.

This result, along with the equivalence between CSP noninterference security and classical
noninterference security for classical processes, is then used to demonstrate that the generalized
noninterference security of the aforesaid classical process does not entail its CSP noninterference
security, which proves that generalized noninterference security is actually not a sufficient
condition for CSP noninterference security even in the case of deterministic processes.

The remainder of this section is dedicated to the construction of such counterexample.

\null
\<close>

datatype g_state = Even | Odd

datatype g_action = Any | Count

primrec g_step :: "g_state \<Rightarrow> g_action \<Rightarrow> g_state" where
"g_step s Any = (case s of Even \<Rightarrow> Odd | Odd \<Rightarrow> Even)" |
"g_step s Count = s"

primrec g_out :: "g_state \<Rightarrow> g_action \<Rightarrow> g_state option" where
"g_out _ Any = None" |
"g_out s Count = Some s"

primrec g_D :: "g_action \<Rightarrow> g_level" where
"g_D Any = High" |
"g_D Count = Low"

definition g_s\<^sub>0 :: g_state where
"g_s\<^sub>0 \<equiv> Even"

lemma g_secure_counterexample:
 "g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D)"
proof (rule g_secure_suff_implies_g_secure, simp add: g_secure_suff_def, (rule allI)+,
 rule impI, rule subsetI, simp, erule exE, (erule conjE)+)
  fix xps x p yps yps'
  assume "xps @ [(x, p)] \<in> traces (c_process g_step g_out g_s\<^sub>0)"
  hence "\<exists>X. (xps @ [(x, p)], X) \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_traces)
  then obtain X where "(xps @ [(x, p)], X) \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "xps @ [(x, p)] = c_tr g_step g_out g_s\<^sub>0 (map fst (xps @ [(x, p)]))"
   by (rule c_failures_tr)
  moreover assume "c_dom g_D (x, p) = High"
  hence "x = Any" by (cases x, simp_all add: c_dom_def)
  ultimately have "xps @ [(x, p)] = c_tr g_step g_out g_s\<^sub>0 (map fst xps @ [Any])"
   (is "_ = _ (?xs @ _)") by simp
  moreover assume "xps @ yps \<in> traces (c_process g_step g_out g_s\<^sub>0)"
  hence "\<exists>Y. (xps @ yps, Y) \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_traces)
  then obtain Y where "(xps @ yps, Y) \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "(yps, Y) \<in> futures (c_process g_step g_out g_s\<^sub>0) xps"
   by (simp add: c_futures_failures)
  hence "yps = c_tr g_step g_out (foldl g_step g_s\<^sub>0 ?xs) (map fst yps)"
   (is "_ = c_tr _ _ _ ?ys") by (rule c_futures_tr)
  hence "yps =
    c_tr g_step g_out (foldl g_step (foldl g_step g_s\<^sub>0 (?xs @ [Any])) [Any]) ?ys"
   (is "_ = c_tr _ _ (foldl _ ?s _) _") by (cases "foldl g_step g_s\<^sub>0 ?xs", simp_all)
  hence "c_tr g_step g_out ?s [Any] @ yps = c_tr g_step g_out ?s ([Any] @ ?ys)"
   (is "?yp @ _ = _") by (simp only: c_tr_append)
  moreover have "(c_tr g_step g_out ?s ([Any] @ ?ys),
    {(x, p). p \<noteq> g_out (foldl g_step ?s ([Any] @ ?ys)) x})
    \<in> futures (c_process g_step g_out g_s\<^sub>0) (c_tr g_step g_out g_s\<^sub>0 (?xs @ [Any]))"
   (is "(_, ?Y') \<in> _") by (rule c_tr_futures)
  ultimately have "(?yp @ yps, ?Y')
    \<in> futures (c_process g_step g_out g_s\<^sub>0) (xps @ [(x, p)])"
   by simp
  hence "(xps @ (x, p) # ?yp @ yps, ?Y') \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_futures_failures)
  hence "\<exists>Y'. (xps @ (x, p) # ?yp @ yps, Y') \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "xps @ (x, p) # ?yp @ yps \<in> traces (c_process g_step g_out g_s\<^sub>0)"
   (is "?P (?yp @ yps)") by (simp add: c_traces)
  moreover assume "yps' = [yp\<leftarrow>yps. c_dom g_D yp = Low]"
  hence "yps' = [yp\<leftarrow>?yp @ yps. c_dom g_D yp = Low]"
   (is "?Q (?yp @ yps)") by (simp add: c_tr_singleton c_dom_def)
  ultimately have "?P (?yp @ yps) \<and> ?Q (?yp @ yps)" ..
  thus "\<exists>yps. ?P yps \<and> ?Q yps" ..
qed

lemma not_c_secure_counterexample:
 "\<not> c_secure g_step g_out g_s\<^sub>0 g_I g_D"
proof (simp add: c_secure_def)
  have "g_out (foldl g_step g_s\<^sub>0 [Any]) Count = Some Odd"
   (is "?f Count [Any] = _") by (simp add: g_s\<^sub>0_def)
  moreover have
    "g_out (foldl g_step g_s\<^sub>0 (c_ipurge g_I g_D (g_D Count) [Any])) Count =
    Some Even"
   (is "?g Count [Any] = _") by (simp add: g_I_def g_s\<^sub>0_def)
  ultimately have "?f Count [Any] \<noteq> ?g Count [Any]" by simp
  thus "\<exists>x xs. ?f x xs \<noteq> ?g x xs" by blast
qed

theorem not_g_secure_implies_c_secure:
 "\<not> (g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D) \<longrightarrow>
  c_secure g_step g_out g_s\<^sub>0 g_I g_D)"
proof (simp, rule conjI, rule g_secure_counterexample)
qed (rule not_c_secure_counterexample)

theorem not_g_secure_implies_secure:
 "\<not> (g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D) \<longrightarrow>
  secure (c_process g_step g_out g_s\<^sub>0) g_I (c_dom g_D))"
proof (simp, rule conjI, rule g_secure_counterexample)
qed (rule notI, drule secure_implies_c_secure, erule contrapos_pp,
 rule not_c_secure_counterexample)

end


theory Mg_Prod
  imports "../Pord" "../Mergeable" "../Bump"
begin

(* For product types, we impose an ordering that requires that _all_ components of
 * product a be less than or equal to their corresponding components of b,
 * in order for a <[ b to hold.
 *
 * In other words, this is _not_ a lexicographic ordering. Lexicographic orderings
 * where the first component is arbitrary create problems around completeness.
 * This is why we work with a more restricted version of a lexicographic-like ordering, md_prio,
 * a pair where the first component is guaranteed to be a natural number, and the ordering
 * is lexicographic (see below)
 *)

instantiation prod :: (Pord_Weak, Pord_Weak) Pord_Weak
begin
  definition prod_pleq :
  "(x :: 'a * 'b) <[ y =
    (case x of
        (x1, x2) \<Rightarrow> (case y of
                      (y1, y2) \<Rightarrow> (pleq x1 y1 \<and> pleq x2 y2)))"
instance proof
  fix a :: "('a * 'b)"
  show "pleq a a" by (auto simp add:prod_pleq leq_refl split:prod.splits)
next
  fix a b c :: "('a * 'b)"
  assume H1 : "pleq a b"
  assume H2 : "pleq b c"

  obtain a1 and a2 where 0 : "a = (a1, a2)" by (cases a; auto)
  obtain b1 and b2 where 1 : "b = (b1, b2)" by (cases b; auto)
  obtain c1 and c2 where 2 : "c = (c1, c2)" by (cases c; auto)

  show "pleq a c" using H1 H2 0 1 2 leq_trans[of a1 b1 c1] leq_trans[of a2 b2 c2]
    by (auto simp add:prod_pleq)
qed
end

instantiation prod :: (Pord, Pord) Pord
begin
instance proof
  fix a b :: "('a * 'b)"
  assume H1 : "pleq a b"
  assume H2 : "pleq b a"

  obtain a1 and a2 where 0 : "a = (a1, a2)" by (cases a; auto)
  obtain b1 and b2 where 1 : "b = (b1, b2)" by (cases b; auto)

  show "a = b" using H1 H2 0 1 leq_antisym[of a1 b1] leq_antisym[of a2 b2]
    by(auto simp add:prod_pleq)
qed
end

instantiation prod :: (Pordc, Pordc) Pordc
begin
instance proof

  fix a b :: "('a * 'b)"
  assume H : "has_ub {a, b}"

  obtain a1 and a2 where 0 : "a = (a1, a2)" by (cases a; auto)
  obtain b1 and b2 where 1 : "b = (b1, b2)" by (cases b; auto)

  obtain ub where HUb : "is_ub {a, b} ub" using H by (auto simp add:has_ub_def)
  obtain ub1 and ub2 where HUb' : "ub = (ub1, ub2)" by (cases ub; auto)

  have Ub1 : "is_ub {a1, b1} ub1" using H 0 1 HUb HUb'
    by(auto simp add:prod_pleq is_ub_def)
  have Ub2 : "is_ub {a2, b2} ub2" using H 0 1 HUb HUb'
    by(auto simp add:prod_pleq is_ub_def)

  obtain sup1 where Sup1 : "is_sup {a1, b1} sup1" using complete2[of a1 b1] Ub1
    by(auto simp add: has_sup_def has_ub_def)

  obtain sup2 where Sup2 : "is_sup {a2, b2} sup2"
    using complete2[of a2 b2] Ub2
    by(auto simp add: has_sup_def has_ub_def)

  have Sup : "is_sup {(a1, a2), (b1, b2)} (sup1, sup2)" using Sup1 Sup2
    by(auto simp add: prod_pleq is_sup_def is_ub_def is_least_def)

  thus "has_sup {a, b}" using 0 1 by (auto simp add:has_sup_def)
qed
end

lemma is_sup_fst :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_sup Xs supr"
  shows "is_sup ((\<lambda> w . (w, x')) ` Xs) (supr, x')"
proof(rule is_supI)
  fix x

  assume X: "x \<in> (\<lambda>w. (w, x')) ` Xs"

  then obtain x1 where X1 :
    "x = (x1, x')" "x1 \<in> Xs"
    by auto

  have "x1 <[ supr"
    using is_supD1[OF H X1(2)] by auto

  then show "x <[ (supr, x')"
    using X1
    by(auto simp add: prod_pleq leq_refl)
next

  fix y

  assume Y: "is_ub ((\<lambda>w. (w, x')) ` Xs) y"

  obtain y1 y2 where Y1_2 : "y = (y1, y2)"
    by(cases y; auto)

  have "is_ub Xs y1"
  proof(rule is_ubI)
    fix z

    assume Z: "z \<in> Xs"

    then have "(z, x') <[ y"
      using is_ubE[OF Y] by auto

    then show "z <[ y1"
      using Y1_2
      by(auto simp add: prod_pleq)
  qed

  then have "supr <[ y1"
    using is_supD2[OF H]
    by auto

  have "(x, x') <[ y"
    using is_ubE[OF Y] Hnemp
    by auto

  then have "x' <[ y2"
    using Y1_2
    by(auto simp add: prod_pleq)

  show "(supr, x') <[ y"
    using `supr <[ y1` `x' <[ y2` Y1_2
    by(auto simp add: prod_pleq)
qed

lemma is_ub_fst :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_ub Xs ub"
  shows "is_ub ((\<lambda> w . (w, x')) ` Xs) (ub, x')"
proof(rule is_ubI)
  fix x

  assume X: "x \<in> (\<lambda>w. (w, x')) ` Xs"

  then obtain x1 where X1 :
    "x = (x1, x')" "x1 \<in> Xs"
    by auto

  have "x1 <[ ub"
    using is_ubE[OF H X1(2)] by auto

  then show "x <[ (ub, x')"
    using X1
    by(auto simp add: prod_pleq leq_refl)
qed

lemma is_sup_fst' :
  assumes Hnemp : "xy \<in> Xys"
  assumes H : "is_sup Xys (s1, s2)"
  shows "is_sup (fst ` Xys) s1"
proof(rule is_supI)

  fix x

  assume X: "x \<in> fst ` Xys"
  then obtain y where Xy : "(x, y) \<in> Xys"
    by(auto)

  then have "(x, y) <[ (s1, s2)"
    using is_supD1[OF H Xy]
    by auto

  then show "x <[ s1"
    by(auto simp add: prod_pleq)
next

  fix x'

  assume X' : "is_ub (fst ` Xys) x'"

  have Ub' : "is_ub Xys (x', s2)"
  proof(rule is_ubI)

    fix w

    assume W : "w \<in> Xys"

    obtain w1 w2 where W1_2 :
      "w = (w1, w2)"
      by(cases w; auto)

    then have "w1 \<in> fst ` Xys" using imageI[OF W, of fst]
      by auto

    then have "w1 <[ x'"
      using is_ubE[OF X'] by auto

    have "w2 \<in> snd ` Xys" using imageI[OF W, of snd] W1_2
      by auto

    then have "w2 <[ s2"
      using is_supD1[OF H W] W1_2
      by(auto simp add: prod_pleq)

    then show "w <[ (x', s2)"
      using `w1 <[ x'` W1_2
      by(auto simp add: prod_pleq)
  qed

  show "s1 <[ x'"
    using is_supD2[OF H Ub']
    by(auto simp add: prod_pleq)
qed

lemma is_ub_fst' :
  assumes Hnemp : "xy \<in> Xys"
  assumes H : "is_ub Xys (s1, s2)"
  shows "is_ub (fst ` Xys) s1"
proof(rule is_ubI)

  fix x

  assume X: "x \<in> fst ` Xys"
  then obtain y where Xy : "(x, y) \<in> Xys"
    by(auto)

  then have "(x, y) <[ (s1, s2)"
    using is_ubE[OF H Xy]
    by auto

  then show "x <[ s1"
    by(auto simp add: prod_pleq)
qed

lemma is_sup_snd :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_sup Xs supr"
  shows "is_sup ((\<lambda> w . (x', w)) ` Xs) (x', supr)"
proof(rule is_supI)
  fix x

  assume X: "x \<in> (\<lambda>w. (x', w)) ` Xs"

  then obtain x2 where X2 :
    "x = (x', x2)" "x2 \<in> Xs"
    by auto

  have "x2 <[ supr"
    using is_supD1[OF H X2(2)] by auto

  then show "x <[ (x', supr)"
    using X2
    by(auto simp add: prod_pleq leq_refl)
next

  fix y

  assume Y: "is_ub ((\<lambda>w. (x', w)) ` Xs) y"

  obtain y1 y2 where Y1_2 : "y = (y1, y2)"
    by(cases y; auto)

  have "is_ub Xs y2"
  proof(rule is_ubI)
    fix z

    assume Z: "z \<in> Xs"

    then have "(x', z) <[ y"
      using is_ubE[OF Y] by auto

    then show "z <[ y2"
      using Y1_2
      by(auto simp add: prod_pleq)
  qed

  then have "supr <[ y2"
    using is_supD2[OF H]
    by auto

  have "(x', x) <[ y"
    using is_ubE[OF Y] Hnemp
    by auto

  then have "x' <[ y1"
    using Y1_2
    by(auto simp add: prod_pleq)

  show "(x', supr) <[ y"
    using `supr <[ y2` `x' <[ y1` Y1_2
    by(auto simp add: prod_pleq)
qed

lemma is_ub_snd :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_ub Xs ub"
  shows "is_ub ((\<lambda> w . (x', w)) ` Xs) (x', ub)"
proof(rule is_ubI)
  fix x

  assume X: "x \<in> (\<lambda>w. (x', w)) ` Xs"

  then obtain x2 where X2 :
    "x = (x', x2)" "x2 \<in> Xs"
    by auto

  have "x2 <[ ub"
    using is_ubE[OF H X2(2)] by auto

  then show "x <[ (x', ub)"
    using X2
    by(auto simp add: prod_pleq leq_refl)
qed

lemma is_sup_snd' :
  assumes Hnemp : "xy \<in> Xys"
  assumes H : "is_sup Xys (s1, s2)"
  shows "is_sup (snd ` Xys) s2"
proof(rule is_supI)

  fix y

  assume Y: "y \<in> snd ` Xys"
  then obtain x where Xy : "(x, y) \<in> Xys"
    by(auto)

  then have "(x, y) <[ (s1, s2)"
    using is_supD1[OF H Xy]
    by auto

  then show "y <[ s2"
    by(auto simp add: prod_pleq)
next

  fix y'

  assume Y' : "is_ub (snd ` Xys) y'"

  have Ub' : "is_ub Xys (s1, y')"
  proof(rule is_ubI)

    fix w

    assume W : "w \<in> Xys"

    obtain w1 w2 where W1_2 :
      "w = (w1, w2)"
      by(cases w; auto)

    then have "w2 \<in> snd ` Xys" using imageI[OF W, of snd]
      by auto

    then have "w2 <[ y'"
      using is_ubE[OF Y'] by auto

    have "w1 \<in> fst ` Xys" using imageI[OF W, of fst] W1_2
      by auto

    then have "w1 <[ s1"
      using is_supD1[OF H W] W1_2
      by(auto simp add: prod_pleq)

    then show "w <[ (s1, y')"
      using `w2 <[ y'` W1_2
      by(auto simp add: prod_pleq)
  qed

  show "s2 <[ y'"
    using is_supD2[OF H Ub']
    by(auto simp add: prod_pleq)
qed

lemma is_ub_snd' :
  assumes Hnemp : "xy \<in> Xys"
  assumes H : "is_ub Xys (s1, s2)"
  shows "is_ub (snd ` Xys) s2"
proof(rule is_ubI)

  fix y

  assume Y: "y \<in> snd ` Xys"
  then obtain x where Xy : "(x, y) \<in> Xys"
    by(auto)

  then have "(x, y) <[ (s1, s2)"
    using is_ubE[OF H Xy]
    by auto

  then show "y <[ s2"
    by(auto simp add: prod_pleq)
qed

lemma is_sup_prod :
  assumes Hx : "is_sup Xs suprx"
  assumes Hy : "is_sup Ys supry"
  assumes S1 : "fst ` S = Xs"
  assumes S2 : "snd ` S = Ys"
  shows "is_sup S (suprx, supry)"
proof(rule is_supI)
  fix w
  assume W_in : "w \<in> S"

  obtain w1 w2 where W:
    "w = (w1, w2)"
    by(cases w; auto)

  have W_Xs : "w1 \<in> Xs" and W_Ys : "w2 \<in> Ys"
    using S1 S2 W_in W
    using imageI[OF W_in, of fst] imageI[OF W_in, of snd]
    by(auto)

  have "w1 <[ suprx" "w2 <[ supry"
    using is_supD1[OF Hx W_Xs] is_supD1[OF Hy W_Ys] W
    by auto

  then show "w <[ (suprx, supry)"
    using W by(auto simp add: prod_pleq)
next

  fix w'
  assume Ub : "is_ub S w'"

  obtain w'1 w'2 where W':
    "w' = (w'1, w'2)"
    by(cases w'; auto)

  have Ub_Xs : "is_ub Xs w'1"
  proof(rule is_ubI)
    fix x

    assume X : "x \<in> Xs"

    then obtain y where Y: "(x, y) \<in> S"
      using S1
      by(auto)

    have "(x, y) <[ w'"
      using is_ubE[OF Ub Y]
      by auto

    then show "x <[ w'1"
      using W'
      by(auto simp add: prod_pleq)
  qed

  have Ub_Ys : "is_ub Ys w'2"
  proof(rule is_ubI)
    fix y

    assume Y : "y \<in> Ys"

    then obtain x where X: "(x, y) \<in> S"
      using S2
      by(auto)

    have "(x, y) <[ w'"
      using is_ubE[OF Ub X]
      by auto

    then show "y <[ w'2"
      using W'
      by(auto simp add: prod_pleq)
  qed

  have "suprx <[ w'1" "supry <[ w'2"
    using is_supD2[OF Hx Ub_Xs] is_supD2[OF Hy Ub_Ys]
    by auto

  then show "(suprx, supry) <[ w'"
    using W'
    by(auto simp add: prod_pleq)
qed

lemma is_ub_prod :
  assumes Hx : "is_ub Xs ubx"
  assumes Hy : "is_ub Ys uby"
  assumes S1 : "fst ` S = Xs"
  assumes S2 : "snd ` S = Ys"
  shows "is_ub S (ubx, uby)"
proof(rule is_ubI)
  fix w
  assume W_in : "w \<in> S"

  obtain w1 w2 where W:
    "w = (w1, w2)"
    by(cases w; auto)

  have W_Xs : "w1 \<in> Xs" and W_Ys : "w2 \<in> Ys"
    using S1 S2 W_in W
    using imageI[OF W_in, of fst] imageI[OF W_in, of snd]
    by(auto)

  have "w1 <[ ubx" "w2 <[ uby"
    using is_ubE[OF Hx W_Xs] is_ubE[OF Hy W_Ys] W
    by auto

  then show "w <[ (ubx, uby)"
    using W by(auto simp add: prod_pleq)
qed

instantiation prod :: (Pordps, Pordps) Pordps
begin
instance proof
  fix a b c :: "'a * 'b"

  assume "has_sup {a, b}"
  then obtain sup_ab
    where Sup_ab : "is_sup {a, b} sup_ab"
    by(auto simp add: has_sup_def)

  obtain sup_ab1 sup_ab2 where
    Sup_ab12 : "sup_ab = (sup_ab1, sup_ab2)"
    by(cases sup_ab; auto)

  assume Sup_bc : "has_sup {b, c}"
  then obtain sup_bc
    where Sup_bc : "is_sup {b, c} sup_bc"
    by(auto simp add: has_sup_def)

  obtain sup_bc1 sup_bc2 where
    Sup_bc12 : "sup_bc = (sup_bc1, sup_bc2)"
    by(cases sup_bc; auto)

  assume Sup_ac : "has_sup {a, c}"
  then obtain sup_ac
    where Sup_ac : "is_sup {a, c} sup_ac"
    by(auto simp add: has_sup_def)

  obtain sup_ac1 sup_ac2 where
    Sup_ac12 : "sup_ac = (sup_ac1, sup_ac2)"
    by(cases sup_ac; auto)

  obtain a1 a2 where A: "a = (a1, a2)"
    by(cases a; auto)

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  obtain c1 c2 where C: "c = (c1, c2)"
    by(cases c; auto)

  have Has_sup_ab1 :
    "has_sup {a1, b1}"
    using Sup_ab Sup_ab12 A B
      is_sup_fst'[of a "{a, b}" sup_ab1 sup_ab2]
    by(auto simp add: has_sup_def)

  have Has_sup_ab2 :
    "has_sup {a2, b2}"
    using Sup_ab Sup_ab12 A B
      is_sup_snd'[of a "{a, b}" sup_ab1 sup_ab2]
    by(auto simp add: has_sup_def)

  have Has_sup_bc1 :
    "has_sup {b1, c1}"
    using Sup_bc Sup_bc12 B C
      is_sup_fst'[of b "{b, c}" sup_bc1 sup_bc2]
    by(auto simp add: has_sup_def)

  have Has_sup_bc2 :
    "has_sup {b2, c2}"
    using Sup_bc Sup_bc12 B C
      is_sup_snd'[of b "{b, c}" sup_bc1 sup_bc2]
    by(auto simp add: has_sup_def)

  have Has_sup_ac1 :
    "has_sup {a1, c1}"
    using Sup_ac Sup_ac12 A C
      is_sup_fst'[of a "{a, c}" sup_ac1 sup_ac2]
    by(auto simp add: has_sup_def)

  have Has_sup_ac2 :
    "has_sup {a2, c2}"
    using Sup_ac Sup_ac12 A C
      is_sup_snd'[of a "{a, c}" sup_ac1 sup_ac2]
    by(auto simp add: has_sup_def)

  obtain sup1 where Sup1 :
    "is_sup {a1, b1, c1} sup1"
    using pairwise_sup[OF Has_sup_ab1 Has_sup_bc1 Has_sup_ac1]
    by(auto simp add: has_sup_def)

  obtain sup2 where Sup2 :
    "is_sup {a2, b2, c2} sup2"
    using pairwise_sup[OF Has_sup_ab2 Has_sup_bc2 Has_sup_ac2]
    by(auto simp add: has_sup_def)

  have "is_sup {a, b, c} (sup1, sup2)"
    using is_sup_prod[OF Sup1 Sup2, of "{a, b, c}"]
    unfolding A B C
    by auto

  then show "has_sup {a, b, c}"
    by(auto simp add: has_sup_def)
qed
end

instantiation prod :: (Pordpsok, Pordpsok) Pordpsok
begin
instance proof
  fix a b supr :: "('a * 'b)"
  assume Aok : "a \<in> ok_S"
  assume Bok : "b \<in> ok_S"
  assume Sup : "is_sup {a, b} supr"

  obtain a1 a2 where A : "a = (a1, a2)" "a1 \<in> ok_S" "a2 \<in> ok_S"
    using Aok
    by(cases a; auto simp add: prod_ok_S)

  obtain b1 b2 where B : "b = (b1, b2)" "b1 \<in> ok_S" "b2 \<in> ok_S"
    using Bok
    by(cases b; auto simp add: prod_ok_S)

  obtain supr1 supr2 where Supr12 : "supr = (supr1, supr2)"
    by(cases supr; auto)

  have Supr_fst : "is_sup {a1, b1} supr1"
    using is_sup_fst'[of a "{a, b}" supr1 supr2] Sup
    unfolding A B Supr12
    by auto

  then have Supr_fst_ok : "supr1 \<in> ok_S"
    using pairwise_sup_ok[OF A(2) B(2) Supr_fst] by auto

  have Supr_snd : "is_sup {a2, b2} supr2"
    using is_sup_snd'[of a "{a, b}" supr1 supr2] Sup
    unfolding A B Supr12
    by auto

  then have Supr_snd_ok : "supr2 \<in> ok_S"
    using pairwise_sup_ok[OF A(3) B(3) Supr_snd] by auto

  then show "supr \<in> ok_S"
    using Supr_fst_ok Supr_snd_ok Supr12
    by(auto simp add: prod_ok_S)
qed
end

instantiation prod :: (Pord_Weakb, Pord_Weakb) Pord_Weakb
begin
definition prod_bot :
  "(bot :: 'a * 'b) = (bot, bot)"
instance proof
  fix a :: "'a * 'b"
  show "pleq bot a"
    by(cases a; auto simp add:prod_pleq prod_bot bot_spec)
qed
end

instantiation prod :: (Pordb, Pordb) Pordb
begin
instance proof
qed
end

instantiation prod :: (Mergeableb, Mergeableb) Mergeableb
begin

definition prod_bsup :
"[^ a, b ^] =
  (case a of
    (a1, a2) \<Rightarrow> (case b of
                  (b1, b2) \<Rightarrow> (bsup a1 b1, bsup a2 b2)))"

instance proof
  fix a :: "'a  * 'b"
  fix b :: "'a * 'b"

  obtain a1 and a2 where Ha : "a = (a1, a2)" by(cases a; auto)
  obtain b1 and b2 where Hb : "b = (b1, b2)" by(cases b; auto)

  show "is_bsup a b (bsup a b)"
  proof(rule is_bsupI)

    show "pleq a (bsup a b)" using Ha Hb bsup_leq[OF bsup_spec[of a1 b1]] bsup_leq[OF bsup_spec[of a2 b2]]
      by(auto simp add:prod_bsup prod_pleq split:prod.splits)

  next
    fix bd :: "'a * 'b"
    fix sd :: "'a * 'b"

    obtain a1 and a2 where Ha : "a = (a1, a2)" by(cases a; auto)
    obtain b1 and b2 where Hb : "b = (b1, b2)" by(cases b; auto)
    obtain bd1 and bd2 where Hbd : "bd = (bd1, bd2)" by(cases bd; auto)
    obtain sd1 and sd2 where Hsd : "sd = (sd1, sd2)" by(cases sd; auto)

    obtain bsupv1 and bsupv2 where Hbsup : "bsup a b = (bsupv1, bsupv2)" by (cases "(bsup a b)"; auto)

    assume Hleq : "pleq bd b"
    assume Hsup : "is_sup {a, bd} sd"

    have Hbsv1 : "bsupv1 = bsup a1 b1" using Ha Hb Hbsup
      by(auto simp add:prod_bsup)
    have Hbsv2 : "bsupv2 = bsup a2 b2" using Ha Hb Hbsup
      by(auto simp add:prod_bsup)

    have Sup1 : "is_sup {a1, bd1} sd1" using Ha Hbd Hsd Hsup
      by(auto simp add: prod_pleq is_sup_def is_least_def is_ub_def)

    have Sup2 : "is_sup {a2, bd2} sd2" using Ha Hbd Hsd Hsup
      by(auto simp add: prod_pleq is_sup_def is_least_def is_ub_def)

    have Leq1 : "pleq bd1 b1" using Hb Hbd Hleq
      by(auto simp add: prod_pleq is_sup_def is_least_def is_ub_def)

    have Leq2 : "pleq bd2 b2" using Hb Hbd Hleq
      by(auto simp add: prod_pleq is_sup_def is_least_def is_ub_def)

    have Bsup1 : "is_bsup a1 b1 bsupv1" using Hbsup Ha Hb bsup_spec[of a1 b1]
      by(auto simp add:prod_bsup)

    have Bsup2 : "is_bsup a2 b2 bsupv2" using Hbsup Ha Hb bsup_spec[of a2 b2]
      by(auto simp add:prod_bsup)

    have Conc1 : "pleq sd1 (bsup a1 b1)" using is_bsupD2[OF Bsup1 Leq1 Sup1] Hbsv1
      by(auto simp add:is_bsup_def is_least_def is_bub_def)

    have Conc2 : "pleq sd2 (bsup a2 b2)" using is_bsupD2[OF Bsup2 Leq2 Sup2] Hbsv2
      by(auto simp add:is_bsup_def is_least_def is_bub_def)

    show "pleq sd (bsup a b)" using Ha Hb Hbsup Hbsv1 Hbsv2 Hsd Conc1 Conc2
      by(auto simp add: prod_pleq prod_bsup)

  next

      fix x :: "'a * 'b"
      obtain a1 and a2 where Ha : "a = (a1, a2)" by(cases a; auto)
      obtain b1 and b2 where Hb : "b = (b1, b2)" by(cases b; auto)
      obtain x1 and x2 where Hx : "x = (x1, x2)" by(cases x; auto)
      obtain bsupv1 and bsupv2 where Hbsup : "bsup a b = (bsupv1, bsupv2)" by (cases "(bsup a b)"; auto)

      have Hbsv1 : "bsupv1 = bsup a1 b1" using Ha Hb Hbsup
        by(auto simp add:prod_bsup)
      have Hbsv2 : "bsupv2 = bsup a2 b2" using Ha Hb Hbsup
        by(auto simp add:prod_bsup)

      assume Hbub : "is_bub a b x"

      have Hbub1 : "is_bub a1 b1 x1"
      proof(rule is_bubI)
        show "pleq a1 x1" using Hbub Ha Hx by(auto simp add:is_bub_def is_sup_def prod_pleq)
      next
        fix bd1 :: 'a
        fix sd1 :: 'a
        assume H1 : "pleq bd1 b1"
        assume H2 : "is_sup {a1,bd1} sd1"

        have Hpleq' : "pleq (bd1, bot) b" using H1 Hb bot_spec[of b2]
          by (auto simp add: prod_pleq)

        have Hsup' : "is_sup {a, (bd1, bot)} (sd1, a2)" using Ha bot_spec[of a2] H2
          by(auto simp add:is_sup_def is_least_def is_ub_def leq_refl prod_pleq)

        show "pleq sd1 x1" using is_bubD2[OF Hbub Hpleq' Hsup'] Hx
          by(simp add:prod_pleq)
      qed

      have Hbub2 : "is_bub a2 b2 x2"
      proof(rule is_bubI)
        show "pleq a2 x2" using Hbub Ha Hx by(auto simp add:is_bub_def is_sup_def prod_pleq)
      next
        fix bd2 :: 'b
        fix sd2 :: 'b
        assume H1 : "pleq bd2 b2"
        assume H2 : "is_sup {a2,bd2} sd2"

        have Hpleq' : "pleq (bot, bd2) b" using H1 Hb bot_spec[of b1]
          by (auto simp add: prod_pleq)

        have Hsup' : "is_sup {a, (bot, bd2)} (a1, sd2)" using Ha bot_spec[of a1] H2
          by(auto simp add:is_sup_def is_least_def is_ub_def leq_refl prod_pleq)

        show "pleq sd2 x2" using is_bubD2[OF Hbub Hpleq' Hsup'] Hx
          by(simp add:prod_pleq)
      qed

      show "pleq (bsup a b) x" using Hx Ha Hb Hbub1 Hbub2 bsup_spec[of a1 b1] bsup_spec[of a2 b2]
        by(auto simp add:is_bsup_def is_least_def prod_pleq prod_bsup)
    qed
  qed
end

instantiation prod :: (Pordc_all, Pordc_all) Pordc_all
begin

instance proof
  fix a b :: "'a * 'b"

  obtain a1 a2 where A: "a = (a1, a2)"
    by(cases a; auto)

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  obtain ub1 where Ub1 : "is_ub {a1, b1} ub1"
    using ub2_all[of a1 b1]
    by(auto simp add: has_ub_def)

  obtain ub2 where Ub2 : "is_ub {a2, b2} ub2"
    using ub2_all[of a2 b2]
    by(auto simp add: has_ub_def)

  have "is_ub {a, b} (ub1, ub2)"
    using is_ub_prod[OF Ub1 Ub2, of "{a, b}"]
    unfolding A B
    by auto

  then show "has_ub {a, b}"
    by(auto simp add: has_ub_def)
qed
end

instantiation prod :: (Bump, Bump) Bump
begin

definition prod_bump :
  "bump x = (case x of (x1, x2) \<Rightarrow> (bump x1, bump x2))"

instance proof
  fix x :: "'a * 'b"
  show "bump x \<noteq> x"
    by(cases x; auto simp add: prod_bump bump_neq)
next
  fix x :: "'a * 'b"
  show "x <[ bump x"
    by(cases x; auto simp add: prod_bump prod_pleq bump_geq)
qed

end

end


(*  Title:       Inductive definition of Hoare logic
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory PsHoare imports PsLang begin

subsection{* Hoare logic for partial correctness *}

type_synonym 'a assn = "'a \<Rightarrow> state \<Rightarrow> bool"
type_synonym 'a cntxt = "('a assn \<times> com \<times> 'a assn)set"

definition
 valid :: "'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
 "\<Turnstile> {P}c{Q} \<equiv> (\<forall>s t z. s -c\<rightarrow> t \<longrightarrow> P z s \<longrightarrow> Q z t)"

definition
 valids :: "'a cntxt \<Rightarrow> bool" ("|\<Turnstile> _" 50) where
 "|\<Turnstile> D \<equiv> (\<forall>(P,c,Q) \<in> D. \<Turnstile> {P}c{Q})"

definition
 nvalid :: "nat \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile>_ {(1_)}/ (_)/ {(1_)}" 50) where
 "\<Turnstile>n {P}c{Q} \<equiv> (\<forall>s t z. s -c-n\<rightarrow> t \<longrightarrow> P z s \<longrightarrow> Q z t)"

definition
 nvalids :: "nat \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("|\<Turnstile>'__/ _" 50) where
 "|\<Turnstile>_n C \<equiv> (\<forall>(P,c,Q) \<in> C. \<Turnstile>n {P}c{Q})"

text{* We now need an additional notion of
validity \mbox{@{text"C |\<Turnstile> D"}} where @{term D} is a set as well. The
reason is that we can now have mutually recursive procedures whose
correctness needs to be established by simultaneous induction. Instead
of sets of Hoare triples we may think of conjunctions. We define both
@{text"C |\<Turnstile> D"} and its relativized version: *}

definition
 cvalids :: "'a cntxt \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("_ |\<Turnstile>/ _" 50) where
  "C |\<Turnstile> D \<longleftrightarrow> |\<Turnstile> C \<longrightarrow> |\<Turnstile> D"

definition
 cnvalids :: "'a cntxt \<Rightarrow> nat \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("_ |\<Turnstile>'__/ _" 50) where
  "C |\<Turnstile>_n D \<longleftrightarrow> |\<Turnstile>_n C \<longrightarrow> |\<Turnstile>_n D"

text{*Our Hoare logic now defines judgements of the form @{text"C \<tturnstile>
D"} where both @{term C} and @{term D} are (potentially infinite) sets
of Hoare triples; @{text"C \<turnstile> {P}c{Q}"} is simply an abbreviation for
@{text"C \<tturnstile> {(P,c,Q)}"}.*}

inductive
  hoare :: "'a cntxt \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("_ \<tturnstile>/ _" 50)
  and hoare3 :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("_ \<turnstile>/ ({(1_)}/ (_)/ {(1_)})" 50)
where
  "C \<turnstile> {P}c{Q}  \<equiv>  C \<tturnstile> {(P,c,Q)}"
| Do:  "C \<turnstile> {\<lambda>z s. \<forall>t \<in> f s . P z t} Do f {P}"
| Semi: "\<lbrakk> C \<turnstile> {P}c{Q}; C \<turnstile> {Q}d{R} \<rbrakk> \<Longrightarrow> C \<turnstile> {P} c;d {R}"
| If: "\<lbrakk> C \<turnstile> {\<lambda>z s. P z s \<and> b s}c{Q}; C \<turnstile> {\<lambda>z s. P z s \<and> \<not>b s}d{Q}  \<rbrakk> \<Longrightarrow>
      C \<turnstile> {P} IF b THEN c ELSE d {Q}"
| While: "C \<turnstile> {\<lambda>z s. P z s \<and> b s} c {P} \<Longrightarrow>
          C \<turnstile> {P} WHILE b DO c {\<lambda>z s. P z s \<and> \<not>b s}"

| Conseq: "\<lbrakk> C \<turnstile> {P'}c{Q'};
             \<forall>s t. (\<forall>z. P' z s \<longrightarrow> Q' z t) \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t) \<rbrakk> \<Longrightarrow>
           C \<turnstile> {P}c{Q}"

| Call: "\<lbrakk> \<forall>(P,c,Q) \<in> C. \<exists>p. c = CALL p;
     C \<tturnstile> {(P,b,Q). \<exists>p. (P,CALL p,Q) \<in> C \<and> b = body p} \<rbrakk>
  \<Longrightarrow> {} \<tturnstile> C"

| Asm: "(P,CALL p,Q) \<in> C \<Longrightarrow> C \<turnstile> {P} CALL p {Q}"

| ConjI: "\<forall>(P,c,Q) \<in> D. C \<turnstile> {P}c{Q}  \<Longrightarrow>  C \<tturnstile> D"
| ConjE: "\<lbrakk> C \<tturnstile> D; (P,c,Q) \<in> D \<rbrakk> \<Longrightarrow> C \<turnstile> {P}c{Q}"

| Local: "\<lbrakk> \<forall>s'. C \<turnstile> {\<lambda>z s. P z s' \<and> s = f s'} c {\<lambda>z t. Q z (g s' t)} \<rbrakk> \<Longrightarrow>
        C \<turnstile> {P} LOCAL f;c;g {Q}"
monos split_beta

lemmas valid_defs = valid_def valids_def cvalids_def
                    nvalid_def nvalids_def cnvalids_def

theorem "C \<tturnstile> D  \<Longrightarrow>  C |\<Turnstile> D"

txt{*\noindent As before, we prove a generalization of @{prop"C |\<Turnstile> D"},
namely @{prop"\<forall>n. C |\<Turnstile>_n D"}, by induction on @{prop"C \<tturnstile> D"}, with an
induction on @{term n} in the @{term CALL} case.*}

apply(subgoal_tac "\<forall>n. C |\<Turnstile>_n D")
apply(unfold valid_defs exec_iff_execn[THEN eq_reflection])
 apply fast
apply(erule hoare.induct);
      apply simp
     apply simp
     apply fast
    apply simp
   apply clarify
   apply(drule while_rule)
   prefer 3
   apply (assumption, assumption)
   apply simp
  apply simp
  apply fast
 apply(rule allI, rule impI)
 apply(induct_tac n)
  apply force
 apply clarify
 apply(frule bspec, assumption)
 apply (simp(no_asm_use))
 apply fast
apply simp
apply fast

apply simp
apply fast

apply fast

apply fastforce
done

definition MGT :: "com \<Rightarrow> state assn \<times> com \<times> state assn" where
  [simp]: "MGT c = (\<lambda>z s. z = s, c, \<lambda>z t. z -c\<rightarrow> t)"

lemma MGT_implies_complete:
  "{} \<tturnstile> {MGT c} \<Longrightarrow> \<Turnstile> {P}c{Q} \<Longrightarrow> {} \<turnstile> {P}c{Q::state assn}";
apply(unfold MGT_def)
apply (erule hoare.Conseq)
apply(simp add: valid_defs)
done

lemma MGT_lemma: "\<forall>p. C \<tturnstile> {MGT(CALL p)}  \<Longrightarrow>  C \<tturnstile> {MGT c}"
apply (simp)
apply(induct_tac c)
    apply (rule strengthen_pre[OF _ hoare.Do])
    apply blast
   apply simp
   apply (rule hoare.Semi)
    apply blast
   apply (rule hoare.Conseq)
    apply blast
   apply blast
  apply clarsimp
  apply(rule hoare.If)
   apply(rule hoare.Conseq)
    apply blast
   apply simp
  apply(rule hoare.Conseq)
   apply blast
  apply simp
 prefer 2
 apply simp
apply(rename_tac b c)
apply(rule hoare.Conseq)
 apply(rule_tac P = "\<lambda>z s. (z,s) \<in> ({(s,t). b s \<and> s -c\<rightarrow> t})^*"
       in hoare.While)
 apply(erule hoare.Conseq)
 apply(blast intro:rtrancl_into_rtrancl)
apply clarsimp
apply(rename_tac s t)
apply(erule_tac x = s in allE)
apply clarsimp
apply(erule converse_rtrancl_induct)
 apply(blast intro:exec.intros)
apply(fast elim:exec.WhileTrue)

apply(fastforce intro: hoare.Local elim!: hoare.Conseq)
done

lemma MGT_body: "(P, CALL p, Q) = MGT (CALL pa) \<Longrightarrow> C \<tturnstile> {MGT (body p)} \<Longrightarrow> C \<turnstile> {P} body p {Q}"
apply clarsimp
done

declare MGT_def[simp del]

theorem Complete: "\<Turnstile> {P}c{Q}  \<Longrightarrow>  {} \<turnstile> {P}c{Q::state assn}";
apply(rule MGT_implies_complete)
 prefer 2
 apply assumption
apply (rule MGT_lemma);
apply(rule allI)
apply(unfold MGT_def)
apply(rule hoare.ConjE[OF MGT_CALL])
apply(simp add:MGT_def fun_eq_iff)
done

end


theory CommAnd
  imports Main
begin

text\<open> Apply style, the proof here corresponds to the proof for lem_j_3 \<close>
lemma lem_i_1 : "(p \<and> q) \<longrightarrow> (p \<and> q)"
  apply (rule impI)
  apply assumption
  done

text\<open> Isar style, the proof illustrates the use of intermediate facts,
   with keywords 'from ... have ...' \<close>
lemma lem_j_1 : "(p \<and> q) \<longrightarrow> (p \<and> q)"
proof
  assume a : "p \<and> q"
  from a have b : "p" by (rule conjE)   (* INTERMEDIATE fact *)
  from a have c : "q" by (rule conjE)   (* INTERMEDIATE fact *)
  from b c show "p \<and> q" by (rule conjI)
qed

text\<open> Isar style, lem_j_1 again, the proof illustrates the use of nested proofs \<close>
lemma lem_j_2 : "(p \<and> q) \<longrightarrow> (p \<and> q)"
proof
  assume a : "p \<and> q"
  show "p \<and> q"
  proof (rule conjE [OF a])  (* a nested proof, i.e. a subproof *)
    (* do not omit '(rule conjE [OF a])' Isabelle is not smart enough to guess it *)
    assume b : "p"
    assume c : "q"
    from b c show "p \<and> q" by (rule conjI)
  qed
qed

text\<open> Isar style, lem_j_1 again, with the simplest possible proof \<close>
lemma lem_j_3 : "(p \<and> q) \<longrightarrow> (p \<and> q)"
proof
  assume a : "p \<and> q"
  show "p \<and> q" by (rule a)
qed

text\<open> Apply style \<close>
lemma lem_k_1 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
  apply (rule impI)
  apply (rule conjI)
  apply (erule conjE)
   apply assumption
  apply (erule conjE)
  apply assumption
  done

text\<open> Isar style, the proof illustrates the use of intermediate facts,
   once more with keywords 'from ... have ...' \<close>
lemma lem_l_1 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a have b : "p" by (rule conjE)     (* INTERMEDIATE fact *)
  from a have c : "q" by (rule conjE)     (* INTERMEDIATE fact *)
  from c b show "q \<and> p" by (rule conjI)   (* we must write 'from c b' not 'from b c' *)
qed

text\<open> Isar style, lem_l_1 again, with more abbreviations \<close>
lemma lem_l_2 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a have b : "p" ..
  from a have c : "q" ..
  from c b show "(q \<and> p)" ..
qed

text\<open> Isar style, lem_l_1 again, with nested proofs \<close>
lemma lem_l_3 : "(p \<and> q) \<longrightarrow> (q \<and> p)"
proof
  assume a : "p \<and> q"
  from a show "q \<and> p"
  proof
    assume b : "p"
    assume c : "q"
    from c b show "q \<and> p" by (rule conjI)
  qed
qed

end


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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

theorem property0 :
  "((add3 x y z) = (add3 y x z))"
  oops

end


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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

theorem property0 :
  "((add3 x y z) = (add3 z x y))"
  oops

end


theory Untyped_Set
imports Main
begin

section {* Untyped Set Theory as in TLA+ *}

subsection {* Basic Setup *}

definition unique_unsafe :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "unique_unsafe P = (if \<exists>x. P x then The P else Nitpick.unknown)"

typedef u = "UNIV :: ind set"
  by simp

typedecl \<alpha>

consts \<gamma> :: "\<alpha> \<Rightarrow> u"

nitpick_params [user_axioms, dont_box, max_potential = 0, show_all,
  atoms u = a b c d e f g h i j k l,
  atoms \<alpha> = \<alpha> \<beta> \<gamma> \<delta> \<epsilon> \<zeta> \<eta> \<theta> \<iota> \<kappa> \<mu> \<nu>]

definition ex\<alpha> :: "u \<Rightarrow> bool" where
  "ex\<alpha> x \<longleftrightarrow> (\<exists>a. \<gamma> a = x)"

subsection {* Set Membership *}

axiomatization mem :: "u \<Rightarrow> u \<Rightarrow> bool" (infix "#\<in>#" 50) where
  mem_ext: "\<And>A B. A = B \<or> (\<exists>x. \<not> (\<gamma> x #\<in># \<gamma> A \<longleftrightarrow> \<gamma> x #\<in># \<gamma> B))" and
  mem_acyclic: "\<And>A. \<not> tranclp (op #\<in>#) (\<gamma> A) (\<gamma> A)"

definition Mem :: "u \<Rightarrow> u \<Rightarrow> bool" (infix "\<in>#" 50) where
  "x \<in># A \<longleftrightarrow> unique_unsafe (\<lambda>P. (P \<longleftrightarrow> x #\<in># A) \<and> ex\<alpha> x \<and> ex\<alpha> A)"

nitpick_params [card = 1-8, format mem = 2, format Mem = 2]

lemma "\<not> x \<in># A"
  nitpick [expect = genuine]
  oops

lemma "x \<in># x"
  nitpick [expect = genuine]
  oops

lemma "\<not> x \<in># x"
  nitpick [expect = none]
  sorry

lemma "x \<in># y \<Longrightarrow> \<not> y \<in># x"
  nitpick [expect = none]
  sorry

lemma "x \<in># y \<Longrightarrow> y \<in># z \<Longrightarrow> \<not> z \<in># x"
  nitpick [expect = none]
  sorry

subsection {* Empty Set *}

definition emptyset :: u where
  "emptyset = unique_unsafe (\<lambda>A. (\<forall>a. \<not> \<gamma> a #\<in># A) \<and> ex\<alpha> A)"

lemma "\<forall>x. \<not> x \<in># emptyset"
  nitpick [satisfy, expect = genuine]
  nitpick [expect = none]
  sorry

lemma "(SOME x. \<not> x \<in># A) \<in># A"
  nitpick [expect = genuine]
  nitpick [satisfy, expect = none]
  oops

lemma "\<not> (SOME x. \<not> x \<in># A) \<in># A"
  nitpick [expect = none]
  sorry

subsection {* Subset *}

definition subseteq :: "u \<Rightarrow> u \<Rightarrow> bool" (infix "\<subseteq>#" 50) where
  "subseteq A B \<longleftrightarrow> (\<forall>x. x \<in># A \<longrightarrow> x \<in># B)"

subsection {* Functions *}

axiomatization
  dom :: "u \<Rightarrow> u" and
  app :: "u \<Rightarrow> u \<Rightarrow> u" (infixl "\<cdot>" 70)
where
  app_ext: "\<And>f g. dom f = dom g \<and> (\<forall>x. x \<in># dom f \<longrightarrow> f \<cdot> x = g \<cdot> x) \<longrightarrow> f = g"

abbreviation mapsto :: "u \<Rightarrow> (u \<Rightarrow> u) \<Rightarrow> u" where
  "mapsto A f \<equiv> unique_unsafe (\<lambda>g. dom g = A \<and> (\<forall>x. x \<in># A \<longrightarrow> g \<cdot> x = f x))"

lemma "f = mapsto (dom f) (op \<cdot> f)"
  nitpick [expect = none]
  sorry

subsection {* Powerset *}

definition
  Pow :: "u \<Rightarrow> u"
where
  "Pow B = unique_unsafe (\<lambda>C. \<forall>A. A \<in># C \<longleftrightarrow> A \<subseteq># B)"

lemma "A \<in># Pow B"
  nitpick [expect = genuine, debug] (* FIXME *)
  oops

lemma "\<not> A \<in># Pow B"
  nitpick [expect = genuine]
  oops

lemma "A \<in># Pow A"
  nitpick [expect = none]
  sorry

lemma "A \<subseteq># Pow A"
  nitpick [expect = genuine]
  oops

subsection {* Big Union *}

definition
  Union :: "u \<Rightarrow> u"
where
  "Union B = unique_unsafe (\<lambda>C. \<forall>x. x \<in># C \<longleftrightarrow> (\<exists>A. x \<in># A \<and> A \<in># B))"

lemma "A \<in># Union A"
  nitpick [expect = genuine]
  oops

lemma "\<not> A \<in># Union A"
  nitpick [expect = none]
  sorry

lemma "A = Union (Pow A)"
  nitpick [expect = none]
  sorry

end


theory Prelude_Bool_1
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize [\"Ax4\", \"Not_False\", \"Not_True\"]"

typedecl Bool

consts
notH__X :: "Bool => Bool" ("(notH/ _)" [56] 56)
X_False :: "Bool" ("False''")
X_True :: "Bool" ("True''")

instance Bool:: type ..

axioms
Not_False [rule_format] : "Not' False' = True'"

Not_True [rule_format] : "Not' True' = False'"

declare Not_False [simp]
declare Not_True [simp]

theorem Ax4 : "~ True' = False'"
by auto

ML "Header.record \"Ax4\""

end


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

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ge :: "Nat => Nat => bool" where
"ge x y = le y x"

theorem property0 :
  "((ge x y) ==> ((le x y) ==> (x = y)))"
  oops

end


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

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

theorem property0 :
  "le x x"
  oops

end


theory fol_isar
  imports Main
begin

thm allE (* \<lbrakk>\<forall>x. ?P x; ?P ?x \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
lemma "(\<exists> x. \<forall> y. x \<le> y) \<longrightarrow> (\<forall>x. \<exists> y. y \<le> x)"

lemma
  assumes "(\<exists> x. \<forall> y. x \<le> y)"
  shows "(\<forall>x. \<exists> y. y \<le> x)"
proof (rule allI)
  show "\<And>x. \<exists>y. y \<le> x" proof -
    fix x

end