theory Compiler_Utils
imports
  "HOL-Library.Monad_Syntax"
  "HOL-Library.FSet"
  "HOL-Library.Finite_Map"
begin

section \<open>Miscellaneous\<close>

notation undefined ("\<^undefined>")

lemma sum_nat_le_single:
  fixes x :: nat
  assumes y: "y \<in> S" and x: "x \<le> f y" and finite: "finite S"
  shows "x \<le> sum f S"
proof -
  have "sum f S = sum f (insert y S)"
    using y by (metis insert_absorb)
  with finite have "sum f S = f y + sum f (S - {y})"
    by (metis sum.insert_remove)
  with x show ?thesis
    by linarith
qed

lemma sum_nat_less_single:
  fixes x :: nat
  assumes y: "y \<in> S" and x: "x < f y" and finite: "finite S"
  shows "x < sum f S"
proof -
  have "sum f S = sum f (insert y S)"
    using y by (metis insert_absorb)
  with finite have "sum f S = f y + sum f (S - {y})"
    by (metis sum.insert_remove)
  with x show ?thesis
    by linarith
qed

lemma prod_BallI: "(\<And>a b. (a, b) \<in> M \<Longrightarrow> P a b) \<Longrightarrow> Ball M (\<lambda>(a, b). P a b)"
by auto

lemma fset_map_snd_id:
  assumes "\<And>a b e. (a, b) \<in> fset cs \<Longrightarrow> f a b = b"
  shows "(\<lambda>(a, b). (a, f a b)) |`| cs = cs"
proof -
  have "(\<lambda>(a, b). (a, f a b)) |`| cs = id |`| cs"
    proof (rule fset.map_cong0, safe)
      fix a b
      assume "(a, b) \<in> fset cs"
      hence "f a b = b"
        using assms by auto
      thus "(a, f a b) = id (a, b)"
        by simp
    qed
  thus ?thesis
    by simp
qed

lemmas disj_cases = disjE[case_names 1 2, consumes 1]

lemma case_prod_twice: "case_prod f (case_prod (\<lambda>a b. (g a b, h a b)) x) = case_prod (\<lambda>a b. f (g a b) (h a b)) x"
by (simp add: split_beta)

lemma map_of_map_keyed:
  "map_of (map (\<lambda>(k, v). (k, f k v)) xs) = (\<lambda>k. map_option (f k) (map_of xs k))"
  by (induction xs) (auto simp: fun_eq_iff)

locale rekey =
  fixes f :: "'a \<Rightarrow> 'b"
  assumes bij: "bij f"
begin

lemma map_of_rekey:
  "map_of (map (\<lambda>(k, v). (f k, g k v)) xs) k = map_option (g (inv f k)) (map_of xs (inv f k))"
using bij
by (induction xs) (auto simp: bij_def surj_f_inv_f)

lemma map_of_rekey': "map_of (map (map_prod f g) xs) k = map_option g (map_of xs (inv f k))"
unfolding map_prod_def
by (rule map_of_rekey)

lemma fst_distinct: "distinct (map fst xs) \<Longrightarrow> distinct (map (\<lambda>(k, _). f k) xs)"
proof (induction xs)
  case Cons
  thus ?case
    apply (auto split: prod.splits)
    using bij unfolding bij_def
    by (metis fst_conv injD rev_image_eqI)
qed auto

lemma inv: "rekey (inv f)"
apply standard
using bij
by (simp add: bij_imp_bij_inv)

end

section \<open>Finite sets\<close>

lemma fset_eq_empty_iff: "M = {||} \<longleftrightarrow> (\<forall>x. x |\<notin>| M)"
by auto

context
  includes fset.lifting
begin

lemma fbind_subset_eqI: "fBall S (\<lambda>s. f s |\<subseteq>| T) \<Longrightarrow> fbind S f |\<subseteq>| T"
by transfer' fastforce

lemma prod_fBallI: "(\<And>a b. (a, b) |\<in>| M \<Longrightarrow> P a b) \<Longrightarrow> fBall M (\<lambda>(a, b). P a b)"
by transfer (rule prod_BallI)

lemma ffUnion_subset_elem: "x |\<in>| X \<Longrightarrow> x |\<subseteq>| ffUnion X"
including fset.lifting
by transfer auto

lemma fbindE:
  assumes "x |\<in>| fbind S f"
  obtains s where "x |\<in>| f s" "s |\<in>| S"
using assms by transfer' auto

lemma ffUnion_least_rev: "ffUnion A |\<subseteq>| C \<Longrightarrow> fBall A (\<lambda>X. X |\<subseteq>| C)"
by transfer blast

lemma inj_on_fimage_set_diff:
  assumes "inj_on f (fset C)" "A |\<subseteq>| C" "B |\<subseteq>| C"
  shows "f |`| (A - B) = f |`| A - f |`| B"
using assms
by transfer (meson Diff_subset inj_on_image_set_diff order_trans)

lemma list_all_iff_fset: "list_all P xs \<longleftrightarrow> fBall (fset_of_list xs) P"
by transfer (rule list_all_iff)

lemma fbind_fun_funion: "fbind M (\<lambda>x. f x |\<union>| g x) = fbind M f |\<union>| fbind M g"
by transfer' auto

end

lemma funion_strictE:
  assumes "c |\<in>| A |\<union>| B"
  obtains (A) "c |\<in>| A" | (B) "c |\<notin>| A" "c |\<in>| B"
using assms by auto

lemma max_decr:
  fixes X :: "nat set"
  assumes "\<exists>x \<in> X. x \<ge> k" "finite X"
  shows "Max ((\<lambda>x. x - k) ` X) = Max X - k"
proof (rule mono_Max_commute[symmetric])
  show "mono (\<lambda>x. x - k)"
    by (rule monoI) linarith
  show "finite X"
    by fact
  show "X \<noteq> {}"
    using assms by auto
qed

lemma max_ex_gr: "\<exists>x \<in> X. k < x \<Longrightarrow> finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> k < Max X"
by (simp add: Max_gr_iff)

context includes fset.lifting begin

lemma fmax_decr:
  fixes X :: "nat fset"
  assumes "fBex X (\<lambda>x. x \<ge> k)"
  shows "fMax ((\<lambda>x. x - k) |`| X) = fMax X - k"
using assms by transfer (rule max_decr)

lemma fmax_ex_gr: "fBex X (\<lambda>x. k < x) \<Longrightarrow> X \<noteq> {||} \<Longrightarrow> k < fMax X"
by transfer (rule max_ex_gr)

lemma fMax_le: "fBall M (\<lambda>x. x \<le> k) \<Longrightarrow> M \<noteq> {||} \<Longrightarrow> fMax M \<le> k"
by transfer auto

end

section \<open>Sets\<close>

subsection \<open>Code setup trickery\<close>

definition compress :: "'a set \<Rightarrow> 'a set" where
"compress = id"

definition the_elem' :: "'a::linorder set \<Rightarrow> 'a" where
"the_elem' S = the_elem (set (sorted_list_of_set S))"

lemma the_elem_id: "finite S \<Longrightarrow> the_elem' S = the_elem S"
unfolding the_elem'_def
by auto

context
  includes fset.lifting
begin

lift_definition fcompress :: "'a fset \<Rightarrow> 'a fset" is compress
unfolding compress_def by simp

lemma fcompress_eq[simp]: "fcompress M = M"
by transfer' (auto simp: compress_def)

lift_definition fthe_elem' :: "'a::linorder fset \<Rightarrow> 'a" is the_elem' .

lemma fthe_elem'_eq: "fthe_elem' = fthe_elem"
proof
  fix S :: "'a fset"
  show "fthe_elem' S = fthe_elem S"
    by transfer (fastforce intro: the_elem_id)
qed

end

subsection \<open>@{type set}s as maps\<close>

definition is_map :: "('a \<times> 'b) set \<Rightarrow> bool" where
"is_map M = Ball M (\<lambda>(a\<^sub>1, b\<^sub>1). Ball M (\<lambda>(a\<^sub>2, b\<^sub>2). a\<^sub>1 = a\<^sub>2 \<longrightarrow> b\<^sub>1 = b\<^sub>2))"

lemma is_mapI[intro]:
  assumes "\<And>a b\<^sub>1 b\<^sub>2. (a, b\<^sub>1) \<in> M \<Longrightarrow> (a, b\<^sub>2) \<in> M \<Longrightarrow> b\<^sub>1 = b\<^sub>2"
  shows "is_map M"
using assms unfolding is_map_def by auto

lemma distinct_is_map:
  assumes "distinct (map fst m)"
  shows "is_map (set m)"
using assms
by (metis Some_eq_map_of_iff is_mapI option.inject)

lemma is_map_image:
  assumes "is_map M"
  shows "is_map ((\<lambda>(a, b). (a, f a b)) ` M)"
using assms unfolding is_map_def by auto

lemma is_mapD:
  assumes "is_map M" "(a, b\<^sub>1) \<in> M" "(a, b\<^sub>2) \<in> M"
  shows "b\<^sub>1 = b\<^sub>2"
using assms unfolding is_map_def by auto

lemma is_map_subset: "is_map N \<Longrightarrow> M \<subseteq> N \<Longrightarrow> is_map M"
unfolding is_map_def by blast

lemma map_of_is_map: "(k, v) \<in> set m \<Longrightarrow> is_map (set m) \<Longrightarrow> map_of m k = Some v"
by (metis is_mapD map_of_SomeD weak_map_of_SomeI)

definition get_map :: "('a \<times> 'b) set \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'b)" where
"get_map M k = the_elem (Set.filter (\<lambda>(k', _). k = k') M)"

lemma get_map_elem:
  assumes "is_map M"
  assumes "(k, v) \<in> M"
  shows "get_map M k = (k, v)"
proof -
  from assms have "Set.filter (\<lambda>(k', _). k = k') M = {(k, v)}"
    unfolding is_map_def by fastforce
  thus ?thesis
    unfolding get_map_def by simp
qed

lemma get_map_map:
  assumes "is_map S" "k \<in> fst ` S"
  shows "get_map ((\<lambda>(a, b). (a, f a b)) ` S) k = (case get_map S k of (a, b) \<Rightarrow> (a, f a b))"
proof -
  from assms obtain v where "(k, v) \<in> S"
    by force
  hence "get_map S k = (k, v)"
    using assms by (simp add: get_map_elem)

  have "(k, f k v) \<in> (\<lambda>(a, b). (a, f a b)) ` S"
    using \<open>(k, v) \<in> S\<close> by auto
  hence "get_map ((\<lambda>(a, b). (a, f a b)) ` S) k = (k, f k v)"
    using assms by (metis get_map_elem is_map_image) (* takes long *)

  show ?thesis
    unfolding \<open>get_map S k = _\<close> \<open>get_map (_ ` S) k = _\<close>
    by simp
qed

lemma is_map_fst_inj: "is_map S \<Longrightarrow> inj_on fst S"
by (fastforce intro: inj_onI dest: is_mapD)

context
  includes fset.lifting
begin

lemma is_map_transfer:
  fixes A :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes [transfer_rule]: "bi_unique A"
  shows "rel_fun (rel_set (rel_prod (=) A)) (=) is_map is_map"
unfolding is_map_def[abs_def]
by transfer_prover

lift_definition is_fmap :: "('a \<times> 'b) fset \<Rightarrow> bool" is is_map parametric is_map_transfer .

lemma is_fmapI[intro]:
  assumes "\<And>a b\<^sub>1 b\<^sub>2. (a, b\<^sub>1) |\<in>| M \<Longrightarrow> (a, b\<^sub>2) |\<in>| M \<Longrightarrow> b\<^sub>1 = b\<^sub>2"
  shows "is_fmap M"
using assms by transfer' auto

lemma is_fmap_image: "is_fmap M \<Longrightarrow> is_fmap ((\<lambda>(a, b). (a, f a b)) |`| M)"
by transfer' (rule is_map_image)

lemma is_fmapD:
  assumes "is_fmap M" "(a, b\<^sub>1) |\<in>| M" "(a, b\<^sub>2) |\<in>| M"
  shows "b\<^sub>1 = b\<^sub>2"
using assms by transfer' (rule is_mapD)

end

subsection \<open>Conversion into sorted lists\<close>

definition ordered_map :: "('a::linorder \<times> 'b) set \<Rightarrow> ('a \<times> 'b) list" where
"ordered_map S = map (get_map S) (sorted_list_of_set (fst ` S))"

lemma ordered_map_set_eq:
  assumes "finite S" "is_map S"
  shows "set (ordered_map S) = S"
proof -
  have "set (ordered_map S) = get_map S ` set (sorted_list_of_set (fst ` S))"
    unfolding ordered_map_def by simp
  also have "\<dots> = get_map S ` (fst ` S)"
    using assms by (auto simp: sorted_list_of_set)
  also have "\<dots> = (get_map S \<circ> fst) ` S"
    unfolding o_def by auto
  also have "\<dots> = id ` S"
    using assms
    by (force simp: get_map_elem)
  finally show ?thesis
    by simp
qed

lemma ordered_map_image:
  assumes "finite S" "is_map S"
  shows "map (\<lambda>(a, b). (a, f a b)) (ordered_map S) = ordered_map ((\<lambda>(a, b). (a, f a b)) ` S)"
using assms
unfolding ordered_map_def list.map_comp image_comp
by (auto simp: fst_def[abs_def] comp_def case_prod_twice get_map_map)

lemma ordered_map_distinct:
  assumes "finite S" "is_map S"
  shows "distinct (map fst (ordered_map S))"
proof -
  have "inj_on (fst \<circ> get_map S) (set (sorted_list_of_set (fst ` S)))"
    apply rule
    using sorted_list_of_set assms(1)
    apply simp
    apply (erule imageE)
    apply (erule imageE)
    subgoal for x y x' y'
      apply (cases x', cases y')
      apply simp
      apply (subst (asm) get_map_elem)
        apply (rule assms)
       apply assumption
      apply (subst (asm) get_map_elem)
        apply (rule assms)
       apply assumption
      apply simp
      done
    done
  then show ?thesis
    unfolding ordered_map_def
    by (auto intro: distinct_sorted_list_of_set simp: distinct_map)
qed

lemma ordered_map_keys:
  assumes "finite S" "is_map S"
  shows "map fst (ordered_map S) = sorted_list_of_set (fst ` S)"
proof -
  have "fst (get_map S z) = z" if "z \<in> fst ` S" for z
    using assms that by (fastforce simp: get_map_elem)
  moreover have "set (sorted_list_of_set (fst ` S)) = fst ` S"
    using assms by (force simp: sorted_list_of_set)
  ultimately show ?thesis
    unfolding ordered_map_def
    by (metis (no_types, lifting) map_idI map_map o_apply)
qed

corollary ordered_map_sound:
  assumes "is_map S" "finite S" "(a, b) \<in> set (ordered_map S)"
  shows "(a, b) \<in> S"
using assms by (metis ordered_map_set_eq)

lemma ordered_map_nonempty:
  assumes "is_map S" "ordered_map S \<noteq> []" "finite S"
  shows "S \<noteq> {}"
using assms unfolding ordered_map_def by auto

lemma ordered_map_remove:
  assumes "is_map S" "finite S" "x \<in> S"
  shows "ordered_map (S - {x}) = remove1 x (ordered_map S)"
proof -
  have distinct: "distinct (sorted_list_of_set (fst ` S))"
    using assms
    by (fastforce simp: sorted_list_of_set)

  have "inj_on (get_map S) (fst ` S)"
    using assms
    by (fastforce simp: get_map_elem intro: inj_onI)

  hence inj: "inj_on (get_map S) (set (sorted_list_of_set (fst ` S)))"
    using assms
    by (simp add: sorted_list_of_set)

  have "ordered_map (S - {x}) = map (get_map (S - {x})) (sorted_list_of_set (fst ` (S - {x})))"
    unfolding ordered_map_def by simp
  also have "\<dots> = map (get_map (S - {x})) (sorted_list_of_set (fst ` S - {fst x}))"
    proof (subst inj_on_image_set_diff)
      show "inj_on fst S"
        by (rule is_map_fst_inj) fact
    next
      show "{x} \<subseteq> S"
        using assms by simp
    qed auto
  also have "\<dots> = map (get_map (S - {x})) (remove1 (fst x) (sorted_list_of_set (fst ` S)))"
    proof (subst sorted_list_of_set_remove)
      show "finite (fst ` S)"
        using assms by simp
    qed simp
  also have "\<dots> = map (get_map S) (remove1 (fst x) (sorted_list_of_set (fst ` S)))"
    proof (rule list.map_cong0)
      fix z
      assume "z \<in> set (remove1 (fst x) (sorted_list_of_set (fst ` S)))"
      with distinct have "z \<noteq> fst x"
        by simp
      thus "get_map (S - {x}) z = get_map S z"
        unfolding get_map_def Set.filter_def
        by (metis (full_types, lifting) case_prodE fst_conv member_remove remove_def)
    qed
  also have "\<dots> = map (get_map S) (removeAll (fst x) (sorted_list_of_set (fst ` S)))"
    using distinct
    by (auto simp: distinct_remove1_removeAll)
  also have "\<dots> = removeAll (get_map S (fst x)) (map (get_map S) (sorted_list_of_set (fst ` S)))"
    proof (subst map_removeAll_inj_on)
      have "fst x \<in> set (sorted_list_of_set (fst ` S))"
        using assms by (fastforce simp: sorted_list_of_set)
      hence "insert (fst x) (set (sorted_list_of_set (fst ` S))) = set (sorted_list_of_set (fst ` S))"
        by auto
      with inj show "inj_on (get_map S) (insert (fst x) (set (sorted_list_of_set (fst ` S))))"
        by auto
    qed simp
  also have "\<dots> = removeAll x (map (get_map S) (sorted_list_of_set (fst ` S)))"
    using assms by (auto simp: get_map_elem[where v = "snd x"])
  also have "\<dots> = remove1 x (map (get_map S) (sorted_list_of_set (fst ` S)))"
    using distinct inj
    by (simp add: distinct_remove1_removeAll distinct_map)
  finally show ?thesis
    unfolding ordered_map_def .
qed

lemma ordered_map_list_all:
  assumes "finite S" "is_map S"
  shows "list_all P (ordered_map S) = Ball S P"
unfolding list_all_iff
using assms by (simp add: ordered_map_set_eq)

lemma ordered_map_singleton[simp]: "ordered_map {(x, y)} = [(x, y)]"
unfolding ordered_map_def get_map_def Set.filter_def the_elem_def
by auto

context
  includes fset.lifting
begin

lift_definition ordered_fmap :: "('a::linorder \<times> 'b) fset \<Rightarrow> ('a \<times> 'b) list" is ordered_map .

lemma ordered_fmap_set_eq: "is_fmap S \<Longrightarrow> fset_of_list (ordered_fmap S) = S"
by transfer (rule ordered_map_set_eq)

lemma ordered_fmap_image:
  assumes "is_fmap S"
  shows "map (\<lambda>(a, b). (a, f a b)) (ordered_fmap S) = ordered_fmap ((\<lambda>(a, b). (a, f a b)) |`| S)"
using assms by transfer (rule ordered_map_image)

lemma ordered_fmap_distinct:
  assumes "is_fmap S"
  shows "distinct (map fst (ordered_fmap S))"
using assms
by transfer (rule ordered_map_distinct)

lemma ordered_fmap_keys:
  assumes "is_fmap S"
  shows "map fst (ordered_fmap S) = sorted_list_of_fset (fst |`| S)"
using assms
by transfer (rule ordered_map_keys)

lemma ordered_fmap_sound:
  assumes "is_fmap S" "(a, b) \<in> set (ordered_fmap S)"
  shows "(a, b) |\<in>| S"
using assms by transfer (rule ordered_map_sound)

lemma ordered_fmap_nonempty:
  assumes "is_fmap S" "ordered_fmap S \<noteq> []"
  shows "S \<noteq> {||}"
using assms by transfer (rule ordered_map_nonempty)

lemma ordered_fmap_remove:
  assumes "is_fmap S" "x |\<in>| S"
  shows "ordered_fmap (S - {| x |}) = remove1 x (ordered_fmap S)"
using assms by transfer (rule ordered_map_remove)

lemma ordered_fmap_list_all:
  assumes "is_fmap S"
  shows "list_all P (ordered_fmap S) = fBall S P"
unfolding list_all_iff
using assms by transfer (simp add: ordered_map_set_eq)

lemma ordered_fmap_singleton[simp]: "ordered_fmap {| (x, y) |} = [(x, y)]"
by transfer' simp

end

subsection \<open>Grouping into sets\<close>

definition group_by :: "('a \<Rightarrow> ('b \<times> 'c)) \<Rightarrow> 'a set \<Rightarrow> ('b \<times> 'c set) set" where
"group_by f s = {(fst (f a), {snd (f a')| a'. a' \<in> s \<and> fst (f a) = fst (f a') }) |a. a \<in> s}"

lemma group_by_nonempty: "M \<noteq> {} \<Longrightarrow> group_by f M \<noteq> {}"
unfolding group_by_def by blast

lemma group_by_nonempty_inner:
  assumes "(b, cs) \<in> group_by f as"
  obtains c where "c \<in> cs"
using assms unfolding group_by_def by blast

lemma group_byD: "(b, cs) \<in> group_by f as \<Longrightarrow> f a = (b, c) \<Longrightarrow> a \<in> as \<Longrightarrow> c \<in> cs"
unfolding group_by_def by force

lemma group_byE[elim]:
  assumes "c \<in> cs" "(b, cs) \<in> group_by f as"
  obtains a where "a \<in> as" "f a = (b, c)"
using assms by (metis group_by_sound)

lemma group_byE2:
  assumes "(b, cs) \<in> group_by f as"
  obtains a where "a \<in> as" "fst (f a) = b"
using assms
by (metis group_byE group_by_nonempty_inner prod.sel(1))

lemma group_by_complete:
  assumes "a \<in> as"
  obtains cs where "(fst (f a), cs) \<in> group_by f as" "snd (f a) \<in> cs"
using assms unfolding group_by_def by auto

definition group_by' :: "('a \<Rightarrow> ('b \<times> 'c)) \<Rightarrow> 'a set \<Rightarrow> ('b \<times> 'c set) set" where
"group_by' f s = (\<lambda>a. let (fa, _) = f a in (fa, (snd \<circ> f) ` Set.filter (\<lambda>a'. fa = fst (f a')) s)) ` s"

lemma group_by'_eq[code, code_unfold]: "group_by = group_by'"
apply (rule ext)+
unfolding group_by_def group_by'_def Set.filter_def
by (auto simp: Let_def split_beta)

lemma is_map_group_by[intro]: "is_map (group_by f M)"
unfolding group_by_def by force

lemma group_by_keys[simp]: "fst ` group_by f M = fst ` f ` M"
unfolding group_by_def by force

context
  includes fset.lifting
begin

lift_definition fgroup_by :: "('a \<Rightarrow> ('b \<times> 'c)) \<Rightarrow> 'a fset \<Rightarrow> ('b \<times> 'c fset) fset" is group_by
unfolding inf_apply inf_bool_def group_by_def by auto

lemma fgroup_by_nonempty: "M \<noteq> {||} \<Longrightarrow> fgroup_by f M \<noteq> {||}"
by transfer' (rule group_by_nonempty)

lemma fgroup_by_nonempty_inner:
  assumes "(b, cs) |\<in>| fgroup_by f as"
  obtains c where "c |\<in>| cs"
using assms by transfer' (rule group_by_nonempty_inner)

lemma fgroup_by_sound: "c |\<in>| cs \<Longrightarrow> (b, cs) |\<in>| fgroup_by f as \<Longrightarrow> fBex as (\<lambda>a. f a = (b, c))"
by transfer (metis group_by_sound)

lemma fgroup_byD: "(b, cs) |\<in>| fgroup_by f as \<Longrightarrow> f a = (b, c) \<Longrightarrow> a |\<in>| as \<Longrightarrow> c |\<in>| cs"
by transfer' (metis group_byD)

lemma fgroup_byE2:
  assumes "(b, cs) |\<in>| fgroup_by f as"
  obtains a where "a |\<in>| as" "fst (f a) = b"
using assms by transfer' (rule group_byE2)

lemma fgroup_by_complete:
  assumes "a |\<in>| as"
  obtains cs where "(fst (f a), cs) |\<in>| fgroup_by f as" "snd (f a) |\<in>| cs"
using assms proof (transfer)
  fix a :: 'a and as :: "'a set"
  fix f :: "'a \<Rightarrow> ('c \<times> 'b)"
  fix thesis

  assume as: "finite as"
  assume "a \<in> as"
  then obtain cs where cs: "(fst (f a), cs) \<in> group_by f as" "snd (f a) \<in> cs"
    by (metis group_by_complete)
  hence "finite cs"
    unfolding group_by_def using as by force

  assume thesis: "\<And>cs. finite cs \<Longrightarrow> (fst (f a), cs) \<in> group_by f as \<Longrightarrow> snd (f a) \<in> cs \<Longrightarrow> thesis"
  show thesis
    by (rule thesis) fact+
qed

lemma fgroup_by_single: "(a, x) |\<in>| fgroup_by f s \<Longrightarrow> (a, y) |\<in>| fgroup_by f s \<Longrightarrow> x = y"
by transfer (metis group_by_single)

definition fgroup_by' :: "('a \<Rightarrow> ('b \<times> 'c)) \<Rightarrow> 'a fset \<Rightarrow> ('b \<times> 'c fset) fset" where
"fgroup_by' f s = fcompress ((\<lambda>a. let (fa, _) = f a in (fa, (snd \<circ> f) |`| ffilter (\<lambda>a'. fa = fst (f a')) s)) |`| s)"

lemma fgroup_by'_eq[code, code_unfold]: "fgroup_by = fgroup_by'"
unfolding fgroup_by'_def[abs_def] fcompress_eq
by transfer' (metis group_by'_def group_by'_eq)

lemma is_fmap_group_by[intro]: "is_fmap (fgroup_by f M)"
by transfer' (rule is_map_group_by)

lemma fgroup_by_keys[simp]: "fst |`| fgroup_by f M = fst |`| f |`| M"
by transfer' (rule group_by_keys)

end

subsection \<open>Singletons\<close>

lemma singleton_set_holds:
  assumes "\<forall>x \<in> M. \<forall>y \<in> M. f x = f y" "m \<in> M"
  shows "f m = the_elem (f ` M)"
proof -
  let ?n = "the_elem (f ` M)"
  have "f ` M = {f m}"
    using assms(1) assms(2) by blast
  hence "?n = (THE n. {f m} = {n})"
    unfolding the_elem_def by simp
  thus ?thesis by auto
qed

lemma singleton_set_is:
  assumes "\<forall>x \<in> M. x = y" "M \<noteq> {}"
  shows "M = {y}"
using assms by auto

context
  includes fset.lifting
begin

lemma singleton_fset_holds:
  assumes "fBall M (\<lambda>x. fBall M (\<lambda>y. f x = f y))" "m |\<in>| M"
  shows "f m = fthe_elem (f |`| M)"
using assms
by transfer (rule singleton_set_holds)

lemma singleton_fset_is:
  assumes "fBall M (\<lambda>x. x = y)" "M \<noteq> {||}"
  shows "M = {| y |}"
using assms by transfer' (rule singleton_set_is)

end

subsection \<open>Pairwise relations\<close>

definition pairwise :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
"pairwise P M \<longleftrightarrow> (\<forall>m \<in> M. \<forall>n \<in> M. P m n)"

lemma pairwiseI[intro!]:
  assumes "\<And>m n. m \<in> M \<Longrightarrow> n \<in> M \<Longrightarrow> P m n"
  shows "pairwise P M"
using assms unfolding pairwise_def by simp

lemma pairwiseD[dest]:
  assumes "pairwise P M" "m \<in> M" "n \<in> M"
  shows "P m n"
using assms unfolding pairwise_def by simp

lemma pairwise_subset: "pairwise P M \<Longrightarrow> N \<subseteq> M \<Longrightarrow> pairwise P N"
unfolding pairwise_def by blast

lemma pairwise_weaken: "pairwise P M \<Longrightarrow> (\<And>x y. x \<in> M \<Longrightarrow> y \<in> M \<Longrightarrow> P x y \<Longrightarrow> Q x y) \<Longrightarrow> pairwise Q M"
by auto

lemma pairwise_image[simp]: "pairwise P (f ` M) = pairwise (\<lambda>x y. P (f x) (f y)) M"
by auto

context
  includes fset.lifting
begin

lift_definition fpairwise :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> bool" is pairwise .

lemma fpairwise_alt_def[code]: "fpairwise P M \<longleftrightarrow> fBall M (\<lambda>m. fBall M (\<lambda>n. P m n))"
by transfer' auto

lemma fpairwiseI[intro!]:
  assumes "\<And>m n. m |\<in>| M \<Longrightarrow> n |\<in>| M \<Longrightarrow> P m n"
  shows "fpairwise P M"
using assms unfolding fpairwise_alt_def by blast

lemma fpairwiseD:
  assumes "fpairwise P M" "m |\<in>| M" "n |\<in>| M"
  shows "P m n"
  using assms unfolding fpairwise_alt_def by auto

lemma fpairwise_image[simp]: "fpairwise P (f |`| M) = fpairwise (\<lambda>x y. P (f x) (f y)) M"
by (auto dest: fpairwiseD)

end

lemma fpairwise_subset: "fpairwise P M \<Longrightarrow> N |\<subseteq>| M \<Longrightarrow> fpairwise P N"
unfolding fpairwise_alt_def by auto

lemma fpairwise_weaken: "fpairwise P M \<Longrightarrow> (\<And>x y. x |\<in>| M \<Longrightarrow> y |\<in>| M \<Longrightarrow> P x y \<Longrightarrow> Q x y) \<Longrightarrow> fpairwise Q M"
unfolding fpairwise_alt_def by auto

subsection \<open>Relators\<close>

lemma rel_set_eq_eq: "rel_set (=) A B \<Longrightarrow> A = B"
unfolding rel_set_def by fast

lemma rel_set_image:
  assumes "rel_set P A B"
  assumes "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> P a b \<Longrightarrow> Q (f a) (g b)"
  shows "rel_set Q (f ` A) (g ` B)"
using assms
by (force intro!: rel_setI dest: rel_setD1 rel_setD2)

corollary rel_set_image_eq:
  assumes "rel_set P A B"
  assumes "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> P a b \<Longrightarrow> f a = g b"
  shows "f ` A = g ` B"
proof -
  have "rel_set (=) (f ` A) (g ` B)"
    by (rule rel_set_image) fact+
  thus ?thesis
    by (rule rel_set_eq_eq)
qed

lemma rel_set_refl_strong[intro]:
  assumes "\<And>x. x \<in> S \<Longrightarrow> P x x"
  shows "rel_set P S S"
proof (rule rel_setI)
  fix x
  assume "x \<in> S"
  thus "\<exists>y \<in> S. P x y"
    using assms by blast
next
  fix y
  assume "y \<in> S"
  thus "\<exists>x \<in> S. P x y"
    using assms by blast
qed

context
  includes fset.lifting
begin

lemma rel_fsetE1:
  assumes "rel_fset P M N" "x |\<in>| M"
  obtains y where "y |\<in>| N" "P x y"
using assms by transfer' (auto dest: rel_setD1)

lemma rel_fsetE2:
  assumes "rel_fset P M N" "y |\<in>| N"
  obtains x where "x |\<in>| M" "P x y"
using assms by transfer' (auto dest: rel_setD2)

lemma rel_fsetI:
  assumes "\<And>x. x |\<in>| A \<Longrightarrow> fBex B (R x)" "\<And>y. y |\<in>| B \<Longrightarrow> fBex A (\<lambda>x. R x y)"
  shows "rel_fset R A B"
using assms by transfer' (rule rel_setI)

lemma rel_fset_image:
  assumes "rel_fset P A B"
  assumes "\<And>a b. a |\<in>| A \<Longrightarrow> b |\<in>| B \<Longrightarrow> P a b \<Longrightarrow> Q (f a) (g b)"
  shows "rel_fset Q (f |`| A) (g |`| B)"
using assms by transfer' (rule rel_set_image)

corollary rel_fset_image_eq:
  assumes "rel_fset P A B"
  assumes "\<And>a b. a |\<in>| A \<Longrightarrow> b |\<in>| B \<Longrightarrow> P a b \<Longrightarrow> f a = g b"
  shows "f |`| A = g |`| B"
using assms by transfer' (rule rel_set_image_eq)

lemma rel_fset_refl_strong:
  assumes "\<And>x. x |\<in>| S \<Longrightarrow> P x x"
  shows "rel_fset P S S"
using assms
by transfer' (rule rel_set_refl_strong)

end

subsection \<open>Selecting values from keys\<close>

definition select :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"select f S = {z|z. \<exists>x \<in> S. f x = Some z}"

lemma select_finite:
  assumes "finite S"
  shows "finite (select f S)"
proof -
  have "finite (f ` S)"
    using assms by simp
  moreover have "Some ` (select f S) \<subseteq> f ` S"
    unfolding select_def by force
  ultimately have "finite (Some ` select f S)"
    by (rule rev_finite_subset)
  moreover have "\<And>S. inj_on Some S"
    by simp
  ultimately show ?thesis
    by (rule finite_imageD)
qed

lemma select_memberI: "x \<in> S \<Longrightarrow> f x = Some y \<Longrightarrow> y \<in> select f S"
unfolding select_def by blast

lemma select_memberE:
  assumes "y \<in> select f S"
  obtains x where "x \<in> S" "f x = Some y"
using assms unfolding select_def by blast

context
  includes fset.lifting
begin

lift_definition fselect :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a fset \<Rightarrow> 'b fset" is select
by (rule select_finite)

lemma fselect_memberI[intro]: "x |\<in>| S \<Longrightarrow> f x = Some y \<Longrightarrow> y |\<in>| fselect f S"
by transfer' (rule select_memberI)

lemma fselect_memberE[elim]:
  assumes "y |\<in>| fselect f S"
  obtains x where "x |\<in>| S" "f x = Some y"
using assms by transfer' (rule select_memberE)

end

subsection \<open>Miscellaneous\<close>

lemma set_of_list_singletonE:
  assumes "set xs = {x}" "distinct xs"
  shows "xs = [x]"
using assms
by (metis distinct.simps(2) empty_iff insertI1 insert_ident list.simps(15) neq_Nil_conv set_empty2 singletonD)

lemma fset_of_list_singletonE:
  assumes "fset_of_list xs = {|x|}" "distinct xs"
  shows "xs = [x]"
including fset.lifting
  using assms by transfer (rule set_of_list_singletonE)

section \<open>Finite maps\<close>

definition fmlookup_default :: "('a, 'b) fmap \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
"fmlookup_default m f x = (case fmlookup m x of None \<Rightarrow> f x | Some b \<Rightarrow> b)"

lemma fmpred_foldl[intro]:
  assumes "fmpred P init" "\<And>x. x \<in> set xs \<Longrightarrow> fmpred P x"
  shows "fmpred P (foldl (++\<^sub>f) init xs)"
using assms proof (induction xs arbitrary: init)
  case (Cons x xs)
  have "fmpred P (foldl (++\<^sub>f) (init ++\<^sub>f x) xs)"
    proof (rule Cons)
      show "fmpred P (init ++\<^sub>f x)"
        using Cons by auto
    next
      fix x
      assume "x \<in> set xs"
      thus "fmpred P x"
        using Cons by auto
    qed
  thus ?case
    by simp
qed auto

lemma fmdom_foldl_add: "fmdom (foldl (++\<^sub>f) m ns) = fmdom m |\<union>| ffUnion (fmdom |`| fset_of_list ns)"
by (induction ns arbitrary: m) auto

lemma fmimage_fmmap[simp]: "fmimage (fmmap f m) S = f |`| fmimage m S"
including fmap.lifting fset.lifting
by transfer' auto

lemma fmmap_total:
  assumes "\<And>k v. fmlookup m k = Some v \<Longrightarrow> (\<exists>v'. f v' = v)"
  obtains m' where "m = fmmap f m'"
apply (rule that[of "fmmap (inv f) m"])
unfolding fmap.map_comp
apply (subst fmap.map_id[symmetric])
apply (rule fmap.map_cong)
apply (auto simp: fmran'_def f_inv_into_f dest!: assms)
done

lemma set_of_map_upd: "set_of_map (map_upd k v m) = set_of_map (map_drop k m) \<union> {(k, v)}"
unfolding set_of_map_def map_upd_def map_drop_def map_filter_def
by (auto split: if_splits)

lemma map_drop_delete: "map_drop k (map_of ps) = map_of (AList.delete k ps)"
unfolding AList.delete_eq map_drop_def
apply (subst map_filter_map_of)
apply (rule arg_cong[where f = "map_of"])
apply (rule filter_cong[OF refl])
by auto

lemma set_of_map_map_of: "set_of_map (map_of xs) = set (AList.clearjunk xs)"
proof (induction xs rule: clearjunk.induct)
  case (2 p ps)

  (* honourable mention: int-e on IRC, but it's way to short to understand what's going on *)
  have ?case by (simp add: 2[symmetric] delete_conv) (auto simp: set_of_map_def)

  obtain k v where "p = (k, v)"
    by (cases p) auto
  have "set_of_map (map_of (p # ps)) = set_of_map (map_upd k v (map_of ps))"
    unfolding \<open>p = _\<close> map_upd_def by simp
  also have "\<dots> = set_of_map (map_drop k (map_of ps)) \<union> {(k, v)}"
    by (rule set_of_map_upd)
  also have "\<dots> = set_of_map (map_of (AList.delete k ps)) \<union> {(k, v)}"
    by (simp only: map_drop_delete)
  also have "\<dots> =  set (AList.clearjunk (AList.delete k ps)) \<union> {(k, v)}"
    using 2 unfolding \<open>p = _\<close> by simp
  also have "\<dots> = set (AList.clearjunk (p # ps))"
    unfolding \<open>p = _\<close> by simp
  finally show ?case .
qed (simp add: set_of_map_def)

lemma fset_of_fmap_code[code]: "fset_of_fmap (fmap_of_list x) = fset_of_list (AList.clearjunk x)"
including fmap.lifting fset.lifting
  by transfer (rule set_of_map_map_of)

lemma distinct_sorted_list_of_fmap[simp, intro]: "distinct (sorted_list_of_fmap m)"
unfolding sorted_list_of_fmap_def
apply (subst distinct_map)
apply rule
subgoal by simp
subgoal by (rule inj_on_convol_ident)
done

section \<open>Lists\<close>

lemma rev_induct2[consumes 1, case_names nil snoc]:
  assumes "length xs = length ys"
  assumes "P [] []"
  assumes "\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (xs @ [x]) (ys @ [y])"
  shows "P xs ys"
proof -
  have "length (rev xs) = length (rev ys)"
    using assms by simp
  hence "P (rev (rev xs)) (rev (rev ys))"
    using assms by (induct rule: list_induct2) auto
  thus ?thesis
    by simp
qed

lemma list_allI[intro]:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> P x"
  shows "list_all P xs"
using assms unfolding list_all_iff by auto

lemma list_map_snd_id:
  assumes "\<And>a b e. (a, b) \<in> set cs \<Longrightarrow> f a b = b"
  shows "map (\<lambda>(a, b). (a, f a b)) cs = cs"
proof -
  have "map (\<lambda>(a, b). (a, f a b)) cs = map id cs"
    proof (rule list.map_cong0, safe)
      fix a b
      assume "(a, b) \<in> set cs"
      hence "f a b = b"
        using assms by auto
      thus "(a, f a b) = id (a, b)"
        by simp
    qed
  thus ?thesis
    by simp
qed

lemma list_all2_leftE:
  assumes "list_all2 P xs ys" "x \<in> set xs"
  obtains y where "y \<in> set ys" "P x y"
using assms by induct auto

lemma list_all2_rightE:
  assumes "list_all2 P xs ys" "y \<in> set ys"
  obtains x where "x \<in> set xs" "P x y"
using assms by induct auto

fun list_all3 where
"list_all3 P (x # xs) (y # ys) (z # zs) \<longleftrightarrow> P x y z \<and> list_all3 P xs ys zs" |
"list_all3 P [] [] [] \<longleftrightarrow> True" |
"list_all3 _ _ _ _ \<longleftrightarrow> False"

lemma list_all3_empty[intro]: "list_all3 P [] [] []"
by simp

lemma list_all3_cons[intro]: "list_all3 P xs ys zs \<Longrightarrow> P x y z \<Longrightarrow> list_all3 P (x # xs) (y # ys) (z # zs)"
by simp

lemma list_all3_induct[consumes 1, case_names Nil Cons, induct set: list_all3]:
  assumes P: "list_all3 P xs ys zs"
  assumes Nil: "Q [] [] []"
  assumes Cons: "\<And>x xs y ys z zs.
    P x y z \<Longrightarrow> Q xs ys zs \<Longrightarrow> list_all3 P xs ys zs \<Longrightarrow> Q (x # xs) (y # ys) (z # zs)"
  shows "Q xs ys zs"
using P
proof (induction P\<equiv>P xs ys zs rule: list_all3.induct, goal_cases cons)
  show "Q [] [] []" by fact
next
  case (cons x xs y ys z zs)
  thus ?case
    using Cons by auto
qed auto

lemma list_all3_from_list_all2s:
  assumes "list_all2 P xs ys" "list_all2 Q xs zs"
  assumes "\<And>x y z. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> z \<in> set zs \<Longrightarrow> P x y \<Longrightarrow> Q x z \<Longrightarrow> R x y z"
  shows "list_all3 R xs ys zs"
using assms proof (induction arbitrary: zs)
  case Nil
  hence "zs = []" by blast
  thus ?case by simp
next
  case (Cons x y xs ys zs0)
  then obtain z zs where "zs0 = z # zs" by (cases zs0) auto
  show ?case
    using Cons unfolding \<open>zs0 = _\<close>
    by auto
qed

lemma those_someD:
  assumes "those xs = Some ys"
  shows "xs = map Some ys"
using assms by (induction xs arbitrary: ys) (auto split: if_splits option.splits)

end


(*  File:       Revision_Composition.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Revision Composition\<close>

theory Revision_Composition
  imports "Basic_Modules/Component_Types/Electoral_Module"
begin

text
\<open>A revised electoral module rejects all originally rejected or deferred
alternatives, and defers the originally elected alternatives.
It does not elect any alternatives.\<close>

subsection \<open>Definition\<close>

fun revision_composition :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module" where
  "revision_composition m A p = ({}, A - elect m A p, elect m A p)"

abbreviation rev ::
"'a Electoral_Module \<Rightarrow> 'a Electoral_Module" ("_\<down>" 50) where
  "m\<down> == revision_composition m"

subsection \<open>Soundness\<close>

theorem rev_comp_sound[simp]:
  assumes module: "electoral_module m"
  shows "electoral_module (revision_composition m)"
proof -
  from module have "\<forall>A p. finite_profile A p \<longrightarrow> elect m A p \<subseteq> A"
    using elect_in_alts
    by auto
  hence "\<forall>A p. finite_profile A p \<longrightarrow> (A - elect m A p) \<union> elect m A p = A"
    by blast
  hence unity:
    "\<forall>A p. finite_profile A p \<longrightarrow>
      set_equals_partition A (revision_composition m A p)"
    by simp
  have "\<forall>A p. finite_profile A p \<longrightarrow> (A - elect m A p) \<inter> elect m A p = {}"
    by blast
  hence disjoint:
    "\<forall>A p. finite_profile A p \<longrightarrow> disjoint3 (revision_composition m A p)"
    by simp
  from unity disjoint show ?thesis
    by (simp add: electoral_modI)
qed

subsection \<open>Composition Rules\<close>

(*An electoral module received by revision is never electing.*)
theorem rev_comp_non_electing[simp]:
  assumes "electoral_module m"
  shows "non_electing (m\<down>)"
  by (simp add: assms non_electing_def)

(*
   Revising an electing electoral module results in a
   non-blocking electoral module.
*)
theorem rev_comp_non_blocking[simp]:
  assumes "electing m"
  shows "non_blocking (m\<down>)"
  unfolding non_blocking_def
proof (safe, simp_all)
  show "electoral_module (m\<down>)"
    using assms electing_def rev_comp_sound
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    no_elect: "A - elect m A p = A" and
    x_in_A: "x \<in> A"
  from no_elect have non_elect:
    "non_electing m"
    using assms prof_A x_in_A fin_A electing_def empty_iff
          Diff_disjoint Int_absorb2 elect_in_alts
    by (metis (no_types, lifting))
  show "False"
    using non_elect assms electing_def empty_iff fin_A
          non_electing_def prof_A x_in_A
    by (metis (no_types, lifting))
qed

(*
   Revising an invariant monotone electoral module results in a
   defer-invariant-monotone electoral module.
*)
theorem rev_comp_def_inv_mono[simp]:
  assumes "invariant_monotonicity m"
  shows "defer_invariant_monotonicity (m\<down>)"
proof -
  have "\<forall>A p q w. (w \<in> defer (m\<down>) A p \<and> lifted A p q w) \<longrightarrow>
                  (defer (m\<down>) A q = defer (m\<down>) A p \<or> defer (m\<down>) A q = {w})"
    using assms
    by (simp add: invariant_monotonicity_def)
  moreover have "electoral_module (m\<down>)"
    using assms rev_comp_sound invariant_monotonicity_def
    by auto
  moreover have "non_electing (m\<down>)"
    using assms rev_comp_non_electing invariant_monotonicity_def
    by auto
  ultimately have "electoral_module (m\<down>) \<and> non_electing (m\<down>) \<and>
      (\<forall>A p q w. (w \<in> defer (m\<down>) A p \<and> lifted A p q w) \<longrightarrow>
                 (defer (m\<down>) A q = defer (m\<down>) A p \<or> defer (m\<down>) A q = {w}))"
    by blast
  thus ?thesis
    using defer_invariant_monotonicity_def
    by (simp add: defer_invariant_monotonicity_def)
qed

end


(*  Title:       Verification components with predicate transformers
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Verification components with Predicate Transformers \<close>

text \<open> We use the categorical forward box operator @{text fb\<^sub>\<F>} to compute weakest liberal
preconditions (wlps) of hybrid programs. Then we repeat the three methods for verifying
correctness specifications of the continuous dynamics of a HS. \<close>

theory HS_VC_PT
  imports
    "Transformer_Semantics.Kleisli_Quantaloid"
    "../HS_ODEs"

begin

no_notation bres (infixr "\<rightarrow>" 60)
        and dagger ("_\<^sup>\<dagger>" [101] 100)
        and "Relation.relcomp" (infixl ";" 75)
        and eta ("\<eta>")
        and kcomp (infixl "\<circ>\<^sub>K" 75)

type_synonym 'a pred = "'a \<Rightarrow> bool"

notation eta ("skip")
     and kcomp (infixl ";" 75)
     and g_orbital ("(1x\<acute>=_ & _ on _ _ @ _)")

subsection \<open>Verification of regular programs\<close>

text \<open>Properties of the forward box operator. \<close>

lemma "fb\<^sub>\<F> F S = (\<Inter> \<circ> \<P> (- op\<^sub>K F)) (- S)"
  unfolding ffb_def map_dual_def dual_set_def klift_def by simp

lemma "fb\<^sub>\<F> F S = {s. F s \<subseteq> S}"
  by (auto simp: ffb_def kop_def klift_def map_dual_def dual_set_def f2r_def r2f_def)

lemma ffb_eq: "fb\<^sub>\<F> F S = {s. \<forall>s'. s' \<in> F s \<longrightarrow> s' \<in> S}"
  by (auto simp: ffb_def kop_def klift_def map_dual_def dual_set_def f2r_def r2f_def)

lemma ffb_iso: "P \<le> Q \<Longrightarrow> fb\<^sub>\<F> F P \<le> fb\<^sub>\<F> F Q"
  unfolding ffb_eq by auto

lemma ffb_invariants:
  assumes "{s. I s} \<le> fb\<^sub>\<F> F {s. I s}" and "{s. J s} \<le> fb\<^sub>\<F> F {s. J s}"
  shows "{s. I s \<and> J s} \<le> fb\<^sub>\<F> F {s. I s \<and> J s}"
    and "{s. I s \<or> J s} \<le> fb\<^sub>\<F> F {s. I s \<or> J s}"
  using assms unfolding ffb_eq by auto

\<comment> \<open> Skip \<close>

lemma ffb_skip[simp]: "fb\<^sub>\<F> skip S = S"
  unfolding ffb_def by(simp add: kop_def klift_def map_dual_def)

\<comment> \<open> Tests \<close>

definition test :: "'a pred \<Rightarrow> 'a \<Rightarrow> 'a set" ("(1\<questiondown>_?)")
  where "\<questiondown>P? = (\<lambda>s. {x. x = s \<and> P x})"

lemma ffb_test[simp]: "fb\<^sub>\<F> \<questiondown>P? Q = {s. P s \<longrightarrow> s \<in> Q}"
  unfolding ffb_eq test_def by simp

\<comment> \<open> Assignments \<close>

definition assign :: "'n \<Rightarrow> ('a^'n \<Rightarrow> 'a) \<Rightarrow> ('a^'n) \<Rightarrow> ('a^'n) set" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) = (\<lambda>s. {vec_upd s x (e s)})"

lemma ffb_assign[simp]: "fb\<^sub>\<F> (x ::= e) Q = {s. (\<chi> j. ((($) s)(x := (e s))) j) \<in> Q}"
  unfolding vec_upd_def assign_def by (subst ffb_eq) simp

\<comment> \<open> Nondeterministic assignments \<close>

definition nondet_assign :: "'n \<Rightarrow> 'a^'n \<Rightarrow> ('a^'n) set" ("(2_ ::= ? )" [70] 61)
  where "(x ::= ?) = (\<lambda>s. {(vec_upd s x k)|k. True})"

lemma fbox_nondet_assign[simp]: "fb\<^sub>\<F> (x ::= ?) P = {s. \<forall>k. (\<chi> j. if j = x then k else s$j) \<in> P}"
  unfolding ffb_eq nondet_assign_def vec_upd_eq apply(simp add: fun_eq_iff, safe)
  by (erule_tac x="(\<chi> j. if j = x then k else _ $ j)" in allE, auto)

\<comment> \<open> Nondeterministic choice \<close>

lemma ffb_choice: "fb\<^sub>\<F> (\<lambda>s. F s \<union> G s) P = fb\<^sub>\<F> F P \<inter> fb\<^sub>\<F> G P"
  unfolding ffb_eq by auto

lemma le_ffb_choice_iff: "P \<subseteq> fb\<^sub>\<F> (\<lambda>s. F s \<union> G s) Q \<longleftrightarrow> P \<subseteq> fb\<^sub>\<F> F Q \<and> P \<subseteq> fb\<^sub>\<F> G Q"
  unfolding ffb_eq by auto

\<comment> \<open> Sequential composition \<close>

lemma ffb_kcomp[simp]: "fb\<^sub>\<F> (G ; F) P = fb\<^sub>\<F> G (fb\<^sub>\<F> F P)"
  unfolding ffb_eq by (auto simp: kcomp_def)

lemma hoare_kcomp:
  assumes "P \<le> fb\<^sub>\<F> F R" "R \<le> fb\<^sub>\<F> G Q"
  shows "P \<le> fb\<^sub>\<F> (F ; G) Q"
  apply(subst ffb_kcomp)
  by (rule order.trans[OF assms(1)]) (rule ffb_iso[OF assms(2)])

\<comment> \<open> Conditional statement \<close>

definition ifthenelse :: "'a pred \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set)"
  ("IF _ THEN _ ELSE _" [64,64,64] 63) where
  "IF P THEN X ELSE Y = (\<lambda> x. if P x then X x else Y x)"

lemma ffb_if_then_else[simp]:
  "fb\<^sub>\<F> (IF T THEN X ELSE Y) Q = {s. T s \<longrightarrow> s \<in> fb\<^sub>\<F> X Q} \<inter> {s. \<not> T s \<longrightarrow> s \<in> fb\<^sub>\<F> Y Q}"
  unfolding ffb_eq ifthenelse_def by auto

lemma hoare_if_then_else:
  assumes "P \<inter> {s. T s} \<le> fb\<^sub>\<F> X Q"
    and "P \<inter> {s. \<not> T s} \<le> fb\<^sub>\<F> Y Q"
  shows "P \<le> fb\<^sub>\<F> (IF T THEN X ELSE Y) Q"
  using assms
  apply(subst ffb_eq)
  apply(subst (asm) ffb_eq)+
  unfolding ifthenelse_def by auto

\<comment> \<open> Finite iteration \<close>

lemma kpower_inv: "I \<le> {s. \<forall>y. y \<in> F s \<longrightarrow> y \<in> I} \<Longrightarrow> I \<le> {s. \<forall>y. y \<in> (kpower F n s) \<longrightarrow> y \<in> I}"
  apply(induct n, simp)
  apply simp
  by(auto simp: kcomp_prop)

lemma kstar_inv: "I \<le> fb\<^sub>\<F> F I \<Longrightarrow> I \<subseteq> fb\<^sub>\<F> (kstar F) I"
  unfolding kstar_def ffb_eq apply clarsimp
  using kpower_inv by blast

lemma ffb_kstarI:
  assumes "P \<le> I" and "I \<le> Q" and "I \<le> fb\<^sub>\<F> F I"
  shows "P \<le> fb\<^sub>\<F> (kstar F) Q"
proof-
  have "I \<subseteq> fb\<^sub>\<F> (kstar F) I"
    using assms(3) kstar_inv by blast
  hence "P \<le> fb\<^sub>\<F> (kstar F) I"
    using assms(1) by auto
  also have "fb\<^sub>\<F> (kstar F) I \<le> fb\<^sub>\<F> (kstar F) Q"
    by (rule ffb_iso[OF assms(2)])
  finally show ?thesis .
qed

definition loopi :: "('a \<Rightarrow> 'a set) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP F INV I \<equiv> (kstar F)"

lemma change_loopI: "LOOP X INV G = LOOP X INV I"
  unfolding loopi_def by simp

lemma ffb_loopI: "P \<le> {s. I s}  \<Longrightarrow> {s. I s} \<le> Q \<Longrightarrow> {s. I s} \<le> fb\<^sub>\<F> F {s. I s} \<Longrightarrow> P \<le> fb\<^sub>\<F> (LOOP F INV I) Q"
  unfolding loopi_def using ffb_kstarI[of "P"] by simp

lemma ffb_loopI_break:
  "P \<le> fb\<^sub>\<F> Y {s. I s} \<Longrightarrow> {s. I s} \<le> fb\<^sub>\<F> X {s. I s} \<Longrightarrow> {s. I s} \<le> Q \<Longrightarrow> P \<le> fb\<^sub>\<F> (Y ; (LOOP X INV I)) Q"
  by (rule hoare_kcomp, force) (rule ffb_loopI, auto)

subsection \<open>Verification of hybrid programs\<close>

text \<open>Verification by providing evolution\<close>

definition g_evol :: "(('a::ord) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b pred \<Rightarrow> ('b \<Rightarrow> 'a set) \<Rightarrow> ('b \<Rightarrow> 'b set)" ("EVOL")
  where "EVOL \<phi> G U = (\<lambda>s. g_orbit (\<lambda>t. \<phi> t s) G (U s))"

lemma fbox_g_evol[simp]:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "fb\<^sub>\<F> (EVOL \<phi> G U) Q = {s. (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q)}"
  unfolding g_evol_def g_orbit_eq ffb_eq by auto

text \<open>Verification by providing solutions\<close>

lemma ffb_g_orbital: "fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) Q =
  {s. \<forall>X\<in>Sols f U S t\<^sub>0 s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<longrightarrow> (X t) \<in> Q}"
  unfolding ffb_eq g_orbital_eq by (auto simp: fun_eq_iff)

context local_flow
begin

lemma ffb_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "fb\<^sub>\<F> (x\<acute>= (\<lambda>t. f) & G on U S @ 0) Q =
  {s. s \<in> S \<longrightarrow> (\<forall>t\<in>(U s). (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q)}"
  apply(unfold ffb_g_orbital set_eq_iff)
  apply(clarify, rule iffI; clarify)
   apply(force simp: in_ivp_sols assms)
  apply(frule ivp_solsD(2), frule ivp_solsD(3), frule ivp_solsD(4))
  apply(subgoal_tac "\<forall>\<tau>\<in>down (U x) t. X \<tau> = \<phi> \<tau> x")
   apply(clarsimp, fastforce, rule ballI)
  apply(rule ivp_unique_solution[OF _ _ _ _ _ in_ivp_sols])
  using assms by auto

lemma ffb_g_ode: "fb\<^sub>\<F> (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) Q =
  {s. s \<in> S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q)}" (is "_ = ?wlp")
  by (subst ffb_g_ode_subset, simp_all add: init_time interval_time)

lemma ffb_orbit: "fb\<^sub>\<F> \<gamma>\<^sup>\<phi> Q = {s. s \<in> S \<longrightarrow> (\<forall> t \<in> T. \<phi> t s \<in> Q)}"
  unfolding orbit_def ffb_g_ode by simp

end

text \<open> Verification with differential invariants \<close>

definition g_ode_inv :: "(real \<Rightarrow> ('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> real set) \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("(1x\<acute>=_ & _ on _ _ @ _ DINV _ )")
  where "(x\<acute>= f & G on U S @ t\<^sub>0 DINV I) = (x\<acute>= f & G on U S @ t\<^sub>0)"

lemma ffb_g_orbital_guard:
  assumes "H = (\<lambda>s. G s \<and> Q s)"
  shows "fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. Q s} = fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. H s}"
  unfolding ffb_g_orbital using assms by auto

lemma ffb_g_orbital_inv:
  assumes "P \<le> I" and "I \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) I" and "I \<le> Q"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) Q"
  using assms(1)
  apply(rule order.trans)
  using assms(2)
  apply(rule order.trans)
  by (rule ffb_iso[OF assms(3)])

lemma ffb_diff_inv[simp]:
  "({s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. I s}) = diff_invariant I f U S t\<^sub>0 G"
  by (auto simp: diff_invariant_def ivp_sols_def ffb_eq g_orbital_eq)

lemma bdf_diff_inv:
  "diff_invariant I f U S t\<^sub>0 G = (bd\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. I s} \<le> {s. I s})"
  unfolding ffb_fbd_galois_var by (auto simp: diff_invariant_def ivp_sols_def ffb_eq g_orbital_eq)

lemma diff_inv_guard_ignore:
  assumes "{s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. True) on U S @ t\<^sub>0) {s. I s}"
  shows "{s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. I s}"
  using assms unfolding ffb_diff_inv diff_invariant_eq image_le_pred by auto

context local_flow
begin

lemma ffb_diff_inv_eq:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "diff_invariant I (\<lambda>t. f) U S 0 (\<lambda>s. True) =
  ({s. s \<in> S \<longrightarrow> I s} = fb\<^sub>\<F> (x\<acute>= (\<lambda>t. f) & (\<lambda>s. True) on U S @ 0) {s. s \<in> S \<longrightarrow> I s})"
 unfolding ffb_diff_inv[symmetric]
  apply(subst ffb_g_ode_subset[OF assms], simp)+
  apply(clarsimp simp: set_eq_iff, safe, force)
   apply(erule_tac x=0 in ballE)
  using init_time in_domain ivp(2) assms apply(force, force)
  apply(erule_tac x=x in allE, clarsimp, erule_tac x=t in ballE)
  using in_domain ivp(2) assms by force+

lemma diff_inv_eq_inv_set:
  "diff_invariant I (\<lambda>t. f) (\<lambda>s. T) S 0 (\<lambda>s. True) = (\<forall>s. I s \<longrightarrow> \<gamma>\<^sup>\<phi> s \<subseteq> {s. I s})"
  unfolding diff_inv_eq_inv_set orbit_def by simp

end

lemma ffb_g_odei: "P \<le> {s. I s} \<Longrightarrow> {s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. I s} \<Longrightarrow>
  {s. I s \<and> G s} \<le> Q \<Longrightarrow> P \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0 DINV I) Q"
  unfolding g_ode_inv_def
  apply(rule_tac b="fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. I s}" in order.trans)
   apply(rule_tac I="{s. I s}" in ffb_g_orbital_inv, simp_all)
  apply(subst ffb_g_orbital_guard, simp)
  by (rule ffb_iso, force)

subsection \<open> Derivation of the rules of dL \<close>

text\<open> We derive domain specific rules of differential dynamic logic (dL). First we present a
generalised version, then we show the rules as instances of the general ones.\<close>

abbreviation g_dl_orbit ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set" ("(1x\<acute>=_ & _)")
  where "(x\<acute>=f & G) \<equiv> (x\<acute>=(\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0)"

abbreviation g_dl_ode_inv ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set" ("(1x\<acute>=_ & _ DINV _)")
  where "(x\<acute>=f & G DINV I) \<equiv> (x\<acute>=(\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0 DINV I)"

lemma diff_solve_axiom1:
  assumes "local_flow f UNIV UNIV \<phi>"
  shows "fb\<^sub>\<F> (x\<acute>= f & G) Q =
  {s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q}"
  by (subst local_flow.ffb_g_ode_subset[OF assms], auto)

lemma diff_solve_axiom2:
  fixes c::"'a::{heine_borel, banach}"
  shows "fb\<^sub>\<F> (x\<acute>=(\<lambda>s. c) & G) Q =
  {s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s + \<tau> *\<^sub>R c)) \<longrightarrow> (s + t *\<^sub>R c) \<in> Q}"
  apply(subst local_flow.ffb_g_ode_subset[where \<phi>="(\<lambda>t s. s + t *\<^sub>R c)" and T=UNIV])
  by (rule line_is_local_flow, auto)

lemma diff_solve_rule:
  assumes "local_flow f UNIV UNIV \<phi>"
    and "\<forall>s. s \<in> P \<longrightarrow> (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q)"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G) Q"
  using assms by(subst local_flow.ffb_g_ode_subset[OF assms(1)]) auto

lemma diff_weak_axiom1: "s \<in> (fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. G s})"
  unfolding ffb_eq g_orbital_eq by auto

lemma diff_weak_axiom2: "fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q = fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. G s \<longrightarrow> s \<in> Q}"
  unfolding ffb_g_orbital image_def by force

lemma diff_weak_rule: "{s. G s} \<le> Q \<Longrightarrow> P \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q"
  by(auto intro: g_orbitalD simp: le_fun_def g_orbital_eq ffb_eq)

lemma ffb_g_orbital_eq_univD:
  assumes "fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. C s} = UNIV"
    and "\<forall>\<tau>\<in>(down (U s) t). x \<tau> \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
  shows "\<forall>\<tau>\<in>(down (U s) t). C (x \<tau>)"
proof
  fix \<tau> assume "\<tau> \<in> (down (U s) t)"
  hence "x \<tau> \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    using assms(2) by blast
  also have "\<forall>y. y \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s \<longrightarrow> C y"
    using assms(1) unfolding ffb_eq by fastforce
  ultimately show "C (x \<tau>)" by blast
qed

lemma diff_cut_axiom:
  assumes "fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. C s} = UNIV"
  shows "fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) Q = fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) Q"
proof(rule_tac f="\<lambda> x. fb\<^sub>\<F> x Q" in HOL.arg_cong, rule ext, rule subset_antisym)
  fix s
  {fix s' assume "s' \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    then obtain \<tau>::real and X where x_ivp: "X \<in> Sols f U S t\<^sub>0 s"
      and "X \<tau> = s'" and "\<tau> \<in> (U s)" and guard_x:"\<P> X (down (U s) \<tau>) \<subseteq> {s. G s}"
      using g_orbitalD[of s' "f" G _ S t\<^sub>0 s]  by blast
    have "\<forall>t\<in>(down (U s) \<tau>). \<P> X (down (U s) t) \<subseteq> {s. G s}"
      using guard_x by (force simp: image_def)
    also have "\<forall>t\<in>(down (U s) \<tau>). t \<in> (U s)"
      using \<open>\<tau> \<in> (U s)\<close> closed_segment_subset_interval by auto
    ultimately have "\<forall>t\<in>(down (U s) \<tau>). X t \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp] by (metis (mono_tags, lifting))
    hence "\<forall>t\<in>(down (U s) \<tau>). C (X t)"
      using assms unfolding ffb_eq by fastforce
    hence "s' \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp \<open>\<tau> \<in> (U s)\<close>] guard_x \<open>X \<tau> = s'\<close>
      unfolding image_le_pred by fastforce}
  thus "(x\<acute>= f & G on U S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s"
    by blast
next show "\<And>s. (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    by (auto simp: g_orbital_eq)
qed

lemma diff_cut_rule:
  assumes ffb_C: "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) {s. C s}"
    and ffb_Q: "P \<le> fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) Q"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) Q"
proof(subst ffb_eq, subst g_orbital_eq, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s assume "s \<in> P" and "t \<in> (U s)"
    and x_ivp:"X \<in> Sols f U S t\<^sub>0 s"
    and guard_x:"\<forall>\<tau>. \<tau> \<in> (U s) \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)"
  have "\<forall>\<tau>\<in>(down (U s) t). X \<tau> \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    using g_orbitalI[OF x_ivp] guard_x unfolding image_le_pred by auto
  hence "\<forall>\<tau>\<in>(down (U s) t). C (X \<tau>)"
    using ffb_C \<open>s \<in> P\<close> by (subst (asm) ffb_eq, auto)
  hence "X t \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s"
    using guard_x \<open>t \<in> (U s)\<close> by (auto intro!: g_orbitalI x_ivp)
  thus "(X t) \<in> Q"
    using \<open>s \<in> P\<close> ffb_Q by (subst (asm) ffb_eq) auto
qed

lemma diff_inv_axiom1:
  assumes "G s \<longrightarrow> I s" and "diff_invariant I (\<lambda>t. f) (\<lambda>s. {t. t \<ge> 0}) UNIV 0 G"
  shows "s \<in> (fb\<^sub>\<F> (x\<acute>= f & G) {s. I s})"
  using assms unfolding ffb_g_orbital diff_invariant_eq apply clarsimp
  by (erule_tac x=s in allE, frule ivp_solsD(2), clarsimp)

lemma diff_inv_axiom2:
  assumes "picard_lindeloef (\<lambda>t. f) UNIV UNIV 0"
    and "\<And>s. {t::real. t \<ge> 0} \<subseteq> picard_lindeloef.ex_ivl (\<lambda>t. f) UNIV UNIV 0 s"
    and "diff_invariant I (\<lambda>t. f) (\<lambda>s. {t::real. t \<ge> 0}) UNIV 0 G"
  shows "fb\<^sub>\<F> (x\<acute>= f & G) {s. I s} = fb\<^sub>\<F> (\<lambda>s. {x. s = x \<and> G s}) {s. I s}"
proof(unfold ffb_g_orbital, subst ffb_eq, clarsimp simp: set_eq_iff)
  fix s
  let "?ex_ivl s" = "picard_lindeloef.ex_ivl (\<lambda>t. f) UNIV UNIV 0 s"
  let "?lhs s" =
    "\<forall>X\<in>Sols (\<lambda>t. f) (\<lambda>s. {t. t \<ge> 0}) UNIV 0 s. \<forall>t\<ge>0. (\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)) \<longrightarrow> I (X t)"
  obtain X where xivp1: "X \<in> Sols (\<lambda>t. f) (\<lambda>s. ?ex_ivl s) UNIV 0 s"
    using picard_lindeloef.flow_in_ivp_sols_ex_ivl[OF assms(1)] by auto
  have xivp2: "X \<in> Sols (\<lambda>t. f) (\<lambda>s. Collect ((\<le>) 0)) UNIV 0 s"
    by (rule in_ivp_sols_subset[OF _ _ xivp1], simp_all add: assms(2))
  hence shyp: "X 0 = s"
    using ivp_solsD by auto
  have dinv: "\<forall>s. I s \<longrightarrow> ?lhs s"
    using assms(3) unfolding diff_invariant_eq by auto
  {assume "?lhs s" and "G s"
    hence "I s"
      by (erule_tac x=X in ballE, erule_tac x=0 in allE, auto simp: shyp xivp2)}
  hence "?lhs s \<longrightarrow> (G s \<longrightarrow> I s)"
    by blast
  moreover
  {assume "G s \<longrightarrow> I s"
    hence "?lhs s"
      apply(clarify, subgoal_tac "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)")
       apply(erule_tac x=0 in allE, frule ivp_solsD(2), simp)
      using dinv by blast+}
  ultimately show "?lhs s = (G s \<longrightarrow> I s)"
    by blast
qed

lemma diff_inv_rule:
  assumes "P \<le> {s. I s}" and "diff_invariant I f U S t\<^sub>0 G" and "{s. I s} \<le> Q"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on U S @ t\<^sub>0) Q"
  apply(rule ffb_g_orbital_inv[OF assms(1) _ assms(3)])
  unfolding ffb_diff_inv using assms(2) .

end


theory Prelude_Maybe
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
     \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"EqualPrefixDef\",
     \"DiffPrefixDef\", \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\",
     \"TE1\", \"TE2\", \"TE3\", \"TE4\", \"IBE1\", \"IBE2\", \"IBE3\",
     \"IBE4\", \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\", \"IUE1\",
     \"IUE2\", \"IOE01\", \"IOE02\", \"IOE03\", \"IOE04\", \"IOE05\",
     \"IOE06\", \"IOE07\", \"IOE08\", \"IOE09\", \"LeIrreflexivity\",
     \"LeTAsymmetry\", \"LeTTransitive\", \"LeTTotal\", \"GeDef\",
     \"GeIrreflexivity\", \"GeTAsymmetry\", \"GeTTransitive\",
     \"GeTTotal\", \"LeqDef\", \"LeqReflexivity\", \"LeqTTransitive\",
     \"LeqTTotal\", \"GeqDef\", \"GeqReflexivity\", \"GeqTTransitive\",
     \"GeqTTotal\", \"EqTSOrdRel\", \"EqFSOrdRel\", \"EqTOrdRel\",
     \"EqFOrdRel\", \"EqTOrdTSubstE\", \"EqTOrdFSubstE\",
     \"EqTOrdTSubstD\", \"EqTOrdFSubstD\", \"LeTGeFEqFRel\",
     \"LeFGeTEqTRel\", \"LeTGeTRel\", \"LeFGeFRel\", \"LeqTGetTRel\",
     \"LeqFGetFRel\", \"GeTLeTRel\", \"GeFLeFRel\", \"GeqTLeqTRel\",
     \"GeqFLeqFRel\", \"LeqTGeFRel\", \"LeqFGeTRel\", \"GeTLeFEqFRel\",
     \"GeFLeTEqTRel\", \"GeqTLeFRel\", \"GeqFLeTRel\",
     \"LeqTLeTEqTRel\", \"LeqFLeFEqFRel\", \"GeqTGeTEqTRel\",
     \"GeqFGeFEqFRel\", \"LeTGeqFRel\", \"GeTLeqFRel\", \"LeLeqDiff\",
     \"LePrefixDef\", \"LeqPrefixDef\", \"GePrefixDef\",
     \"GeqPrefixDef\", \"CmpLTDef\", \"CmpEQDef\", \"CmpGTDef\",
     \"MaxYDef\", \"MaxXDef\", \"MinXDef\", \"MinYDef\", \"MaxSym\",
     \"MinSym\", \"TO1\", \"TO2\", \"TO3\", \"TO4\", \"TO5\", \"TO6\",
     \"TO7\", \"IOO13\", \"IOO14\", \"IOO15\", \"IOO16\", \"IOO17\",
     \"IOO18\", \"IOO19\", \"IOO20\", \"IOO21\", \"IOO22\", \"IOO23\",
     \"IOO24\", \"IOO25\", \"IOO26\", \"IOO27\", \"IOO28\", \"IOO29\",
     \"IOO30\", \"IOO31\", \"IOO32\", \"IOO33\", \"IBO5\", \"IBO6\",
     \"IBO7\", \"IBO8\", \"IBO9\", \"IBO10\", \"IBO11\", \"IBO12\",
     \"IUO01\", \"IUO02\", \"IUO03\", \"IUO04\", \"IUO05\", \"IUO06\",
     \"IUO07\", \"MaybeJustDef\", \"MaybeNothingDef\", \"IME01\",
     \"IME03\", \"IMO01\", \"IMO02\", \"IME02\", \"IMO03\", \"IMO04\",
     \"IMO05\", \"IMO06\", \"IMO07\", \"IMO08\", \"IMO09\", \"IMO10\",
     \"IMO11\", \"IMO12\"]"

typedecl Unit
typedecl X_Nat

datatype Bool = X_False ("False''") | X_True ("True''")
datatype Ordering = EQ | GT | LT
datatype 'a Maybe = X_Just 'a ("Just/'(_')" [3] 999) | Nothing

consts
Not__X :: "Bool => Bool" ("(Not''/ _)" [56] 56)
XLtXEqXEqXGt :: "'a => 'a => Bool"
XLtXGtXEqXGt :: "'a => 'a => Bool"
XLtXGtXGt :: "'a => 'a => Bool"
XLtXLtXEqXGt :: "'a => 'a => Bool"
XLtXLtXGt :: "'a => 'a => Bool"
XLtXSlashXEqXGt :: "'a => 'a => Bool"
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a => 'a => Bool" ("(_/ ==''/ _)" [54,54] 52)
X__XGtXEq__X :: "'a => 'a => Bool" ("(_/ >=''/ _)" [54,54] 52)
X__XGt__X :: "'a => 'a => Bool" ("(_/ >''/ _)" [54,54] 52)
X__XLtXEq__X :: "'a => 'a => Bool" ("(_/ <=''/ _)" [54,54] 52)
X__XLt__X :: "'a => 'a => Bool" ("(_/ <''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a => 'a => Bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
X_max :: "'a => 'a => 'a"
X_min :: "'a => 'a => 'a"
compare :: "'a => 'a => Ordering"
maybe :: "'b => ('a => 'b) => 'a Maybe => 'b"
otherwiseH :: "Bool"

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

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

AndFalse [rule_format] : "ALL x. False' && x = False'"

AndTrue [rule_format] : "ALL x. True' && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH = True'"

NotFalse1 [rule_format] : "ALL x. Not' x = True' = (x = False')"

NotTrue1 [rule_format] : "ALL x. Not' x = False' = (x = True')"

notNot1 [rule_format] : "ALL x. (~ x = True') = (Not' x = True')"

notNot2 [rule_format] : "ALL x. (~ x = False') = (Not' x = False')"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y = True'"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x = True'"

EqualTransT [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y ==' z = True' --> x ==' z = True'"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

EqualPrefixDef [rule_format] :
"ALL x. ALL y. XLtXEqXEqXGt x y = x ==' y"

DiffPrefixDef [rule_format] :
"ALL x. ALL y. XLtXSlashXEqXGt x y = x /= y"

DiffSymDef [rule_format] : "ALL x. ALL y. x /= y = y /= x"

DiffTDef [rule_format] :
"ALL x. ALL y. x /= y = True' = (Not' (x ==' y) = True')"

DiffFDef [rule_format] :
"ALL x. ALL y. x /= y = False' = (x ==' y = True')"

TE1 [rule_format] : "ALL x. ALL y. x ==' y = False' --> ~ x = y"

TE2 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = True' = (x ==' y = False')"

TE3 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = False' = (x ==' y = True')"

TE4 [rule_format] :
"ALL x. ALL y. (~ x ==' y = True') = (x ==' y = False')"

IBE1 [rule_format] : "True' ==' True' = True'"

IBE2 [rule_format] : "False' ==' False' = True'"

IBE3 [rule_format] : "False' ==' True' = False'"

IBE4 [rule_format] : "True' ==' False' = False'"

IBE5 [rule_format] : "True' /= False' = True'"

IBE6 [rule_format] : "False' /= True' = True'"

IBE7 [rule_format] : "Not' (True' ==' False') = True'"

IBE8 [rule_format] : "Not' Not' (True' ==' False') = False'"

IUE1 [rule_format] : "() ==' () = True'"

IUE2 [rule_format] : "() /= () = False'"

IOE01 [rule_format] : "LT ==' LT = True'"

IOE02 [rule_format] : "EQ ==' EQ = True'"

IOE03 [rule_format] : "GT ==' GT = True'"

IOE04 [rule_format] : "LT ==' EQ = False'"

IOE05 [rule_format] : "LT ==' GT = False'"

IOE06 [rule_format] : "EQ ==' GT = False'"

IOE07 [rule_format] : "LT /= EQ = True'"

IOE08 [rule_format] : "LT /= GT = True'"

IOE09 [rule_format] : "EQ /= GT = True'"

LeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x <' y = False'"

LeTAsymmetry [rule_format] :
"ALL x. ALL y. x <' y = True' --> y <' x = False'"

LeTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. x <' y = True' & y <' z = True' --> x <' z = True'"

LeTTotal [rule_format] :
"ALL x. ALL y. (x <' y = True' | y <' x = True') | x ==' y = True'"

GeDef [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x >' y = False'"

GeTAsymmetry [rule_format] :
"ALL x. ALL y. x >' y = True' --> y >' x = False'"

GeTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. (x >' y) && (y >' z) = True' --> x >' z = True'"

GeTTotal [rule_format] :
"ALL x. ALL y. ((x >' y) || (y >' x)) || (x ==' y) = True'"

LeqDef [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y) || (x ==' y)"

LeqReflexivity [rule_format] : "ALL x. x <=' x = True'"

LeqTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. (x <=' y) && (y <=' z) = True' --> x <=' z = True'"

LeqTTotal [rule_format] :
"ALL x. ALL y. (x <=' y) && (y <=' x) = x ==' y"

GeqDef [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y) || (x ==' y)"

GeqReflexivity [rule_format] : "ALL x. x >=' x = True'"

GeqTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. (x >=' y) && (y >=' z) = True' --> x >=' z = True'"

GeqTTotal [rule_format] :
"ALL x. ALL y. (x >=' y) && (y >=' x) = x ==' y"

EqTSOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = True' = (x <' y = False' & x >' y = False')"

EqFSOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = False' = (x <' y = True' | x >' y = True')"

EqTOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = True' = (x <=' y = True' & x >=' y = True')"

EqFOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = False' = (x <=' y = True' | x >=' y = True')"

EqTOrdTSubstE [rule_format] :
"ALL x.
 ALL y. ALL z. x ==' y = True' & y <' z = True' --> x <' z = True'"

EqTOrdFSubstE [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y <' z = False' --> x <' z = False'"

EqTOrdTSubstD [rule_format] :
"ALL x.
 ALL y. ALL z. x ==' y = True' & z <' y = True' --> z <' x = True'"

EqTOrdFSubstD [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & z <' y = False' --> z <' x = False'"

LeTGeFEqFRel [rule_format] :
"ALL x.
 ALL y. x <' y = True' = (x >' y = False' & x ==' y = False')"

LeFGeTEqTRel [rule_format] :
"ALL x.
 ALL y. x <' y = False' = (x >' y = True' | x ==' y = True')"

LeTGeTRel [rule_format] :
"ALL x. ALL y. x <' y = True' = (y >' x = True')"

LeFGeFRel [rule_format] :
"ALL x. ALL y. x <' y = False' = (y >' x = False')"

LeqTGetTRel [rule_format] :
"ALL x. ALL y. x <=' y = True' = (y >=' x = True')"

LeqFGetFRel [rule_format] :
"ALL x. ALL y. x <=' y = False' = (y >=' x = False')"

GeTLeTRel [rule_format] :
"ALL x. ALL y. x >' y = True' = (y <' x = True')"

GeFLeFRel [rule_format] :
"ALL x. ALL y. x >' y = False' = (y <' x = False')"

GeqTLeqTRel [rule_format] :
"ALL x. ALL y. x >=' y = True' = (y <=' x = True')"

GeqFLeqFRel [rule_format] :
"ALL x. ALL y. x >=' y = False' = (y <=' x = False')"

LeqTGeFRel [rule_format] :
"ALL x. ALL y. x <=' y = True' = (x >' y = False')"

LeqFGeTRel [rule_format] :
"ALL x. ALL y. x <=' y = False' = (x >' y = True')"

GeTLeFEqFRel [rule_format] :
"ALL x.
 ALL y. x >' y = True' = (x <' y = False' & x ==' y = False')"

GeFLeTEqTRel [rule_format] :
"ALL x.
 ALL y. x >' y = False' = (x <' y = True' | x ==' y = True')"

GeqTLeFRel [rule_format] :
"ALL x. ALL y. x >=' y = True' = (x <' y = False')"

GeqFLeTRel [rule_format] :
"ALL x. ALL y. x >=' y = False' = (x <' y = True')"

LeqTLeTEqTRel [rule_format] :
"ALL x.
 ALL y. x <=' y = True' = (x <' y = True' | x ==' y = True')"

LeqFLeFEqFRel [rule_format] :
"ALL x.
 ALL y. x <=' y = False' = (x <' y = False' & x ==' y = False')"

GeqTGeTEqTRel [rule_format] :
"ALL x.
 ALL y. x >=' y = True' = (x >' y = True' | x ==' y = True')"

GeqFGeFEqFRel [rule_format] :
"ALL x.
 ALL y. x >=' y = False' = (x >' y = False' & x ==' y = False')"

LeTGeqFRel [rule_format] :
"ALL x. ALL y. x <' y = True' = (x >=' y = False')"

GeTLeqFRel [rule_format] :
"ALL x. ALL y. x >' y = True' = (x <=' y = False')"

LeLeqDiff [rule_format] :
"ALL x. ALL y. x <' y = (x <=' y) && (x /= y)"

LePrefixDef [rule_format] : "ALL x. ALL y. XLtXLtXGt x y = x <' y"

LeqPrefixDef [rule_format] :
"ALL x. ALL y. XLtXLtXEqXGt x y = x <=' y"

GePrefixDef [rule_format] : "ALL x. ALL y. XLtXGtXGt x y = x >' y"

GeqPrefixDef [rule_format] :
"ALL x. ALL y. XLtXGtXEqXGt x y = x >=' y"

CmpLTDef [rule_format] :
"ALL x. ALL y. compare x y ==' LT = x <' y"

CmpEQDef [rule_format] :
"ALL x. ALL y. compare x y ==' EQ = x ==' y"

CmpGTDef [rule_format] :
"ALL x. ALL y. compare x y ==' GT = x >' y"

MaxYDef [rule_format] : "ALL x. ALL y. X_max x y ==' y = x <=' y"

MaxXDef [rule_format] : "ALL x. ALL y. X_max x y ==' x = y <=' x"

MinXDef [rule_format] : "ALL x. ALL y. X_min x y ==' x = x <=' y"

MinYDef [rule_format] : "ALL x. ALL y. X_min x y ==' y = y <=' x"

MaxSym [rule_format] :
"ALL x. ALL y. X_max x y ==' y = X_max y x ==' y"

MinSym [rule_format] :
"ALL x. ALL y. X_min x y ==' y = X_min y x ==' y"

TO1 [rule_format] :
"ALL x.
 ALL y. (x ==' y = True' | x <' y = True') = (x <=' y = True')"

TO2 [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x <' y = False'"

TO3 [rule_format] :
"ALL x. ALL y. Not' Not' (x <' y) = True' | Not' (x <' y) = True'"

TO4 [rule_format] :
"ALL x. ALL y. x <' y = True' --> Not' (x ==' y) = True'"

TO5 [rule_format] :
"ALL w.
 ALL x.
 ALL y.
 ALL z.
 (x <' y = True' & y <' z = True') & z <' w = True' -->
 x <' w = True'"

TO6 [rule_format] :
"ALL x. ALL z. z <' x = True' --> Not' (x <' z) = True'"

TO7 [rule_format] :
"ALL x. ALL y. x <' y = True' = (y >' x = True')"

IOO13 [rule_format] : "LT <' EQ = True'"

IOO14 [rule_format] : "EQ <' GT = True'"

IOO15 [rule_format] : "LT <' GT = True'"

IOO16 [rule_format] : "LT <=' EQ = True'"

IOO17 [rule_format] : "EQ <=' GT = True'"

IOO18 [rule_format] : "LT <=' GT = True'"

IOO19 [rule_format] : "EQ >=' LT = True'"

IOO20 [rule_format] : "GT >=' EQ = True'"

IOO21 [rule_format] : "GT >=' LT = True'"

IOO22 [rule_format] : "EQ >' LT = True'"

IOO23 [rule_format] : "GT >' EQ = True'"

IOO24 [rule_format] : "GT >' LT = True'"

IOO25 [rule_format] : "X_max LT EQ ==' EQ = True'"

IOO26 [rule_format] : "X_max EQ GT ==' GT = True'"

IOO27 [rule_format] : "X_max LT GT ==' GT = True'"

IOO28 [rule_format] : "X_min LT EQ ==' LT = True'"

IOO29 [rule_format] : "X_min EQ GT ==' EQ = True'"

IOO30 [rule_format] : "X_min LT GT ==' LT = True'"

IOO31 [rule_format] : "compare LT LT ==' EQ = True'"

IOO32 [rule_format] : "compare EQ EQ ==' EQ = True'"

IOO33 [rule_format] : "compare GT GT ==' EQ = True'"

IBO5 [rule_format] : "False' <' True' = True'"

IBO6 [rule_format] : "False' >=' True' = False'"

IBO7 [rule_format] : "True' >=' False' = True'"

IBO8 [rule_format] : "True' <' False' = False'"

IBO9 [rule_format] : "X_max False' True' ==' True' = True'"

IBO10 [rule_format] : "X_min False' True' ==' False' = True'"

IBO11 [rule_format] : "compare True' True' ==' EQ = True'"

IBO12 [rule_format] : "compare False' False' ==' EQ = True'"

IUO01 [rule_format] : "() <=' () = True'"

IUO02 [rule_format] : "() <' () = False'"

IUO03 [rule_format] : "() >=' () = True'"

IUO04 [rule_format] : "() >' () = False'"

IUO05 [rule_format] : "X_max () () ==' () = True'"

IUO06 [rule_format] : "X_min () () ==' () = True'"

IUO07 [rule_format] : "compare () () ==' EQ = True'"

MaybeJustDef [rule_format] :
"ALL f. ALL x. ALL y. maybe y f (Just(x)) = f x"

MaybeNothingDef [rule_format] :
"ALL f. ALL y. maybe y f Nothing = y"

IME01 [rule_format] :
"ALL x. ALL y. Just(x) ==' Just(y) = True' = (x ==' y = True')"

IME03 [rule_format] : "ALL x. Just(x) ==' Nothing = False'"

IMO01 [rule_format] : "ALL x. Nothing <' Just(x) = True'"

IMO02 [rule_format] : "ALL x. ALL y. Just(x) <' Just(y) = x <' y"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare EqualReflex [simp]
declare IBE1 [simp]
declare IBE2 [simp]
declare IBE3 [simp]
declare IBE4 [simp]
declare IBE5 [simp]
declare IBE6 [simp]
declare IBE7 [simp]
declare IBE8 [simp]
declare IOE01 [simp]
declare IOE02 [simp]
declare IOE03 [simp]
declare IOE04 [simp]
declare IOE05 [simp]
declare IOE06 [simp]
declare IOE07 [simp]
declare IOE08 [simp]
declare IOE09 [simp]
declare LeIrreflexivity [simp]
declare LeTAsymmetry [simp]
declare GeIrreflexivity [simp]
declare GeTAsymmetry [simp]
declare GeTTransitive [simp]
declare GeTTotal [simp]
declare LeqReflexivity [simp]
declare LeqTTransitive [simp]
declare LeqTTotal [simp]
declare GeqReflexivity [simp]
declare GeqTTransitive [simp]
declare GeqTTotal [simp]
declare CmpLTDef [simp]
declare CmpEQDef [simp]
declare CmpGTDef [simp]
declare MaxYDef [simp]
declare MaxXDef [simp]
declare MinXDef [simp]
declare MinYDef [simp]
declare TO2 [simp]
declare TO4 [simp]
declare TO6 [simp]
declare IOO13 [simp]
declare IOO14 [simp]
declare IOO15 [simp]
declare IOO16 [simp]
declare IOO17 [simp]
declare IOO18 [simp]
declare IOO19 [simp]
declare IOO20 [simp]
declare IOO21 [simp]
declare IOO22 [simp]
declare IOO23 [simp]
declare IOO24 [simp]
declare IOO25 [simp]
declare IOO26 [simp]
declare IOO27 [simp]
declare IOO28 [simp]
declare IOO29 [simp]
declare IOO30 [simp]
declare IOO31 [simp]
declare IOO32 [simp]
declare IOO33 [simp]
declare IBO5 [simp]
declare IBO6 [simp]
declare IBO7 [simp]
declare IBO8 [simp]
declare IBO9 [simp]
declare IBO10 [simp]
declare IBO11 [simp]
declare IBO12 [simp]
declare IUO05 [simp]
declare IUO06 [simp]
declare IUO07 [simp]
declare MaybeJustDef [simp]
declare MaybeNothingDef [simp]
declare IME03 [simp]
declare IMO01 [simp]
declare IMO02 [simp]

theorem IME02 : "Nothing ==' Nothing = True'"
by (auto)

ML "Header.record \"IME02\""

theorem IMO03 : "ALL x. Nothing >=' Just(x) = False'"
apply(rule allI)
apply(simp only: GeqDef)
apply(simp only: GeDef OrDef)
apply(case_tac "Just(x) <' Nothing")
apply(auto)
done

ML "Header.record \"IMO03\""

theorem IMO04 : "ALL x. Just(x) >=' Nothing = True'"
apply(rule allI)
apply(simp only: GeqDef)
apply(simp only: GeDef OrDef)
apply(case_tac "Nothing <' Just(x)")
apply(auto)
done

ML "Header.record \"IMO04\""

theorem IMO05 : "ALL x. Just(x) <' Nothing = False'"
apply(rule allI)
apply(case_tac "Just(x) <' Nothing")
apply(auto)
done

ML "Header.record \"IMO05\""

theorem IMO06 :
"ALL x. compare Nothing (Just(x)) ==' EQ = Nothing ==' Just(x)"
by (auto)

ML "Header.record \"IMO06\""

theorem IMO07 :
"ALL x. compare Nothing (Just(x)) ==' LT = Nothing <' Just(x)"
by (auto)

ML "Header.record \"IMO07\""

theorem IMO08 :
"ALL x. compare Nothing (Just(x)) ==' GT = Nothing >' Just(x)"
apply(rule allI)+
apply(simp add: GeDef)
done

ML "Header.record \"IMO08\""

theorem IMO09 :
"ALL x. Nothing <=' Just(x) = X_max Nothing (Just(x)) ==' Just(x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO09\""

theorem IMO10 :
"ALL x. Just(x) <=' Nothing = X_max Nothing (Just(x)) ==' Nothing"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO10\""

theorem IMO11 :
"ALL x. Nothing <=' Just(x) = X_min Nothing (Just(x)) ==' Nothing"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO11\""

theorem IMO12 :
"ALL x. Just(x) <=' Nothing = X_min Nothing (Just(x)) ==' Just(x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO12\""

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Galois Connection\<close>
theory Transport_Compositions_Agree_Galois_Connection
  imports
    HOL_Basics.Galois_Connections
    Transport_Compositions_Agree_Monotone
    Transport_Compositions_Agree_Galois_Property
begin

context transport_comp_agree
begin

interpretation flip : transport_comp_agree R2 L2 r2 l2 R1 L1 r1 l1 .

lemma galois_connectionI:
  assumes galois: "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1" "((\<le>\<^bsub>L2\<^esub>) \<stileturn> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and mono_L1_L2_l1: "\<And>x y. x \<le>\<^bsub>L1\<^esub> y \<Longrightarrow> l1 x \<le>\<^bsub>R1\<^esub> l1 y \<Longrightarrow> l1 x \<le>\<^bsub>L2\<^esub> l1 y"
  and mono_R2_R1_r2: "\<And>x y. x \<le>\<^bsub>R2\<^esub> y \<Longrightarrow> r2 x \<le>\<^bsub>L2\<^esub> r2 y \<Longrightarrow> r2 x \<le>\<^bsub>R1\<^esub> r2 y"
  and "([in_dom (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow> [in_codom (\<le>\<^bsub>R2\<^esub>)] \<Rrightarrow> (\<longleftrightarrow>))
    (rel_bimap l1 r2 (\<le>\<^bsub>R1\<^esub>)) (rel_bimap l1 r2 (\<le>\<^bsub>L2\<^esub>))"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
proof -
  from galois mono_L1_L2_l1 have "([in_dom (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m in_dom (\<le>\<^bsub>L2\<^esub>)) l1"
    by (intro dep_mono_wrt_predI) (blast elim!: in_domE g1.galois_connectionE)
  moreover from galois mono_R2_R1_r2
    have "([in_codom (\<le>\<^bsub>R2\<^esub>)] \<Rrightarrow>\<^sub>m in_codom (\<le>\<^bsub>R1\<^esub>)) r2"
    by (intro dep_mono_wrt_predI) (blast elim!: in_codomE g2.galois_connectionE)
  ultimately show ?thesis using assms
    by (intro galois_connectionI galois_propI mono_wrt_rel_leftI
      flip.mono_wrt_rel_leftI)
    auto
qed

lemma galois_connectionI':
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1" "((\<le>\<^bsub>L2\<^esub>) \<stileturn> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2\<^esub>)) l1" "((\<le>\<^bsub>R2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) r2"
  and "([in_dom (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow> [in_codom (\<le>\<^bsub>R2\<^esub>)] \<Rrightarrow> (\<longleftrightarrow>))
    (rel_bimap l1 r2 (\<le>\<^bsub>R1\<^esub>)) (rel_bimap l1 r2 (\<le>\<^bsub>L2\<^esub>))"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_connectionI) auto

end

context transport_comp_same
begin

corollary galois_connectionI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<stileturn> (\<le>\<^bsub>R1\<^esub>)) l1 r1" "((\<le>\<^bsub>R1\<^esub>) \<stileturn> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (rule galois_connectionI) auto

end

end


theory Needham_Schroeder_Base
imports Main "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
begin

datatype agent = Alice | Bob | Spy

definition agents :: "agent set"
where
  "agents = {Spy, Alice, Bob}"

definition bad :: "agent set"
where
  "bad = {Spy}"

datatype key = pubEK agent | priEK agent

fun invKey
where
  "invKey (pubEK A) = priEK A"
| "invKey (priEK A) = pubEK A"

datatype
     msg = Agent  agent
         | Key    key
         | Nonce  nat
         | MPair  msg msg
         | Crypt  key msg

syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>"   == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>"      == "CONST MPair x y"

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

primrec initState
where
  initState_Alice:
    "initState Alice = {Key (priEK Alice)} \<union> (Key ` pubEK ` agents)"
| initState_Bob:
    "initState Bob = {Key (priEK Bob)} \<union> (Key ` pubEK ` agents)"
| initState_Spy:
    "initState Spy        =  (Key ` priEK ` bad) \<union> (Key ` pubEK ` agents)"

datatype
  event = Says  agent agent msg
        | Gets  agent       msg
        | Notes agent       msg

primrec knows :: "agent => event list => msg set"
where
  knows_Nil:   "knows A [] = initState A"
| knows_Cons:
    "knows A (ev # evs) =
       (if A = Spy then
        (case ev of
           Says A' B X => insert X (knows Spy evs)
         | Gets A' X => knows Spy evs
         | Notes A' X  =>
             if A' \<in> bad then insert X (knows Spy evs) else knows Spy evs)
        else
        (case ev of
           Says A' B X =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Gets A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Notes A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs))"

abbreviation (input)
  spies  :: "event list => msg set" where
  "spies == knows Spy"

primrec used :: "event list => msg set"
where
  used_Nil:   "used []         = \<Union>(parts ` initState ` agents)"
| used_Cons:  "used (ev # evs) =
                     (case ev of
                        Says A B X => parts {X} \<union> used evs
                      | Gets A X   => used evs
                      | Notes A X  => parts {X} \<union> used evs)"

subsection \<open>Preparations for sets\<close>

fun find_first :: "('a => 'b option) => 'a list => 'b option"
where
  "find_first f [] = None"
| "find_first f (x # xs) = (case f x of Some y => Some y | None => find_first f xs)"

consts cps_of_set :: "'a set => ('a => term list option) => term list option"

lemma
  [code]: "cps_of_set (set xs) f = find_first f xs"
sorry

consts pos_cps_of_set :: "'a set => ('a => (bool * term list) option) => natural => (bool * term list) option"
consts neg_cps_of_set :: "'a set => ('a Quickcheck_Exhaustive.unknown => term list Quickcheck_Exhaustive.three_valued) => natural => term list Quickcheck_Exhaustive.three_valued"

lemma
  [code]: "pos_cps_of_set (set xs) f i = find_first f xs"
sorry

consts find_first' :: "('b Quickcheck_Exhaustive.unknown => 'a Quickcheck_Exhaustive.three_valued)
    => 'b list => 'a Quickcheck_Exhaustive.three_valued"

lemma
  [code]: "neg_cps_of_set (set xs) f i = find_first' f xs"
sorry

setup \<open>
let
  val Fun = Predicate_Compile_Aux.Fun
  val Input = Predicate_Compile_Aux.Input
  val Output = Predicate_Compile_Aux.Output
  val Bool = Predicate_Compile_Aux.Bool
  val oi = Fun (Output, Fun (Input, Bool))
  val ii = Fun (Input, Fun (Input, Bool))
  fun of_set compfuns (Type ("fun", [T, _])) =
    case body_type (Predicate_Compile_Aux.mk_monadT compfuns T) of
      Type ("Quickcheck_Exhaustive.three_valued", _) =>
        Const(@{const_name neg_cps_of_set}, HOLogic.mk_setT T --> (Predicate_Compile_Aux.mk_monadT compfuns T))
    | Type ("Predicate.pred", _) => Const(@{const_name pred_of_set}, HOLogic.mk_setT T --> Predicate_Compile_Aux.mk_monadT compfuns T)
    | _ => Const(@{const_name pos_cps_of_set}, HOLogic.mk_setT T --> (Predicate_Compile_Aux.mk_monadT compfuns T))
  fun member compfuns (U as Type ("fun", [T, _])) =
    (absdummy T (absdummy (HOLogic.mk_setT T) (Predicate_Compile_Aux.mk_if compfuns
      (Const (@{const_name "Set.member"}, T --> HOLogic.mk_setT T --> @{typ bool}) $ Bound 1 $ Bound 0))))

in
  Core_Data.force_modes_and_compilations @{const_name Set.member}
    [(oi, (of_set, false)), (ii, (member, false))]
end
\<close>

subsection \<open>Derived equations for analz, parts and synth\<close>

lemma [code]:
  "analz H = (let
     H' = H \<union> (\<Union>((%m. case m of \<lbrace>X, Y\<rbrace> => {X, Y} | Crypt K X => if Key (invKey K) : H then {X} else {} | _ => {}) ` H))
   in if H' = H then H else analz H')"
sorry

lemma [code]:
  "parts H = (let
     H' = H \<union> (\<Union>((%m. case m of \<lbrace>X, Y\<rbrace> => {X, Y} | Crypt K X => {X} | _ => {}) ` H))
   in if H' = H then H else parts H')"
sorry

definition synth' :: "msg set => msg => bool"
where
  "synth' H m = (m : synth H)"

lemmas [code_pred_intro] = synth.intros[folded synth'_def]

code_pred [generator_cps] synth' unfolding synth'_def by (rule synth.cases) fastforce+

setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name analz}, @{const_name knows}]\<close>
declare ListMem_iff[symmetric, code_pred_inline]
declare [[quickcheck_timing]]

setup Exhaustive_Generators.setup_exhaustive_datatype_interpretation
declare [[quickcheck_full_support = false]]

end


section \<open>Comparing WS1S Formulas with Presburger Formulas\<close>

(*<*)
theory WS1S_Presburger_Equivalence
imports Presburger_Formula WS1S_Formula
begin
(*>*)

lift_definition letter_eq :: "idx \<Rightarrow> nat \<Rightarrow> bool list \<times> bool list \<Rightarrow> bool list \<Rightarrow> bool" is
  "\<lambda>(m1,m2) n (bs1, bs2) bs. m1 = 0 \<and> m2 = n \<and> bs1 = [] \<and> bs2 = bs" .

lemma letter_eq[dest]:
  "letter_eq idx n a b \<Longrightarrow> (a \<in> set (WS1S_Prelim.\<sigma> idx)) = (b \<in> set (Presburger_Formula.\<sigma> n))"
  by transfer (force simp: Presburger_Formula.\<sigma>_def set_n_lists image_iff)

global_interpretation WS1S_Presb: DAs
  "WS1S_Prelim.\<sigma> idx"
  "(\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)"
  "(\<lambda>a \<phi>. norm (deriv lderiv0 (a :: atom) \<phi>))"
  "(WS1S.final idx)"
  "(\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>)"
  "\<lambda>\<phi>. Formula.lang WS1S_Prelim.nvars
     WS1S_Prelim.Extend WS1S_Prelim.CONS WS1S_Prelim.Length WS1S_Prelim.size_atom
     WS1S_Formula.satisfies0 idx \<phi>"
  "(\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>)"
  "\<lambda>\<phi>. Formula.language WS1S_Prelim.assigns
     WS1S_Prelim.nvars WS1S_Prelim.Extend WS1S_Prelim.CONS
     WS1S_Prelim.Length WS1S_Prelim.size_atom restrict WS1S_Formula.FV0
     WS1S_Formula.satisfies0 idx \<phi>"
  "(Presburger_Formula.\<sigma> n)"
  "(\<lambda>\<phi>. Presburger_Formula.norm (Presburger_Formula.RESTRICT \<phi>))"
  "(\<lambda>a \<phi>. Presburger_Formula.norm (Presburger_Formula.deriv Presburger_Formula.lderiv0 a \<phi>))"
  "(Presburger_Formula.final n)"
  "(\<lambda>\<phi>. presb_wf n \<phi> \<and> presb_lformula \<phi>)"
  "(\<lambda>\<phi>. Formula.lang Presburger_Formula.nvars
            Presburger_Formula.Extend Presburger_Formula.CONS Presburger_Formula.Length
            Presburger_Formula.size_atom (\<Turnstile>0) n \<phi>)"
  "(\<lambda>\<phi>. presb_wf n \<phi> \<and> presb_lformula \<phi>)"
  "(\<lambda>\<phi>. Formula.language Presburger_Formula.assigns
            Presburger_Formula.nvars Presburger_Formula.Extend Presburger_Formula.CONS
            Presburger_Formula.Length Presburger_Formula.size_atom (\<lambda>_ _. True)
            Presburger_Formula.FV0 (\<Turnstile>0)
            n \<phi>)"
  "letter_eq idx n"
  defines check_eqv = "\<lambda>idx n. DAs.check_eqv
    (\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
    (\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
    (final idx) (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>)
    (Presburger_Formula.\<sigma> n) (\<lambda>\<phi>. Presburger_Formula.norm (Presburger_Formula.RESTRICT \<phi>))
    (\<lambda>a \<phi>. Presburger_Formula.norm (Presburger_Formula.deriv Presburger_Formula.lderiv0 a \<phi>))
    (Presburger_Formula.final n) (\<lambda>\<phi>. presb_wf n \<phi> \<and> presb_lformula \<phi>) (letter_eq idx n)"
  by unfold_locales auto

(*Workaround for code generation*)
lemma check_eqv_code[code]: "check_eqv idx n r s \<longleftrightarrow>
  ((ws1s_wf idx r \<and> ws1s_lformula r) \<and> (presb_wf n s \<and> presb_lformula s) \<and>
  (case rtrancl_while (\<lambda>(p, q). final idx p = Presburger_Formula.final n q)
  (\<lambda>(p, q).
    map (\<lambda>(a, b). (norm (deriv lderiv0 a p),
      Presburger_Formula.norm (Presburger_Formula.deriv Presburger_Formula.lderiv0 b q)))
     [(x, y)\<leftarrow>List.product (\<sigma> idx) (Presburger_Formula.\<sigma> n). letter_eq idx n x y])
    (norm (RESTRICT r), Presburger_Formula.norm (Presburger_Formula.RESTRICT s)) of
    None \<Rightarrow> False
  | Some ([], x) \<Rightarrow> True
  | Some (a # list, x) \<Rightarrow> False))"
  unfolding check_eqv_def WS1S_Presb.check_eqv_def ..

method_setup check_equiv = \<open>
  let
    fun tac ctxt =
      let
        val conv = @{computation_check terms: Trueprop
          "0 :: nat" "1 :: nat" "2 :: nat" "3 :: nat" Suc
          "plus :: nat \<Rightarrow> _" "minus :: nat \<Rightarrow> _"
          "times :: nat \<Rightarrow> _" "divide :: nat \<Rightarrow> _" "modulo :: nat \<Rightarrow> _"
          "0 :: int" "1 :: int" "2 :: int" "3 :: int" "-1 :: int"
          check_eqv datatypes: idx "(presb, unit) aformula" "((nat, nat) atomic, WS1S_Prelim.order) aformula"
          "nat \<times> nat" "nat option" "bool option" "int list" integer} ctxt
      in
        CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN'
        resolve_tac ctxt [TrueI]
      end
  in
    Scan.succeed (SIMPLE_METHOD' o tac)
  end
\<close>

(*<*)
end
(*>*)


section "Implementing Labelled Transition Systems by Maps"
theory LTSByTripleSetAQQ
imports TripleSetSpec LTSSpec LTSGA
begin

locale ltsbm_AQQ_defs =
  ts: triple_set ts_\<alpha> ts_invar
  for ts_\<alpha>::"'ts \<Rightarrow> ('A \<times> 'Q \<times> 'Q) set"
  and ts_invar
begin

  definition ltsbm_\<alpha> :: "('Q,'A,'ts) lts_\<alpha>" where
    "ltsbm_\<alpha> ts \<equiv> (\<lambda>(a, q, q'). (q, a, q')) ` (ts_\<alpha> ts)"

  lemma ltsbm_\<alpha>_alt_def :
    "ltsbm_\<alpha> ts = {(q, a, q') . (a, q, q') \<in> ts_\<alpha> ts}"
  unfolding ltsbm_\<alpha>_def
  by (auto simp add: image_iff set_eq_iff Bex_def)

  definition "ltsbm_invar \<equiv> ts_invar"

  lemma ltsbm_empty_correct:
    "triple_set_empty ts_\<alpha> ts_invar emp \<Longrightarrow>
     lts_empty ltsbm_\<alpha> ltsbm_invar emp"
    unfolding lts_empty_def triple_set_empty_def ltsbm_\<alpha>_def ltsbm_invar_def
    by simp

  definition ltsbm_memb :: "_ \<Rightarrow> ('Q,'A,'ts) lts_memb" where
    "ltsbm_memb memb ts q a q' \<equiv> memb ts a q q'"

  lemma ltsbm_memb_correct:
    "triple_set_memb ts_\<alpha> ts_invar memb \<Longrightarrow>
     lts_memb ltsbm_\<alpha> ltsbm_invar (ltsbm_memb memb)"
  unfolding lts_memb_def ltsbm_memb_def ltsbm_invar_def ltsbm_\<alpha>_def triple_set_memb_def
  by (simp add: image_iff Bex_def)

  definition ltsbm_add :: "_ \<Rightarrow> ('Q,'A,'ts) lts_add" where
    "ltsbm_add add q a q' ts \<equiv> add a q q' ts"

  lemma ltsbm_add_correct:
    "triple_set_add ts_\<alpha> ts_invar add \<Longrightarrow>
     lts_add ltsbm_\<alpha> ltsbm_invar (ltsbm_add add)"
  unfolding lts_add_def ltsbm_add_def ltsbm_invar_def ltsbm_\<alpha>_def triple_set_add_def
  by simp

  definition ltsbm_add_succs :: "_ \<Rightarrow> ('Q,'A,'ts) lts_add_succs" where
    "ltsbm_add_succs add_Cl q a qs ts \<equiv> add_Cl a q qs ts"

  lemma ltsbm_add_succs_correct:
    "triple_set_add_Cl ts_\<alpha> ts_invar add_Cl \<Longrightarrow>
     lts_add_succs ltsbm_\<alpha> ltsbm_invar (ltsbm_add_succs add_Cl)"
    unfolding lts_add_succs_def ltsbm_\<alpha>_alt_def ltsbm_invar_def ltsbm_add_succs_def
              triple_set_add_Cl_def
    by auto

  definition ltsbm_delete :: "_ \<Rightarrow> ('Q,'A,'ts) lts_delete" where
    "ltsbm_delete ts_del q a q' ts \<equiv> ts_del a q q' ts"

  lemma ltsbm_delete_correct:
    "triple_set_delete ts_\<alpha> ts_invar ts_del \<Longrightarrow>
     lts_delete ltsbm_\<alpha> ltsbm_invar (ltsbm_delete ts_del)"
    unfolding lts_delete_def ltsbm_delete_def ltsbm_\<alpha>_alt_def ltsbm_invar_def
              triple_set_delete_def
    by auto

  definition ltsbm_succ_it where
   "ltsbm_succ_it it (ts::'ts) (q::'Q) (a::'A) = it ts a q"

  lemma ltsbm_succ_it_correct :
    assumes "triple_set_C_it ts_\<alpha> ts_invar it"
    shows "lts_succ_it ltsbm_\<alpha> ltsbm_invar (ltsbm_succ_it it)"
  using assms
  unfolding lts_succ_it_def triple_set_C_it_def ltsbm_succ_it_def ltsbm_invar_def ltsbm_\<alpha>_alt_def
  by simp

  lemma ltsbm_succ_label_it_correct :
    assumes "triple_set_AC_it ts_\<alpha> ts_invar it"
    shows "lts_succ_label_it ltsbm_\<alpha> ltsbm_invar it"
  using assms
  unfolding lts_succ_label_it_def triple_set_AC_it_def ltsbm_invar_def ltsbm_\<alpha>_alt_def
  by simp

  definition ltsbm_filter_it where
   "ltsbm_filter_it it P_q P_a P_q' (P::('Q \<times> 'A \<times> 'Q) \<Rightarrow> bool) ts =
    set_iterator_image (\<lambda>(a, q, q'). (q, a, q'))
       (it P_a P_q P_q' (\<lambda>(a, q, q'). P (q, a, q')) ts)"

  lemma ltsbm_filter_it_correct :
    assumes filter_it: "triple_set_filter_it ts_\<alpha> ts_invar it"
    shows "lts_filter_it ltsbm_\<alpha> ltsbm_invar (ltsbm_filter_it it)"
  unfolding lts_filter_it_def
  proof (intro allI impI)
    fix ts P_q1 P_a P_q2 P
    assume invar_ts: "ltsbm_invar ts"

    let ?P' = "\<lambda>(a::'A, q::'Q, q'::'Q). (P (q, a, q'))::bool"
    let ?S1 = "{(q1, a, q2). (q1, a, q2) \<in> ltsbm_\<alpha> ts \<and>
                     P_q1 q1 \<and> P_a a \<and> P_q2 q2 \<and> P (q1, a, q2)} "
    let ?S2 = "{(a, q1, q2). (q1, a, q2) \<in> ltsbm_\<alpha> ts \<and>
                     P_a a \<and> P_q1 q1 \<and> P_q2 q2 \<and> P (q1, a, q2)} "

    from triple_set_filter_it.triple_set_filter_it_correct [OF filter_it,
         of ts P_a P_q1 P_q2 ?P'] invar_ts
    have step: "set_iterator (it P_a P_q1 P_q2 ?P' ts) ?S2"
      unfolding triple_set_BC_it_def ltsbm_\<alpha>_alt_def ltsbm_invar_def
      by simp

    show "set_iterator (ltsbm_filter_it it P_q1 P_a P_q2 P ts) ?S1"
    unfolding ltsbm_filter_it_def
      apply (rule set_iterator_image_correct[OF step])
      apply (auto simp add: inj_on_def image_iff)
    done
  qed

  definition ltsbm_it where
   "ltsbm_it it ts =
    set_iterator_image (\<lambda>(a::'A, q::'Q, q'::'Q). (q, a, q')) (it ts)"

  lemma ltsbm_it_correct :
    assumes it: "triple_set_iterator ts_\<alpha> ts_invar it"
    shows "lts_iterator ltsbm_\<alpha> ltsbm_invar (ltsbm_it it)"
  unfolding lts_iterator_def
  proof (intro allI impI)
    fix ts
    assume invar_ts: "ltsbm_invar ts"

    from triple_set_iterator.triple_set_it_correct [OF it, of ts] invar_ts
    have step: "set_iterator (it ts) {(a, q1, q2). (q1, a, q2) \<in> ltsbm_\<alpha> ts}"
      unfolding triple_set_BC_it_def ltsbm_\<alpha>_alt_def ltsbm_invar_def
      by simp

    show "set_iterator (ltsbm_it it ts) (ltsbm_\<alpha> ts)"
    unfolding ltsbm_it_def
      apply (rule set_iterator_image_correct[OF step])
      apply (auto simp add: inj_on_def image_iff)
    done
  qed

  definition ltsbm_pre_it where
   "ltsbm_pre_it it (ts::'ts) (q'::'Q) (a::'A) = it ts a q'"

  lemma ltsbm_pre_it_correct :
    assumes "triple_set_B_it ts_\<alpha> ts_invar it"
    shows "lts_pre_it ltsbm_\<alpha> ltsbm_invar (ltsbm_pre_it it)"
  using assms
  unfolding lts_pre_it_def triple_set_B_it_def ltsbm_pre_it_def ltsbm_invar_def ltsbm_\<alpha>_alt_def
  by simp

  definition ltsbm_pre_label_it where
   "ltsbm_pre_label_it it (ts::'ts) (q::'Q) =
    set_iterator_image (\<lambda>(a, q'). (q', a)) (it ts q)"

  lemma ltsbm_pre_label_it_correct :
    assumes AB_it: "triple_set_AB_it ts_\<alpha> ts_invar it"
    shows "lts_pre_label_it ltsbm_\<alpha> ltsbm_invar (ltsbm_pre_label_it it)"
  unfolding lts_pre_label_it_def
  proof (intro allI impI)
    fix ts q'
    assume invar_ts: "ltsbm_invar ts"

    let ?S1 = "{(a, q) . (q, a, q') \<in> ltsbm_\<alpha> ts}"
    let ?S2 = "{(q, a) . (q, a, q') \<in> ltsbm_\<alpha> ts}"

    from triple_set_AB_it.triple_set_AB_it_correct [OF AB_it, of ts] invar_ts
    have step: "set_iterator (it ts q') ?S1"
      unfolding triple_set_BC_it_def ltsbm_\<alpha>_alt_def ltsbm_invar_def by simp

    show "set_iterator (ltsbm_pre_label_it it ts q') ?S2"
    unfolding ltsbm_pre_label_it_def
      apply (rule set_iterator_image_correct[OF step])
      apply (auto simp add: inj_on_def)
    done
  qed
end

end