theory TA_DBM_Operations_Impl
  imports
    TA.TA_DBM_Operations
    DBM.DBM_Operations_Impl_Refine
    Sepref_Acconstraint
    TA_Library.Syntax_Bundles
begin

unbundle no_library_syntax

section \<open>Constraints\<close>

(*
fun abstra' :: "(nat, 't::time) acconstraint \<Rightarrow> 't DBM \<Rightarrow> 't DBM"
where
  "abstra' (EQ c d) M =
    (\<lambda> i j . if i = 0 \<and> j = c then min (M i j) (Le (-d)) else if i = c \<and> j = 0 then min (M i j) (Le d) else M i j)" |
  "abstra' (LT c d) M =
    (\<lambda> i j . if i = c \<and> j = 0 then min (M i j) (Lt d) else M i j)" |
  "abstra' (LE c d) M =
    (\<lambda> i j . if i = c \<and> j = 0 then min (M i j) (Le d) else M i j)" |
  "abstra' (GT c d) M =
    (\<lambda> i j. if i = 0 \<and> j = c then min (M i j) (Lt (- d)) else M i j)" |
  "abstra' (GE c d) M =
    (\<lambda> i j. if i = 0 \<and> j = c then min (M i j) (Le (- d)) else M i j)"
*)

definition "abstra' ac M = abstra ac M id"

lemma abstra_abstra':
  assumes "v (constraint_clk ac) = constraint_clk ac"
  shows "abstra ac M v = abstra' ac M"
unfolding abstra'_def using assms by (cases ac; fastforce)

definition "abstr' cc M = abstr cc M id"

lemma abstr_abstr':
  assumes "\<forall> c \<in> collect_clks cc. v c = c"
  shows "abstr cc M v = abstr' cc M"
unfolding abstr'_def using assms
by (auto simp: collect_clks_def intro: fold_cong abstra_abstra'[unfolded abstra'_def])

(* XXX Move? *)
lemma And_abstr:
  assumes "clock_numbering' v n" "\<forall> c \<in> collect_clks cc. v c \<le> n"
  shows "[And M (abstr cc (\<lambda> i j. \<infinity>) v)]\<^bsub>v,n\<^esub> = [abstr cc M v]\<^bsub>v,n\<^esub>"
using And_correct dbm_abstr_zone_eq[OF assms] dbm_abstr_zone_eq2[OF assms] by blast

(* XXX Move *)
lemma min_inf_r:
  "min a \<infinity> = a"
  by (cases a) (auto split: split_min simp: less_eq dbm_le_def)

lemma min_inf_l:
  "min \<infinity> b = b"
  by (cases b) (auto split: split_min simp: less_eq dbm_le_def)

lemma And_abstra_commute:
  assumes "clock_numbering' v n" "\<forall> c \<in> collect_clks cc. v c \<le> n"
  shows "And M (abstra ac (\<lambda> i j. \<infinity>) v) = abstra ac M v"
  by (cases ac) (auto simp: min_inf_l min_inf_r any_le_inf intro!: ext)

(* Could be proven by using the facts that abstra commutes with itself and And*)
lemma
  assumes "clock_numbering' v n" "\<forall> c \<in> collect_clks cc. v c \<le> n"
  shows "And M (abstr cc (\<lambda> i j. \<infinity>) v) = abstr cc M v"
apply (induction cc)
apply simp
apply (simp add: min_inf_r)
oops

lemma abstra_canonical_diag_preservation:
  assumes "clock_numbering v"
  shows "(abstra ac M v) i i = M i i"
using assms by (cases ac) (auto dest: clock_numberingD)

lemma abstr_canonical_diag_preservation:
  assumes "clock_numbering v"
  shows "(abstr cc M v) i i = M i i"
using assms
apply (induction cc arbitrary: M)
apply (simp; fail)
 subgoal for ac cc M
 using abstra_canonical_diag_preservation[where v = v and ac = ac] by auto
done

fun abstra_upd :: "(nat, 't::{linorder,uminus}) acconstraint \<Rightarrow> 't DBM' \<Rightarrow> 't DBM'"
where
  "abstra_upd (EQ c d) M =
    (let
      m0c = op_mtx_get M (0, c);
      mc0 = op_mtx_get M(c, 0)
     in M((0, c) := min m0c (Le (-d)), (c, 0) := min mc0 (Le d)))" |
  "abstra_upd (LT c d) M =
    M((c, 0) := min (op_mtx_get M (c, 0)) (Lt d))" |
  "abstra_upd (LE c d) M =
    M((c, 0) := min (op_mtx_get M (c, 0)) (Le d))" |
  "abstra_upd (GT c d) M =
    M((0, c) := min (op_mtx_get M ((0, c))) (Lt (- d)))" |
  "abstra_upd (GE c d) M =
    M((0, c) := min (op_mtx_get M (0, c)) (Le (- d)))"

lemma abstra_upd_alt_def:
  "abstra_upd ac M = case_acconstraint
    (\<lambda> c d. M((c, 0) := min (op_mtx_get M (c, 0)) (Lt d)))
    (\<lambda> c d. M((c, 0) := min (op_mtx_get M (c, 0)) (Le d)))
    (\<lambda> c d. let m0c = op_mtx_get M (0, c); mc0 = op_mtx_get M(c, 0) in M((0, c) := min m0c (Le (-d)), (c, 0) := min mc0 (Le d)))
    (\<lambda> c d. M((0, c) := min (op_mtx_get M ((0, c))) (Lt (- d))))
    (\<lambda> c d. M((0, c) := min (op_mtx_get M (0, c)) (Le (- d))))
    ac"
by (cases ac) auto

lemma abstra_upd_eq_abstra':
  assumes "constraint_clk ac > 0"
  shows "curry (abstra_upd ac M) = abstra' ac (curry M)"
unfolding abstra'_def using assms by (cases ac; fastforce)

lemma abstra_upd_int_preservation:
  assumes "snd (constraint_pair ac) \<in> \<int>" "dbm_int (curry M) n"
  shows "dbm_int (curry (abstra_upd ac M)) n"
using assms by (cases ac; simp split: split_min)

definition abstr_upd where
  "abstr_upd = fold (\<lambda> ac M. abstra_upd ac M)"

lemma abstr_upd_alt_def:
  "RETURN oo abstr_upd = (\<lambda> cc M. nfoldli cc (\<lambda> _. True) (\<lambda> ac M. RETURN (abstra_upd ac M)) M)"
by (intro ext, simp add: abstr_upd_def fold_eq_nfoldli)

lemma abstr_upd_abstr':
  assumes "\<forall> c \<in> collect_clks cc. c > 0"
  shows "curry (abstr_upd cc M) = abstr' cc (curry M)"
unfolding abstr_upd_def abstr'_def using assms
by (induction cc arbitrary: M) (auto simp: abstra_abstra' abstra_upd_eq_abstra')

lemma abstra_upd_out_of_bounds1:
  assumes "constraint_clk ac \<le> n" "i > n"
  shows "(abstra_upd ac M) (i, j) = M (i, j)"
using assms by (cases ac) auto

lemma abstra_upd_out_of_bounds2:
  assumes "constraint_clk ac \<le> n" "j > n"
  shows "(abstra_upd ac M) (i, j) = M (i, j)"
using assms by (cases ac) auto

lemma abstr_upd_out_of_bounds1:
  assumes "\<forall> c \<in> collect_clks cc. c \<le> n" "i > n"
  shows "(abstr_upd cc M) (i, j) = M (i, j)"
using assms by (induction cc arbitrary: M) (auto simp: abstr_upd_def abstra_upd_out_of_bounds1)

lemma abstr_upd_out_of_bounds2:
  assumes "\<forall> c \<in> collect_clks cc. c \<le> n" "j > n"
  shows "(abstr_upd cc M) (i, j) = M (i, j)"
using assms by (induction cc arbitrary: M) (auto simp: abstr_upd_def abstra_upd_out_of_bounds2)

lemma abstr_upd_int_preservation:
  assumes "\<forall> (_,d) \<in> collect_clock_pairs cc. d \<in> \<int>" "dbm_int (curry M) n"
  shows "dbm_int (curry (abstr_upd cc M)) n"
unfolding abstr_upd_def using assms
proof (induction cc arbitrary: M)
  case Nil then show ?case by simp
next
  case (Cons c cc)
  show ?case
   apply simp
   apply (rule Cons.IH[simplified])
   defer
   apply (rule abstra_upd_int_preservation[simplified])
  using Cons.prems unfolding collect_clock_pairs_def by auto
qed

(*
fun abstra_upd :: "('c, 't::time) acconstraint \<Rightarrow> 't DBM' \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> 't DBM'"
where
  "abstra_upd (EQ c d) M v =
    (let m0c = op_mtx_get M (0, v c); mc0 = op_mtx_get M(v c, 0) in M((0, v c) := min m0c (Le (-d)), (v c, 0) := min mc0 (Le d)))" |
  "abstra_upd (LT c d) M v =
    M((v c, 0) := min (op_mtx_get M (v c, 0)) (Lt d))" |
  "abstra_upd (LE c d) M v =
    M((v c, 0) := min (op_mtx_get M (v c, 0)) (Le d))" |
  "abstra_upd (GT c d) M v =
    M((0, v c) := min (op_mtx_get M ((0, v c))) (Lt (- d)))" |
  "abstra_upd (GE c d) M v =
    M((0, v c) := min (op_mtx_get M (0, v c)) (Le (- d)))"

lemma abstra_upd_eq_abstra:
  assumes "clock_numbering v"
  shows "curry (abstra_upd ac M v) = abstra ac (curry M) v"
using assms by (cases ac; fastforce dest: clock_numberingD)
*)

context
  fixes n :: nat
begin

interpretation DBM_Impl n .

sepref_definition abstra_upd_impl is
  "uncurry (RETURN oo abstra_upd)" ::
  "(acconstraint_assn clock_assn id_assn)\<^sup>k *\<^sub>a mtx_assn\<^sup>d \<rightarrow>\<^sub>a mtx_assn"
unfolding abstra_upd_alt_def zero_clock_def[symmetric] by sepref

sepref_register abstra_upd ::
  "(nat, ('a :: {linordered_cancel_ab_monoid_add,uminus,heap})) acconstraint
  \<Rightarrow> 'a DBMEntry i_mtx \<Rightarrow> 'a DBMEntry i_mtx"

lemmas [sepref_fr_rules] = abstra_upd_impl.refine

sepref_definition abstr_upd_impl is
  "uncurry (RETURN oo abstr_upd)"
  :: "(list_assn (acconstraint_assn clock_assn id_assn))\<^sup>k *\<^sub>a mtx_assn\<^sup>d \<rightarrow>\<^sub>a mtx_assn"
  unfolding abstr_upd_alt_def by sepref

end

export_code abstr_upd_impl abstra_upd_impl in SML_imp

end


(*  Title:      HOL/MicroJava/J/JBasis.thy
    Author:     David von Oheimb, TU Muenchen
*)

chapter \<open>Java Source Language \label{cha:j}\<close>

section \<open>Some Auxiliary Definitions\<close>

theory JBasis
imports
  Main
  "HOL-Library.Transitive_Closure_Table"
  "HOL-Eisbach.Eisbach"
begin

lemmas [simp] = Let_def

subsection "unique"

definition unique :: "('a \<times> 'b) list => bool" where
  "unique == distinct \<circ> map fst"

lemma fst_in_set_lemma: "(x, y) \<in> set xys \<Longrightarrow> x \<in> fst ` set xys"
  by (induct xys) auto

lemma unique_Nil [simp]: "unique []"
  by (simp add: unique_def)

lemma unique_Cons [simp]: "unique ((x,y)#l) = (unique l & (\<forall>y. (x,y) \<notin> set l))"
  by (auto simp: unique_def dest: fst_in_set_lemma)

lemma unique_append: "unique l' \<Longrightarrow> unique l \<Longrightarrow>
    (\<forall>(x,y) \<in> set l. \<forall>(x',y') \<in> set l'. x' \<noteq> x) \<Longrightarrow> unique (l @ l')"
  by (induct l) (auto dest: fst_in_set_lemma)

lemma unique_map_inj: "unique l ==> inj f ==> unique (map (%(k,x). (f k, g k x)) l)"
  by (induct l) (auto dest: fst_in_set_lemma simp add: inj_eq)

subsection "More about Maps"

lemma map_of_SomeI: "unique l \<Longrightarrow> (k, x) \<in> set l \<Longrightarrow> map_of l k = Some x"
  by (induct l) auto

lemma Ball_set_table: "(\<forall>(x,y)\<in>set l. P x y) ==> (\<forall>x. \<forall>y. map_of l x = Some y --> P x y)"
  by (induct l) auto

lemma table_of_remap_SomeD:
  "map_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) ==>
    map_of t (k, k') = Some x"
  by (atomize (full), induct t) auto

end


(*  Title:      HOL/Library/DAList_Multiset.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Multisets partially implemented by association lists\<close>

theory DAList_Multiset
imports Multiset DAList
begin

text \<open>Delete prexisting code equations\<close>

declare [[code drop: "{#}" Multiset.is_empty add_mset
  "plus :: 'a multiset \<Rightarrow> _" "minus :: 'a multiset \<Rightarrow> _"
  inter_mset union_mset image_mset filter_mset count
  "size :: _ multiset \<Rightarrow> nat" sum_mset prod_mset
  set_mset sorted_list_of_multiset subset_mset subseteq_mset
  equal_multiset_inst.equal_multiset]]

text \<open>Raw operations on lists\<close>

definition join_raw ::
    "('key \<Rightarrow> 'val \<times> 'val \<Rightarrow> 'val) \<Rightarrow>
      ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "join_raw f xs ys = foldr (\<lambda>(k, v). map_default k v (\<lambda>v'. f k (v', v))) ys xs"

lemma join_raw_Nil [simp]: "join_raw f xs [] = xs"
  by (simp add: join_raw_def)

lemma join_raw_Cons [simp]:
  "join_raw f xs ((k, v) # ys) = map_default k v (\<lambda>v'. f k (v', v)) (join_raw f xs ys)"
  by (simp add: join_raw_def)

lemma map_of_join_raw:
  assumes "distinct (map fst ys)"
  shows "map_of (join_raw f xs ys) x =
    (case map_of xs x of
      None \<Rightarrow> map_of ys x
    | Some v \<Rightarrow> (case map_of ys x of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (f x (v, v'))))"
  using assms
  apply (induct ys)
  apply (auto simp add: map_of_map_default split: option.split)
  apply (metis map_of_eq_None_iff option.simps(2) weak_map_of_SomeI)
  apply (metis Some_eq_map_of_iff map_of_eq_None_iff option.simps(2))
  done

lemma distinct_join_raw:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (join_raw f xs ys))"
  using assms
proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  then show ?case by (cases y) (simp add: distinct_map_default)
qed

definition "subtract_entries_raw xs ys = foldr (\<lambda>(k, v). AList.map_entry k (\<lambda>v'. v' - v)) ys xs"

lemma map_of_subtract_entries_raw:
  assumes "distinct (map fst ys)"
  shows "map_of (subtract_entries_raw xs ys) x =
    (case map_of xs x of
      None \<Rightarrow> None
    | Some v \<Rightarrow> (case map_of ys x of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (v - v')))"
  using assms
  unfolding subtract_entries_raw_def
  apply (induct ys)
  apply auto
  apply (simp split: option.split)
  apply (simp add: map_of_map_entry)
  apply (auto split: option.split)
  apply (metis map_of_eq_None_iff option.simps(3) option.simps(4))
  apply (metis map_of_eq_None_iff option.simps(4) option.simps(5))
  done

lemma distinct_subtract_entries_raw:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (subtract_entries_raw xs ys))"
  using assms
  unfolding subtract_entries_raw_def
  by (induct ys) (auto simp add: distinct_map_entry)

text \<open>Operations on alists with distinct keys\<close>

lift_definition join :: "('a \<Rightarrow> 'b \<times> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist"
  is join_raw
  by (simp add: distinct_join_raw)

lift_definition subtract_entries :: "('a, ('b :: minus)) alist \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist"
  is subtract_entries_raw
  by (simp add: distinct_subtract_entries_raw)

text \<open>Implementing multisets by means of association lists\<close>

definition count_of :: "('a \<times> nat) list \<Rightarrow> 'a \<Rightarrow> nat"
  where "count_of xs x = (case map_of xs x of None \<Rightarrow> 0 | Some n \<Rightarrow> n)"

lemma count_of_multiset: "finite {x. 0 < count_of xs x}"
proof -
  let ?A = "{x::'a. 0 < (case map_of xs x of None \<Rightarrow> 0::nat | Some n \<Rightarrow> n)}"
  have "?A \<subseteq> dom (map_of xs)"
  proof
    fix x
    assume "x \<in> ?A"
    then have "0 < (case map_of xs x of None \<Rightarrow> 0::nat | Some n \<Rightarrow> n)"
      by simp
    then have "map_of xs x \<noteq> None"
      by (cases "map_of xs x") auto
    then show "x \<in> dom (map_of xs)"
      by auto
  qed
  with finite_dom_map_of [of xs] have "finite ?A"
    by (auto intro: finite_subset)
  then show ?thesis
    by (simp add: count_of_def fun_eq_iff)
qed

lemma count_simps [simp]:
  "count_of [] = (\<lambda>_. 0)"
  "count_of ((x, n) # xs) = (\<lambda>y. if x = y then n else count_of xs y)"
  by (simp_all add: count_of_def fun_eq_iff)

lemma count_of_empty: "x \<notin> fst ` set xs \<Longrightarrow> count_of xs x = 0"
  by (induct xs) (simp_all add: count_of_def)

lemma count_of_filter: "count_of (List.filter (P \<circ> fst) xs) x = (if P x then count_of xs x else 0)"
  by (induct xs) auto

lemma count_of_map_default [simp]:
  "count_of (map_default x b (\<lambda>x. x + b) xs) y =
    (if x = y then count_of xs x + b else count_of xs y)"
  unfolding count_of_def by (simp add: map_of_map_default split: option.split)

lemma count_of_join_raw:
  "distinct (map fst ys) \<Longrightarrow>
    count_of xs x + count_of ys x = count_of (join_raw (\<lambda>x (x, y). x + y) xs ys) x"
  unfolding count_of_def by (simp add: map_of_join_raw split: option.split)

lemma count_of_subtract_entries_raw:
  "distinct (map fst ys) \<Longrightarrow>
    count_of xs x - count_of ys x = count_of (subtract_entries_raw xs ys) x"
  unfolding count_of_def by (simp add: map_of_subtract_entries_raw split: option.split)

text \<open>Code equations for multiset operations\<close>

definition Bag :: "('a, nat) alist \<Rightarrow> 'a multiset"
  where "Bag xs = Abs_multiset (count_of (DAList.impl_of xs))"

code_datatype Bag

lemma count_Bag [simp, code]: "count (Bag xs) = count_of (DAList.impl_of xs)"
  by (simp add: Bag_def count_of_multiset)

lemma Mempty_Bag [code]: "{#} = Bag (DAList.empty)"
  by (simp add: multiset_eq_iff alist.Alist_inverse DAList.empty_def)

lift_definition is_empty_Bag_impl :: "('a, nat) alist \<Rightarrow> bool" is
  "\<lambda>xs. list_all (\<lambda>x. snd x = 0) xs" .

lemma is_empty_Bag [code]: "Multiset.is_empty (Bag xs) \<longleftrightarrow> is_empty_Bag_impl xs"
proof -
  have "Multiset.is_empty (Bag xs) \<longleftrightarrow> (\<forall>x. count (Bag xs) x = 0)"
    unfolding Multiset.is_empty_def multiset_eq_iff by simp
  also have "\<dots> \<longleftrightarrow> (\<forall>x\<in>fst ` set (alist.impl_of xs). count (Bag xs) x = 0)"
  proof (intro iffI allI ballI)
    fix x assume A: "\<forall>x\<in>fst ` set (alist.impl_of xs). count (Bag xs) x = 0"
    thus "count (Bag xs) x = 0"
    proof (cases "x \<in> fst ` set (alist.impl_of xs)")
      case False
      thus ?thesis by (force simp: count_of_def split: option.splits)
    qed (insert A, auto)
  qed simp_all
  also have "\<dots> \<longleftrightarrow> list_all (\<lambda>x. snd x = 0) (alist.impl_of xs)"
    by (auto simp: count_of_def list_all_def)
  finally show ?thesis by (simp add: is_empty_Bag_impl.rep_eq)
qed

lemma union_Bag [code]: "Bag xs + Bag ys = Bag (join (\<lambda>x (n1, n2). n1 + n2) xs ys)"
  by (rule multiset_eqI)
    (simp add: count_of_join_raw alist.Alist_inverse distinct_join_raw join_def)

lemma add_mset_Bag [code]: "add_mset x (Bag xs) =
    Bag (join (\<lambda>x (n1, n2). n1 + n2) (DAList.update x 1 DAList.empty) xs)"
  unfolding add_mset_add_single[of x "Bag xs"] union_Bag[symmetric]
  by (simp add: multiset_eq_iff update.rep_eq empty.rep_eq)

lemma minus_Bag [code]: "Bag xs - Bag ys = Bag (subtract_entries xs ys)"
  by (rule multiset_eqI)
    (simp add: count_of_subtract_entries_raw alist.Alist_inverse
      distinct_subtract_entries_raw subtract_entries_def)

lemma filter_Bag [code]: "filter_mset P (Bag xs) = Bag (DAList.filter (P \<circ> fst) xs)"
  by (rule multiset_eqI) (simp add: count_of_filter DAList.filter.rep_eq)

lemma mset_eq [code]: "HOL.equal (m1::'a::equal multiset) m2 \<longleftrightarrow> m1 \<subseteq># m2 \<and> m2 \<subseteq># m1"
  by (metis equal_multiset_def subset_mset.order_eq_iff)

text \<open>By default the code for \<open><\<close> is \<^prop>\<open>xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> xs = ys\<close>.
With equality implemented by \<open>\<le>\<close>, this leads to three calls of  \<open>\<le>\<close>.
Here is a more efficient version:\<close>
lemma mset_less[code]: "xs \<subset># (ys :: 'a multiset) \<longleftrightarrow> xs \<subseteq># ys \<and> \<not> ys \<subseteq># xs"
  by (rule subset_mset.less_le_not_le)

lemma mset_less_eq_Bag0:
  "Bag xs \<subseteq># A \<longleftrightarrow> (\<forall>(x, n) \<in> set (DAList.impl_of xs). count_of (DAList.impl_of xs) x \<le> count A x)"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then show ?rhs by (auto simp add: subseteq_mset_def)
next
  assume ?rhs
  show ?lhs
  proof (rule mset_subset_eqI)
    fix x
    from \<open>?rhs\<close> have "count_of (DAList.impl_of xs) x \<le> count A x"
      by (cases "x \<in> fst ` set (DAList.impl_of xs)") (auto simp add: count_of_empty)
    then show "count (Bag xs) x \<le> count A x" by (simp add: subset_mset_def)
  qed
qed

lemma mset_less_eq_Bag [code]:
  "Bag xs \<subseteq># (A :: 'a multiset) \<longleftrightarrow> (\<forall>(x, n) \<in> set (DAList.impl_of xs). n \<le> count A x)"
proof -
  {
    fix x n
    assume "(x,n) \<in> set (DAList.impl_of xs)"
    then have "count_of (DAList.impl_of xs) x = n"
    proof transfer
      fix x n
      fix xs :: "('a \<times> nat) list"
      show "(distinct \<circ> map fst) xs \<Longrightarrow> (x, n) \<in> set xs \<Longrightarrow> count_of xs x = n"
      proof (induct xs)
        case Nil
        then show ?case by simp
      next
        case (Cons ym ys)
        obtain y m where ym: "ym = (y,m)" by force
        note Cons = Cons[unfolded ym]
        show ?case
        proof (cases "x = y")
          case False
          with Cons show ?thesis
            unfolding ym by auto
        next
          case True
          with Cons(2-3) have "m = n" by force
          with True show ?thesis
            unfolding ym by auto
        qed
      qed
    qed
  }
  then show ?thesis
    unfolding mset_less_eq_Bag0 by auto
qed

declare inter_mset_def [code]
declare union_mset_def [code]
declare mset.simps [code]

fun fold_impl :: "('a \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a \<times> nat) list \<Rightarrow> 'b"
where
  "fold_impl fn e ((a,n) # ms) = (fold_impl fn ((fn a n) e) ms)"
| "fold_impl fn e [] = e"

context
begin

qualified definition fold :: "('a \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a, nat) alist \<Rightarrow> 'b"
  where "fold f e al = fold_impl f e (DAList.impl_of al)"

end

context comp_fun_commute
begin

lemma DAList_Multiset_fold:
  assumes fn: "\<And>a n x. fn a n x = (f a ^^ n) x"
  shows "fold_mset f e (Bag al) = DAList_Multiset.fold fn e al"
  unfolding DAList_Multiset.fold_def
proof (induct al)
  fix ys
  let ?inv = "{xs :: ('a \<times> nat) list. (distinct \<circ> map fst) xs}"
  note cs[simp del] = count_simps
  have count[simp]: "\<And>x. count (Abs_multiset (count_of x)) = count_of x"
    by (rule Abs_multiset_inverse) (simp add: count_of_multiset)
  assume ys: "ys \<in> ?inv"
  then show "fold_mset f e (Bag (Alist ys)) = fold_impl fn e (DAList.impl_of (Alist ys))"
    unfolding Bag_def unfolding Alist_inverse[OF ys]
  proof (induct ys arbitrary: e rule: list.induct)
    case Nil
    show ?case
      by (rule trans[OF arg_cong[of _ "{#}" "fold_mset f e", OF multiset_eqI]])
         (auto, simp add: cs)
  next
    case (Cons pair ys e)
    obtain a n where pair: "pair = (a,n)"
      by force
    from fn[of a n] have [simp]: "fn a n = (f a ^^ n)"
      by auto
    have inv: "ys \<in> ?inv"
      using Cons(2) by auto
    note IH = Cons(1)[OF inv]
    define Ys where "Ys = Abs_multiset (count_of ys)"
    have id: "Abs_multiset (count_of ((a, n) # ys)) = (((+) {# a #}) ^^ n) Ys"
      unfolding Ys_def
    proof (rule multiset_eqI, unfold count)
      fix c
      show "count_of ((a, n) # ys) c =
        count (((+) {#a#} ^^ n) (Abs_multiset (count_of ys))) c" (is "?l = ?r")
      proof (cases "c = a")
        case False
        then show ?thesis
          unfolding cs by (induct n) auto
      next
        case True
        then have "?l = n" by (simp add: cs)
        also have "n = ?r" unfolding True
        proof (induct n)
          case 0
          from Cons(2)[unfolded pair] have "a \<notin> fst ` set ys" by auto
          then show ?case by (induct ys) (simp, auto simp: cs)
        next
          case Suc
          then show ?case by simp
        qed
        finally show ?thesis .
      qed
    qed
    show ?case
      unfolding pair
      apply (simp add: IH[symmetric])
      unfolding id Ys_def[symmetric]
      apply (induct n)
      apply (auto simp: fold_mset_fun_left_comm[symmetric])
      done
  qed
qed

end

context
begin

private lift_definition single_alist_entry :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) alist" is "\<lambda>a b. [(a, b)]"
  by auto

lemma image_mset_Bag [code]:
  "image_mset f (Bag ms) =
    DAList_Multiset.fold (\<lambda>a n m. Bag (single_alist_entry (f a) n) + m) {#} ms"
  unfolding image_mset_def
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, (auto simp: ac_simps)[1])
  fix a n m
  show "Bag (single_alist_entry (f a) n) + m = ((add_mset \<circ> f) a ^^ n) m" (is "?l = ?r")
  proof (rule multiset_eqI)
    fix x
    have "count ?r x = (if x = f a then n + count m x else count m x)"
      by (induct n) auto
    also have "\<dots> = count ?l x"
      by (simp add: single_alist_entry.rep_eq)
    finally show "count ?l x = count ?r x" ..
  qed
qed

end

\<comment> \<open>we cannot use \<open>\<lambda>a n. (+) (a * n)\<close> for folding, since \<open>(*)\<close> is not defined in \<open>comm_monoid_add\<close>\<close>
lemma sum_mset_Bag[code]: "sum_mset (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (((+) a) ^^ n)) 0 ms"
  unfolding sum_mset.eq_fold
  apply (rule comp_fun_commute.DAList_Multiset_fold)
  apply unfold_locales
  apply (auto simp: ac_simps)
  done

\<comment> \<open>we cannot use \<open>\<lambda>a n. (*) (a ^ n)\<close> for folding, since \<open>(^)\<close> is not defined in \<open>comm_monoid_mult\<close>\<close>
lemma prod_mset_Bag[code]: "prod_mset (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (((*) a) ^^ n)) 1 ms"
  unfolding prod_mset.eq_fold
  apply (rule comp_fun_commute.DAList_Multiset_fold)
  apply unfold_locales
  apply (auto simp: ac_simps)
  done

lemma size_fold: "size A = fold_mset (\<lambda>_. Suc) 0 A" (is "_ = fold_mset ?f _ _")
proof -
  interpret comp_fun_commute ?f by standard auto
  show ?thesis by (induct A) auto
qed

lemma size_Bag[code]: "size (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (+) n) 0 ms"
  unfolding size_fold
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, simp)
  fix a n x
  show "n + x = (Suc ^^ n) x"
    by (induct n) auto
qed

lemma set_mset_fold: "set_mset A = fold_mset insert {} A" (is "_ = fold_mset ?f _ _")
proof -
  interpret comp_fun_commute ?f by standard auto
  show ?thesis by (induct A) auto
qed

lemma set_mset_Bag[code]:
  "set_mset (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (if n = 0 then (\<lambda>m. m) else insert a)) {} ms"
  unfolding set_mset_fold
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, (auto simp: ac_simps)[1])
  fix a n x
  show "(if n = 0 then \<lambda>m. m else insert a) x = (insert a ^^ n) x" (is "?l n = ?r n")
  proof (cases n)
    case 0
    then show ?thesis by simp
  next
    case (Suc m)
    then have "?l n = insert a x" by simp
    moreover have "?r n = insert a x" unfolding Suc by (induct m) auto
    ultimately show ?thesis by auto
  qed
qed

instantiation multiset :: (exhaustive) exhaustive
begin

definition exhaustive_multiset ::
  "('a multiset \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
  where "exhaustive_multiset f i = Quickcheck_Exhaustive.exhaustive (\<lambda>xs. f (Bag xs)) i"

instance ..

end

end


theory Dijkstra_Benchmark
imports "../../../Examples/Sepref_Dijkstra"
  Dijkstra_Shortest_Path.Test
begin

definition nat_cr_graph_imp
  :: "nat \<Rightarrow> (nat \<times> nat \<times> nat) list \<Rightarrow> nat graph_impl Heap"
  where "nat_cr_graph_imp \<equiv> cr_graph"

concrete_definition nat_dijkstra_imp uses dijkstra_imp_def[where 'W=nat]
prepare_code_thms nat_dijkstra_imp_def

lemma nat_dijkstra_imp_eq: "nat_dijkstra_imp = dijkstra_imp"
  unfolding dijkstra_imp_def[abs_def] nat_dijkstra_imp_def[abs_def]
  by simp

(*definition nat_dijkstra_imp
  :: "nat \<Rightarrow> nat \<Rightarrow> nat graph_impl \<Rightarrow> ((nat \<times> nat \<times> nat) list \<times> nat) option Heap.array Heap"
  where
  "nat_dijkstra_imp \<equiv> dijkstra_imp"
*)

definition "nat_cr_graph_fun nn es \<equiv> hlg_from_list_nat ([0..<nn], es)"

export_code
  integer_of_nat nat_of_integer

  ran_graph

  nat_cr_graph_fun nat_dijkstra

  nat_cr_graph_imp nat_dijkstra_imp
  in SML_imp module_name Dijkstra
  file \<open>dijkstra_export.sml\<close>

end


theory Blinfun_To_Matrix
  imports
    "Jordan_Normal_Form.Matrix"
    "Perron_Frobenius.HMA_Connect"
    "MDP-Rewards.Blinfun_Util"
begin
unbundle no_vec_syntax
hide_const Finite_Cartesian_Product.vec
hide_type Finite_Cartesian_Product.vec
subsubsection \<open>Gauss Seidel is a Regular Splitting\<close>

abbreviation "mat_inv m \<equiv> the (mat_inverse m)"

lemma all_imp_Max:
  assumes "finite X" "X \<noteq> {}" "\<forall>x \<in> X. P (f x)"
  shows "P (MAX x \<in> X. f x)"
proof -
  have "(MAX x \<in> X. f x) \<in> f ` X"
    using assms
    by auto
  thus ?thesis
    using assms by force
qed

lemma vec_add: "Matrix.vec n (\<lambda>i. f i + g i) = Matrix.vec n f + Matrix.vec n g"
  by auto

lemma vec_scale: "Matrix.vec n (\<lambda>i. r * f i) = r \<cdot>\<^sub>v (Matrix.vec n f)"
  by auto

lift_definition bfun_mat :: "real mat \<Rightarrow> (nat \<Rightarrow>\<^sub>b real) \<Rightarrow> (nat \<Rightarrow>\<^sub>b real)" is "(\<lambda>m v i.
    if i < dim_row m  then (m *\<^sub>v (Matrix.vec (dim_col m) (apply_bfun v))) $ i else 0)"
proof
  fix m :: "real mat" and v
  have "norm(if i < dim_row m then (m *\<^sub>v Matrix.vec (dim_col m) (apply_bfun v)) $v i else 0) \<le>
    (if dim_row m = 0 then 0 else (MAX i \<in> {0..<dim_row m}. \<bar>(m *\<^sub>v Matrix.vec (dim_col m) (apply_bfun v)) $v i\<bar>))" for i
    by (force  simp: Max_ge_iff)
  thus "bounded (range (\<lambda>i. if i < dim_row m then (m *\<^sub>v Matrix.vec (dim_col m) (apply_bfun v)) $v i else 0))"
    by (blast intro!: boundedI)
qed

definition "blinfun_to_mat m n (f :: (nat \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L (nat \<Rightarrow>\<^sub>b _)) =
  Matrix.mat m n (\<lambda>(i, j). f (Bfun (\<lambda>k. if j = k then 1 else 0)) i)"

lemma bounded_mult:
  assumes "bounded ((f :: 'c \<Rightarrow> real) ` X)" "bounded (g ` X)"
  shows "bounded ((\<lambda>x. f x * g x) ` X)"
proof -
  obtain a b :: real where "\<forall>x\<in>X. norm (f x) \<le> a"  "\<forall>x\<in>X. norm (g x) \<le> b"
    using assms  by (auto simp: bounded_iff)
  hence "norm (f x * g x) \<le> a * b" if "x \<in> X" for x
    using that by (auto simp: abs_mult intro!: mult_mono)
  thus ?thesis
    by (fastforce intro!: boundedI)
qed

lift_definition mat_to_blinfun :: "real mat \<Rightarrow>  (nat \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L (nat \<Rightarrow>\<^sub>b real)" is bfun_mat
proof
  show "bfun_mat m (x + y) = bfun_mat m x + bfun_mat m y" for m x y
    by (auto simp: vec_add bfun_mat.rep_eq scalar_prod_add_distrib[of _ "dim_col m"])
  show "bfun_mat m (x *\<^sub>R y) = x *\<^sub>R bfun_mat m y" for m x y
    by (auto simp: vec_scale bfun_mat.rep_eq)
  have aux: "0 \<le> Max (abs ` elements_mat (m::real mat))"  if "0 < dim_row m" "0 < dim_col m" for m
    using that by (auto intro: all_imp_Max abs_le_norm_bfun simp: elements_mat_def)

  have 1: "\<bar>\<Sum>i = 0..<dim_col (m::real mat). m $$ (n, i) * apply_bfun x i\<bar> \<le> (\<Sum>i = 0..<dim_col m. \<bar>m $$ (n, i) * apply_bfun x i\<bar>)" for x m n
    by (rule sum_abs)
  have 2: "(\<Sum>i = 0..<dim_col m. \<bar>(m::real mat) $$ (n, i) * apply_bfun x i\<bar>) \<le> (\<Sum>i = 0..<dim_col m. Max (abs ` elements_mat m) * \<bar>apply_bfun x i\<bar>) " if "n < dim_row m" for x m n
    unfolding abs_mult elements_mat_def using that by (fastforce intro!: mult_right_mono sum_mono Max_ge)
  have 3: "(\<Sum> i = 0..<dim_col m. Max (abs ` elements_mat m) * \<bar>apply_bfun x i\<bar>) \<le> (\<Sum>i = 0..<dim_col m. Max (abs ` elements_mat m) * norm x)" if "n < dim_row m" for x m n
    using that aux by (intro sum_mono) (auto intro!:  mult_left_mono abs_le_norm_bfun )

  have 4: "(\<Sum>i = 0..<dim_col (m::real mat). Max (abs ` elements_mat m) * norm (x :: (_  \<Rightarrow>\<^sub>b _))) = norm x * dim_col m *  Max (abs ` (elements_mat m))" if "n < dim_row m" for n x m
    using that by auto

  have "\<bar>\<Sum>i = 0..<dim_col (m::real mat). m $$ (n, i) * apply_bfun x i\<bar> \<le> norm x * dim_col m *  Max (abs ` (elements_mat m))" if "n < dim_row m" for x m n
    using order.trans[OF order.trans[OF 1 2[OF that]] 3]  that unfolding 4[OF that] by auto
  hence "norm (bfun_mat m x) \<le> norm x * (if (dim_col m = 0 \<or> dim_row m = 0) then 0 else dim_col m * Max (abs ` (elements_mat m)))" for m x
    using aux
    by (auto intro!: cSup_least bfun_eqI simp: norm_bfun_def'[of "bfun_mat _ _"] bfun_mat.rep_eq scalar_prod_def mult.assoc)
  thus "\<exists>K. \<forall>x. norm (bfun_mat m x) \<le> norm x * K" for m
    by auto
qed

lemma mat_to_blinfun_mult: "mat_to_blinfun m (v :: nat \<Rightarrow>\<^sub>b real) i = bfun_mat m v i"
  by (simp add: mat_to_blinfun.rep_eq)

lemma blinfun_to_mat_add_scale: "blinfun_to_mat n m (v + b *\<^sub>R u) = blinfun_to_mat n m v + b \<cdot>\<^sub>m (blinfun_to_mat n m u)"
  unfolding blinfun_to_mat_def blinfun.add_left blinfun.scaleR_left
  by auto

lemma mat_scale_one[simp]: "1 \<cdot>\<^sub>m (m::real mat) = m"
  unfolding smult_mat_def
  by (auto simp: map_mat_def mat_eq_iff)

lemma blinfun_to_mat_add: "(blinfun_to_mat n m (v + u) :: real mat) = blinfun_to_mat n m v + (blinfun_to_mat n m u)"
  using blinfun_to_mat_add_scale[where b = 1]
  by auto

lemma blinfun_to_mat_sub: "(blinfun_to_mat n m (v - u) :: real mat) = blinfun_to_mat n m v - blinfun_to_mat n m u"
   using blinfun_to_mat_add_scale[where b = "-1"]
   by auto

lemma blinfun_to_mat_zero[simp]: "blinfun_to_mat n m 0 = 0\<^sub>m n m"
  by (auto simp: blinfun_to_mat_def)

lemma blinfun_to_mat_scale: "(blinfun_to_mat n m (r *\<^sub>R v) :: real mat) = r \<cdot>\<^sub>m (blinfun_to_mat n m v)"
   using blinfun_to_mat_add_scale[where v = 0, where b = "r"]
   by (auto simp add: blinfun_to_mat_def)

lemma Bfun_if[simp]: "apply_bfun (bfun.Bfun (\<lambda>k. if b k then a else c)) = (\<lambda>k. if b k then a else c)"
  by (auto intro!: Bfun_inverse)

lemma blinfun_to_mat_correct: "blinfun_to_mat (dim_row v) (dim_col v) (mat_to_blinfun v) = v"
    unfolding blinfun_to_mat_def mat_to_blinfun.rep_eq bfun_mat.rep_eq
    by (auto simp: mult_mat_vec_def Matrix.mat_eq_iff scalar_prod_def if_distrib cong: if_cong)

lemma blinfun_to_mat_id: "blinfun_to_mat n n id_blinfun = 1\<^sub>m n"
  by (auto simp: blinfun_to_mat_def)

lemma nonneg_mult_vec_mono:
  assumes "0\<^sub>m (dim_row X) (dim_col X) \<le> X" "v \<le> u" "dim_vec v = dim_col X"
  shows "X *\<^sub>v (v :: real vec) \<le> X *\<^sub>v u"
  using assms
  unfolding Matrix.less_eq_mat_def Matrix.less_eq_vec_def
  by (auto simp: Matrix.scalar_prod_def intro!: sum_mono mult_left_mono)

unbundle no_vec_syntax

lemma nonneg_blinfun_mat: "nonneg_blinfun (mat_to_blinfun M) \<longleftrightarrow> (0\<^sub>m (dim_row M) (dim_col M) \<le> M)"
proof
  assume "nonneg_blinfun (mat_to_blinfun M)"
  hence "v \<ge> 0 \<Longrightarrow> 0 \<le> mat_to_blinfun M v" for v unfolding nonneg_blinfun_def by auto
  hence aux: "v \<ge> 0 \<Longrightarrow> 0 \<le> bfun_mat M v" for v unfolding mat_to_blinfun.rep_eq by auto
  hence aux: "(\<And>x. apply_bfun v x \<ge> 0) \<Longrightarrow> 0 \<le> bfun_mat M v x" for v x  unfolding less_eq_bfun_def by auto

  have "0 \<le> M $$ (i, j)" if "i < dim_row M" and "j < dim_col M" for i j
    using aux[of "Bfun (\<lambda>k. if k = j then 1 else 0)"] that
    unfolding bfun_mat.rep_eq
    by (auto cong: if_cong simp: Matrix.mult_mat_vec_def scalar_prod_def if_distrib)
  thus "0\<^sub>m (dim_row M) (dim_col M) \<le> M"
    unfolding less_eq_mat_def by auto
next
  assume "(0\<^sub>m (dim_row M) (dim_col M) \<le> M)"
  hence "0 \<le> M $$ (i,j)" if "i < dim_row M" and "j < dim_col M" for i j
    unfolding less_eq_mat_def using that by auto
  thus "nonneg_blinfun (mat_to_blinfun M)"
    unfolding nonneg_blinfun_def mat_to_blinfun.rep_eq less_eq_bfun_def bfun_mat.rep_eq
    by (auto simp: scalar_prod_def intro!: sum_nonneg)
qed

lemma mat_row_sub: "X \<in> carrier_mat n m \<Longrightarrow> Y \<in> carrier_mat n m \<Longrightarrow> i < n \<Longrightarrow> Matrix.row (X - Y) i = Matrix.row X i - Matrix.row Y i"
  unfolding Matrix.row_def by auto

lemma mat_to_blinfun_sub: "X \<in> carrier_mat n m \<Longrightarrow> Y \<in> carrier_mat n m \<Longrightarrow> mat_to_blinfun (X - Y) = mat_to_blinfun X - mat_to_blinfun Y"
  by (auto intro!: blinfun_eqI simp: minus_scalar_prod_distrib[of _ m] mat_row_sub mat_to_blinfun.rep_eq blinfun.diff_left bfun_mat.rep_eq)

definition "inverse_mats C D \<longleftrightarrow> (\<exists>n. C \<in> carrier_mat n n \<and> D \<in> carrier_mat n n) \<and> inverts_mat C D \<and> inverts_mat D C"

lemma inverse_mats_sym: "inverse_mats C D \<Longrightarrow> inverse_mats D C"
  unfolding inverse_mats_def by auto

lemma inverse_mats_unique:
  assumes "inverse_mats C D" "inverse_mats C E" shows "D = E"
proof -
  have "D = D * (C * E)"
    using assms unfolding inverse_mats_def inverts_mat_def by auto
  also have "\<dots> = (D * C) * E"
    using assms unfolding inverse_mats_def by auto
  finally show ?thesis
    using assms unfolding inverse_mats_def inverts_mat_def by auto
qed

definition "inverse_mat D = (THE E. inverse_mats D E)"

lemma invertible_mat_iff_inverse: "invertible_mat M \<longleftrightarrow> (\<exists>N. inverse_mats M N)"
proof
  show "invertible_mat M \<Longrightarrow> \<exists>N. inverse_mats M N"
  unfolding invertible_mat_def inverts_mat_def inverse_mats_def
  by (metis carrier_matI index_mult_mat(3) index_one_mat(3) square_mat.elims(2))
  show "\<exists>N. inverse_mats M N \<Longrightarrow> invertible_mat M "
    unfolding inverse_mats_def invertible_mat_def
    by (metis carrier_matD(1) carrier_matD(2)  square_mat.elims(1))
qed

lemma mat_inverse_eq_inverse_mat:
  assumes "D \<in> carrier_mat n n" "invertible_mat (D :: real mat)"
  shows "(mat_inverse D) = Some (inverse_mat D)"
proof (cases "mat_inverse D")
  case None
  have "D \<notin> Units (ring_mat TYPE(real) n n)"
    by (simp add: assms(1) None mat_inverse)
  hence "x * D \<noteq> 1\<^sub>m n \<or> D * x \<noteq> 1\<^sub>m n" if "x\<in>carrier_mat n n" for x
    using assms that by (simp add: Units_def ring_mat_simps)
  hence "\<not>invertible_mat D"
    unfolding invertible_mat_iff_inverse
    by (metis assms(1) carrier_matD(1) inverse_mats_def inverts_mat_def)
  then show ?thesis
    using assms by auto
next
  case (Some a)
  hence "inverse_mats D a"
    using assms(1) mat_inverse(2) unfolding inverse_mats_def inverts_mat_def by auto
  thus ?thesis
    unfolding inverse_mat_def local.Some
    using inverse_mats_unique
    by (auto intro: HOL.the1_equality[symmetric])
qed

lemma invertible_inverse_mats:
  assumes "invertible_mat M"
  shows "inverse_mats M (inverse_mat M)"
  by (metis assms inverse_mat_def inverse_mats_unique invertible_mat_iff_inverse theI_unique)

definition "bfun_to_vec n v = Matrix.vec n (apply_bfun v)"

lemma blinfun_to_mat_mult:
  "(blinfun_to_mat n m A) *\<^sub>v (bfun_to_vec m v) = bfun_to_vec n (A (bfun_if (\<lambda>i. i < m) v 0))"
proof -
  have "(\<Sum>ia = 0..<m. (A (bfun.Bfun (\<lambda>k. if ia = k then 1 else 0))) i * v ia) = (A (bfun_if (\<lambda>k. k < m) v 0)) i" for i
  proof -
  have "(\<Sum>ia = 0..<m. (A (bfun.Bfun (\<lambda>k. if ia = k then 1 else 0))) i * v ia)  =
    (\<Sum>ia = 0..<m. (A (v ia *\<^sub>R bfun.Bfun (\<lambda>k. if ia = k then 1 else 0)) i))"
    by (auto intro!: sum.cong simp add: blinfun.scaleR_right)
  also have "\<dots> = (\<Sum>ia = 0..<m. (A (v ia *\<^sub>R bfun.Bfun (\<lambda>k. if ia = k then 1 else 0)))) i"
    by (induction m) auto
  also have "\<dots> = (A  (\<Sum>ia = 0..<m. (v ia *\<^sub>R bfun.Bfun (\<lambda>k. if ia = k then 1 else 0)))) i"
    unfolding blinfun.sum_right by auto
      also have "\<dots> = blinfun_apply A (bfun_if (\<lambda>k. k < m) v 0) i"
      proof -
        have "(\<Sum>ia = 0..<m. (v ia *\<^sub>R bfun.Bfun (\<lambda>k. if ia = k then 1 else 0))) =
              (\<Sum>i = 0..<m. bfun_if (\<lambda>k. k = i) v 0)"
          by (auto simp: bfun_if.rep_eq intro!: sum.cong)
        also have "\<dots> = bfun_if (\<lambda>k. k < m) v 0"
          by (induction m arbitrary: v) (auto simp add: bfun_eqI bfun_if.rep_eq)
        finally show ?thesis by auto
      qed
      finally show ?thesis.
    qed
    thus ?thesis
  unfolding blinfun_to_mat_def bfun_to_vec_def mult_mat_vec_def scalar_prod_def
  by auto
qed

lemma Max_geI:
  assumes "finite X" "(y::_:: linorder) \<in> X" "x \<le> y" shows "x \<le> Max X"
  using assms Max_ge_iff by auto

lift_definition vec_to_bfun :: "real vec \<Rightarrow> (nat \<Rightarrow>\<^sub>b real)" is
  "\<lambda>v i. if i < dim_vec v then v $ i else 0"
proof -
  fix n and v :: "real vec"
  show "(\<lambda>i. if i < n then v $ i else 0) \<in> bfun"
    by (rule bfun_normI[of _ "if n = 0 then 0 else Max (abs ` (($) v) ` {..<n})"]) (auto intro!: Max_geI)
qed

lemma vec_to_bfun_to_vec[simp]: "bfun_to_vec (dim_vec v) (vec_to_bfun v) = v"
  by (auto simp: bfun_to_vec_def vec_to_bfun.rep_eq)

lemma bfun_to_vec_to_bfun[simp]: "vec_to_bfun (bfun_to_vec m v) = bfun_if (\<lambda>i. i < m) v 0"
  by (auto simp: bfun_to_vec_def vec_to_bfun.rep_eq bfun_if.rep_eq)

lemma bfun_if_vec_to_bfun[simp]: "(bfun_if (\<lambda>i. i < dim_vec v) (vec_to_bfun v) 0) = vec_to_bfun v"
  by (auto simp: bfun_if.rep_eq vec_to_bfun.rep_eq)

lemma blinfun_to_mat_mult':
  shows "(blinfun_to_mat n (dim_vec v) A) *\<^sub>v v = bfun_to_vec n (blinfun_apply A (vec_to_bfun v))"
  using blinfun_to_mat_mult[of n "dim_vec v" A "vec_to_bfun v"]
  by auto

lemma blinfun_to_mat_mult'':
  assumes "m = dim_vec v"
  shows "(blinfun_to_mat n m A) *\<^sub>v v = bfun_to_vec n (blinfun_apply A (vec_to_bfun v))"
  using blinfun_to_mat_mult' assms
  by auto

lemma matrix_eqI:
  fixes A :: "real mat"
  assumes "\<And>v. v \<in> carrier_vec m \<Longrightarrow> A *\<^sub>v v = B *\<^sub>v v" "A \<in> carrier_mat n m" "B \<in> carrier_mat n m"
  shows "A = B"
proof -
  have "A *\<^sub>v Matrix.vec m (\<lambda>j. if i = j then 1 else 0) = Matrix.col A i" "B *\<^sub>v Matrix.vec m (\<lambda>j. if i = j then 1 else 0) = Matrix.col B i"
      if  "i < m" for i
    using assms that
    by (auto simp: mult_mat_vec_def scalar_prod_def if_distrib cong: if_cong)
  thus ?thesis
    using assms
    by (auto intro: Matrix.mat_col_eqI)
qed

lemma blinfun_to_mat_in_carrier[simp]: "blinfun_to_mat m p A \<in> carrier_mat m p"
  unfolding blinfun_to_mat_def
  by auto

lemma blinfun_to_mat_dim_col[simp]: "dim_col (blinfun_to_mat m p A) = p"
  unfolding blinfun_to_mat_def
  by auto

lemma blinfun_to_mat_dim_row[simp]: "dim_row (blinfun_to_mat m p A) = m"
  unfolding blinfun_to_mat_def
  by auto

lemma bfun_to_vec_carrier[simp]: "bfun_to_vec m v \<in> carrier_vec m"
  by (simp add: bfun_to_vec_def)

lemma vec_cong: "(\<And>i. i < n \<Longrightarrow> f i = g i) \<Longrightarrow> vec n f = vec n g"
  by auto

lemma mat_to_blinfun_compose:
  assumes "dim_col A = dim_row B"
  shows "(mat_to_blinfun A o\<^sub>L mat_to_blinfun B) = mat_to_blinfun (A * B)"
proof (intro blinfun_eqI bfun_eqI)
  fix i x
  show "apply_bfun (blinfun_apply (mat_to_blinfun A o\<^sub>L mat_to_blinfun B) i) x = apply_bfun (blinfun_apply (mat_to_blinfun (A * B)) i) x "
  proof (cases "x < dim_row A")
    case True
  have "(mat_to_blinfun A o\<^sub>L mat_to_blinfun B) i x = (bfun_mat A (bfun_mat B i)) x"
    by (auto simp: mat_to_blinfun.rep_eq)
  also have "\<dots> = Matrix.row A x \<bullet> vec (dim_col A) (\<lambda>ia. Matrix.row B ia \<bullet> vec (dim_col B) i)"
    using assms by (auto simp: bfun_mat.rep_eq True cong: vec_cong)
  also have "\<dots> = vec (dim_col B) (\<lambda>j. Matrix.row A x \<bullet> col B j) \<bullet> vec (dim_col B) i"
    using assms by (auto simp add: carrier_vecI assoc_scalar_prod[of _ "dim_col A"])
  also have "\<dots> = Matrix.row (A * B) x \<bullet> vec (dim_col B) (apply_bfun i)"
    by (subst Matrix.row_mult) (auto simp add: assms True)
  also have "\<dots> = mat_to_blinfun (A * B) i x"
    by (simp add: mat_to_blinfun.rep_eq bfun_mat.rep_eq True)
  finally show ?thesis.
qed (simp add: bfun_mat.rep_eq mat_to_blinfun_mult)
qed

lemma blinfun_to_mat_compose:
  fixes A B :: "(nat \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L (nat \<Rightarrow>\<^sub>b real)"
  assumes
    "\<And>v v' j. (\<And>i. i < m \<Longrightarrow> apply_bfun v i = apply_bfun v' i) \<Longrightarrow> j < n \<Longrightarrow> A v j = A v' j"
  shows "blinfun_to_mat n m A * blinfun_to_mat m p B = blinfun_to_mat n p (A o\<^sub>L B)"
proof  (rule matrix_eqI[of p _ _ n])
  fix v :: "real vec"
  assume v[simp, intro]: "v \<in> carrier_vec p"
  hence "blinfun_to_mat n m A * blinfun_to_mat m p B *\<^sub>v v = bfun_to_vec n (A (vec_to_bfun (blinfun_to_mat m p B *\<^sub>v v)))"
    by (auto simp: blinfun_to_mat_mult'' blinfun_to_mat_mult assoc_mult_mat_vec[of _ n m _ p])
  also have "\<dots>  = bfun_to_vec n (A (vec_to_bfun (bfun_to_vec m (B (vec_to_bfun v)))))"
    using v by (fastforce simp: blinfun_to_mat_mult'' dest!: carrier_vecD)+
  also have "\<dots> = bfun_to_vec n ((A o\<^sub>L B) (vec_to_bfun v))"
    unfolding bfun_to_vec_to_bfun
    using assms by (fastforce simp add: bfun_if.rep_eq bfun_to_vec_def intro!: vec_cong)
  also have "\<dots> = blinfun_to_mat n p (A o\<^sub>L B) *\<^sub>v v "
    using v by (fastforce simp: blinfun_to_mat_mult'' dest!: carrier_vecD)+
  finally show "blinfun_to_mat n m A * blinfun_to_mat m p B *\<^sub>v v = blinfun_to_mat n p (A o\<^sub>L B) *\<^sub>v v".
qed auto

lemma invertible_mat_dims: "invertible_mat A \<Longrightarrow> dim_col A = dim_row A"
  by (simp add: invertible_mat_def)

lemma invertible_mat_square: "invertible_mat A \<Longrightarrow> square_mat A"
  by (simp add: invertible_mat_dims)

lemma inverse_mat_dims:
  assumes "invertible_mat A"
  shows "dim_col (inverse_mat A) = dim_col A" "dim_row (inverse_mat A) = dim_row A"
  using assms inverse_mats_def invertible_inverse_mats by auto

lemma inverse_mat_mult[simp]:
  assumes "invertible_mat A"
  shows "inverse_mat A * A = 1\<^sub>m (dim_row A)" "A * inverse_mat A = 1\<^sub>m (dim_row A)"
  using assms invertible_inverse_mats[OF assms] inverse_mat_dims
  unfolding inverts_mat_def inverse_mats_def
  by auto

lemma invertible_mult:
  assumes "invertible_mat m" "dim_vec a = dim_col m" "dim_vec b = dim_col m"
  shows "a = b \<longleftrightarrow> m *\<^sub>v a = m *\<^sub>v b"
proof -
  have "(inverse_mat m * m) *\<^sub>v a = a" "(inverse_mat m * m) *\<^sub>v b = b"
    by (metis assms carrier_vec_dim_vec inverse_mat_mult(1) invertible_mat_dims one_mult_mat_vec)+
  thus ?thesis
    by (metis assms assoc_mult_mat_vec carrier_mat_triv carrier_vec_dim_vec inverse_mat_dims(1) invertible_mat_dims)
qed

lemma inverse_mult_iff:
  assumes "invertible_mat m"
  and "dim_vec v = dim_col m" "dim_vec b = dim_row m"
  shows "v = inverse_mat m *\<^sub>v b \<longleftrightarrow> m *\<^sub>v v = b"
proof -
  have "v = inverse_mat m *\<^sub>v b \<longleftrightarrow> m *\<^sub>v v =  m *\<^sub>v (inverse_mat m *\<^sub>v b)"
    using invertible_mult by (metis assms dim_mult_mat_vec inverse_mat_dims(2) invertible_mat_dims)
  also have "\<dots> \<longleftrightarrow>   m *\<^sub>v v = (m * inverse_mat m) *\<^sub>v b"
    by (subst assoc_mult_mat_vec[of _ "dim_col m" "dim_col m" _ "dim_col m"])
       (auto simp add: assms carrier_vecI inverse_mat_dims invertible_mat_dims)
  also have "\<dots> \<longleftrightarrow> m *\<^sub>v v = b"
    by (metis assms(1) assms(3) carrier_vecI inverse_mat_mult(2) one_mult_mat_vec)
  finally show ?thesis.
qed

lemma inverse_blinfun_to_mat:
  fixes A :: "(nat \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L (nat \<Rightarrow>\<^sub>b real)"
  assumes "invertible\<^sub>L A"
  assumes "(\<And>v v' j. (\<And>i. i < m \<Longrightarrow> apply_bfun v i = apply_bfun v' i) \<Longrightarrow> j < m \<Longrightarrow> (A v) j = (A v') j)"
  assumes "(\<And>v v' j. (\<And>i. i < m \<Longrightarrow> apply_bfun v i = apply_bfun v' i) \<Longrightarrow> j < m \<Longrightarrow> (inv\<^sub>L A v) j = (inv\<^sub>L A v') j)"
  shows "blinfun_to_mat m m (inv\<^sub>L A) = (inverse_mat (blinfun_to_mat m m A))" "invertible_mat (blinfun_to_mat m m A)"
proof -
  have *: "blinfun_to_mat m m A * blinfun_to_mat m m (inv\<^sub>L A) = 1\<^sub>m m"
    by (subst blinfun_to_mat_compose) (fastforce simp:  blinfun_to_mat_id assms(1) intro: assms(2))+
  moreover have **: "blinfun_to_mat m m (inv\<^sub>L A) * blinfun_to_mat m m A = 1\<^sub>m m"
    by (subst blinfun_to_mat_compose) (fastforce simp:   blinfun_to_mat_id assms(1) intro: assms(3))+
  ultimately have ***: "invertible_mat (blinfun_to_mat m m A)"
    by (metis blinfun_to_mat_dim_col blinfun_to_mat_dim_row invertible_mat_def inverts_mat_def square_mat.elims(1))

  have "inverse_mats (blinfun_to_mat m m A) (blinfun_to_mat m m (inv\<^sub>L A))"
    unfolding inverse_mats_def inverts_mat_def using * ** by force
  hence "inverse_mat (blinfun_to_mat m m A) = blinfun_to_mat m m (inv\<^sub>L A)"
    using *** inverse_mats_unique invertible_inverse_mats by blast
  thus "blinfun_to_mat m m (inv\<^sub>L A) = inverse_mat (blinfun_to_mat m m A)" "invertible_mat (blinfun_to_mat m m A)"
    using \<open>invertible_mat (blinfun_to_mat m m A)\<close> by auto
qed

end


theory TopoS_Interface
imports Main "Lib/FiniteGraph" TopoS_Vertices "Lib/TopoS_Util"
begin

section \<open>Security Invariants\<close>
  text\<open>
    A good documentation of this formalization is available in \cite{diekmann2014forte}.
\<close>

  text\<open>
    We define security invariants over a graph.
    The graph corresponds to the network's access control structure.
\<close>

  (*TODO: make datatype!*)
  \<comment> \<open>@{typ "'v"} is the type of the nodes in the graph (hosts in the network).
     @{typ "'a"} is the type of the host attributes.\<close>
  record ('v::vertex, 'a) TopoS_Params =
    node_properties :: "'v::vertex \<Rightarrow> 'a option"

text\<open>
A Security Invariant is defined as locale.

We successively define more and more locales with more and more assumptions.
This clearly depicts which assumptions are necessary to use certain features of a Security Invariant.
In addition, it makes instance proofs of Security Invariants easier, since the lemmas obtained by an (easy, few assumptions) instance proof
can be used for the complicated (more assumptions) instance proofs.

A security Invariant consists of one function: \<open>sinvar\<close>.
Essentially, it is a predicate over the policy (depicted as graph \<open>G\<close> and a host attribute mapping (\<open>nP\<close>)).
\<close>

text \<open>A Security Invariant where the offending flows (flows that invalidate the policy) can be defined and calculated.
No assumptions are necessary for this step.
\<close>
  locale SecurityInvariant_withOffendingFlows =
    fixes sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool" \<comment> \<open>policy @{text "\<Rightarrow>"} host attribute mapping @{text "\<Rightarrow>"} bool\<close>
   begin
    \<comment> \<open>Offending Flows definitions:\<close>
    definition is_offending_flows::"('v \<times> 'v) set \<Rightarrow> 'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool" where
      "is_offending_flows f G nP \<equiv> \<not> sinvar G nP \<and> sinvar (delete_edges G f) nP"

    \<comment> \<open>Above definition is not minimal:\<close>
    definition is_offending_flows_min_set::"('v \<times> 'v) set \<Rightarrow> 'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool" where
      "is_offending_flows_min_set f G nP \<equiv> is_offending_flows f G nP \<and>
        (\<forall> (e1, e2) \<in> f. \<not> sinvar (add_edge e1 e2 (delete_edges G f)) nP)"

    \<comment> \<open>The set of all offending flows.\<close>
    definition set_offending_flows::"'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> ('v \<times> 'v) set set" where
      "set_offending_flows G  nP = {F. F \<subseteq> (edges G) \<and> is_offending_flows_min_set F G nP}"

    text \<open>Some of the @{const set_offending_flows} definition\<close>
    lemma offending_not_empty: "\<lbrakk> F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow> F \<noteq> {}"
     by(auto simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma empty_offending_contra:
       "\<lbrakk> F \<in> set_offending_flows G nP; F = {}\<rbrakk> \<Longrightarrow> False"
     by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma offending_notevalD: "F \<in> set_offending_flows G nP \<Longrightarrow> \<not> sinvar G nP"
     by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma sinvar_no_offending: "sinvar G nP \<Longrightarrow> set_offending_flows G nP = {}"
      by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    theorem removing_offending_flows_makes_invariant_hold:
      "\<forall>F \<in> set_offending_flows G nP. sinvar (delete_edges G F) nP"
      proof(cases "sinvar G nP")
       case True
        hence no_offending: "set_offending_flows G nP = {}" using sinvar_no_offending by simp
        thus "\<forall>F\<in>set_offending_flows G nP. sinvar (delete_edges G F) nP" using empty_iff by simp
       next
       case False thus "\<forall>F\<in>set_offending_flows G nP. sinvar (delete_edges G F) nP"
        by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def graph_ops)
      qed
  corollary valid_without_offending_flows:
  "\<lbrakk> F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow> sinvar (delete_edges G F) nP"
    by(simp add: removing_offending_flows_makes_invariant_hold)

  lemma set_offending_flows_simp:
    "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow>
      set_offending_flows G nP = {F. F \<subseteq> edges G \<and>
        (\<not> sinvar G nP \<and> sinvar \<lparr>nodes = nodes G, edges = edges G - F\<rparr> nP) \<and>
        (\<forall>(e1, e2)\<in>F. \<not> sinvar \<lparr>nodes = nodes G, edges = {(e1, e2)} \<union> (edges G - F)\<rparr> nP)}"
    apply(simp only: set_offending_flows_def is_offending_flows_min_set_def
      is_offending_flows_def delete_edges_simp2 add_edge_def graph.select_convs)
    apply(subgoal_tac "\<And>F e1 e2. F \<subseteq> edges G \<Longrightarrow> (e1, e2) \<in> F \<Longrightarrow> nodes G \<union> {e1, e2} = nodes G")
     apply fastforce
    apply(simp add: wf_graph_def)
    by (metis fst_conv imageI in_mono insert_absorb snd_conv)

   end

print_locale! SecurityInvariant_withOffendingFlows

text\<open>
The locale \<open>SecurityInvariant_withOffendingFlows\<close> has no assumptions about the security invariant \<open>sinvar\<close>.
Undesirable things may happen:
The offending flows can be empty, even for a violated invariant.

We provide an example, the security invariant @{term "(\<lambda>_ _. False)"}.
As host attributes, we simply use the identity function @{const id}.
\<close>
lemma "SecurityInvariant_withOffendingFlows.set_offending_flows (\<lambda>_ _. False) \<lparr> nodes = {''v1''}, edges={} \<rparr> id = {}"
by %invisible (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
  SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)
lemma "SecurityInvariant_withOffendingFlows.set_offending_flows (\<lambda>_ _. False)
  \<lparr> nodes = {''v1'', ''v2''}, edges = {(''v1'', ''v2'')} \<rparr> id = {}"
by %invisible (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
  SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)

text \<open>In general, there exists a @{term sinvar} such that the invariant does not hold and no offending flows exits.\<close>
  lemma "\<exists>sinvar. \<not> sinvar G nP \<and> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP = {}"
  apply(simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
    SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply(rule_tac x="(\<lambda>_ _. False)" in exI)
  apply(simp)
  done

text\<open>Thus, we introduce usefulness properties that prohibits such useless invariants.\<close>
text\<open>We summarize them in an invariant.
It requires the following:
\begin{enumerate}
  \item The offending flows are always defined.
  \item The invariant is monotonic, i.e. prohibiting more is more secure.
  \item And, the (non-minimal) offending flows are monotonic, i.e. prohibiting more solves more security issues.
\end{enumerate}

Later, we will show that is suffices to show that the invariant is monotonic. The other two properties can be derived.
\<close>

  locale SecurityInvariant_preliminaries = SecurityInvariant_withOffendingFlows sinvar
    for sinvar
    +
    assumes
      defined_offending:
      "\<lbrakk> wf_graph G; \<not> sinvar G nP \<rbrakk> \<Longrightarrow> set_offending_flows G nP \<noteq> {}"
    and
      mono_sinvar:
      "\<lbrakk> wf_graph \<lparr> nodes = N, edges = E \<rparr>; E' \<subseteq> E; sinvar \<lparr> nodes = N, edges = E \<rparr> nP \<rbrakk> \<Longrightarrow>
        sinvar \<lparr> nodes = N, edges = E' \<rparr> nP"
    and mono_offending:
      "\<lbrakk> wf_graph G; is_offending_flows ff G nP \<rbrakk> \<Longrightarrow> is_offending_flows (ff \<union> f') G nP"
  begin

  text \<open>
    \begin{small}
    To instantiate a @{const SecurityInvariant_preliminaries}, here are some hints:
    Have a look at the \<open>TopoS_withOffendingFlows.thy\<close> file.
    There is a definition of @{prop sinvar_mono}. It impplies @{prop mono_sinvar} and @{prop mono_offending}
    \<open>apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
    apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])\<close>

    In addition, \<open>SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono]\<close> gives a nice proof rule for
    @{prop defined_offending}

    Basically, \<open>sinvar_mono.\<close> implies almost all assumptions here and is equal to @{prop mono_sinvar}.
    \end{small}
\<close>
  end

subsection\<open>Security Invariants with secure auto-completion of host attribute mappings\<close>

text\<open>
We will now add a new artifact to the Security Invariant.
It is a secure default host attribute, we will use the symbol \<open>\<bottom>\<close>.

The newly introduced Boolean \<open>receiver_violation\<close> tells whether a security violation happens at the sender's or the receiver's side.

The details can be looked up in \cite{diekmann2014forte}.
\<close>

  \<comment> \<open>Some notes about the notation:
          @{term "fst ` F"} means to apply the function @{const "fst"} to the set @{term "F"} element-wise.
          Example: If @{term "F"} is a set of directed edges,
          @{term "F \<subseteq> edges G"}, then @{term "fst ` F"}
          is the set of senders and @{term "snd ` f"} the set of receivers.\<close>

  locale SecurityInvariant = SecurityInvariant_preliminaries sinvar
    for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
    +
    fixes default_node_properties :: "'a" ("\<bottom>")
    and receiver_violation :: "bool"
    assumes
      \<comment> \<open>default value can never fix a security violation.\<close>
      \<comment> \<open>Idea: Assume there is a violation, then there is some offending flow.
        @{text receiver_violation} defines whether the violation happens at the sender's or the receiver's side.
        We call the place of the violation the \emph{offending host}.
        We replace the host attribute of the offending host with the default attribute.
        Giving an offending host, a \emph{secure} default attribute does not change whether the invariant holds.
        I.e.\ this reconfiguration does not remove information, thus preserves all security critical information.
        Thought experiment preliminaries: Can a default configuration ever solve an existing security violation? NO!
        Thought experiment 1: admin forgot to configure host, hence it is handled by default configuration value ...
        Thought experiment 2: new node (attacker) is added to the network. What is its default configuration value ...\<close>
      default_secure:
      "\<lbrakk> wf_graph G; \<not> sinvar G nP; F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
        (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<longrightarrow> \<not> sinvar G (nP(i := \<bottom>))) \<and>
        (receiver_violation \<longrightarrow> i \<in> snd ` F \<longrightarrow> \<not> sinvar G (nP(i := \<bottom>)))"
      and
      default_unique:
      "otherbot \<noteq> \<bottom> \<Longrightarrow>
        \<exists> (G::('v::vertex) graph) nP i F. wf_graph G \<and> \<not> sinvar G nP \<and> F \<in> set_offending_flows G nP \<and>
         sinvar (delete_edges G F) nP \<and>
         (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<and> sinvar G (nP(i := otherbot))) \<and>
         (receiver_violation \<longrightarrow> i \<in> snd ` F \<and> sinvar G (nP(i := otherbot))) "
   begin
    \<comment> \<open>Removes option type, replaces with default host attribute\<close>
    fun node_props :: "('v, 'a) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)" where
    "node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> \<bottom>))"

    definition node_props_formaldef :: "('v, 'a) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)" where
    "node_props_formaldef P \<equiv>
    (\<lambda> i. (if i \<in> dom (node_properties P) then the (node_properties P i) else \<bottom>))"

    lemma node_props_eq_node_props_formaldef: "node_props_formaldef = node_props"
     by(simp add: fun_eq_iff node_props_formaldef_def option.case_eq_if domIff)

    text\<open>
      Checking whether a security invariant holds.
      \begin{enumerate}
        \item check that the policy @{term G} is syntactically valid
        \item check the security invariant @{term sinvar}
      \end{enumerate}
\<close>
    definition eval::"'v graph \<Rightarrow> ('v, 'a) TopoS_Params \<Rightarrow> bool" where
    "eval G P \<equiv> wf_graph G \<and> sinvar G (node_props P)"

    lemma unique_common_math_notation:
    assumes "\<forall>G nP i F. wf_graph (G::('v::vertex) graph) \<and> \<not> sinvar G nP \<and> F \<in> set_offending_flows G nP \<and>
         sinvar (delete_edges G F) nP \<and>
         (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<and>
         (receiver_violation \<longrightarrow> i \<in> snd ` F \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
    shows "otherbot = \<bottom>"
    apply(rule ccontr)
    apply(drule default_unique)
    using assms by blast
   end

print_locale! SecurityInvariant

subsection\<open>Information Flow Security and Access Control\<close>
text\<open>

@{term receiver_violation} defines the offending host. Thus, it defines when the violation happens.

We found that this coincides with the invariant's security strategy.

\begin{description}
\item[ACS] If the violation happens at the sender, we have an access control strategy (\emph{ACS}).
I.e.\ the sender does not have the appropriate rights to initiate the connection.

\item[IFS] If the violation happens at the receiver, we have an information flow security strategy (\emph{IFS})
I.e.\ the receiver lacks the appropriate security level to retrieve the (confidential) information.
The violations happens only when the receiver reads the data.
\end{description}

We refine our @{term SecurityInvariant} locale.
\<close>

subsection \<open>Information Flow Security Strategy (IFS)\<close>
  locale SecurityInvariant_IFS = SecurityInvariant_preliminaries sinvar
      for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
      +
      fixes default_node_properties :: "'a" ("\<bottom>")
      assumes  default_secure_IFS:
        "\<lbrakk> wf_graph G; f \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
          \<forall>i \<in> snd` f. \<not> sinvar G (nP(i := \<bottom>))"
      and
      \<comment> \<open>If some otherbot fulfills @{text default_secure}, it must be @{term "\<bottom>"}
             Hence, @{term "\<bottom>"} is uniquely defined\<close>
      default_unique_IFS:
      "(\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> snd` f
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<Longrightarrow> otherbot = \<bottom>"
      begin
        lemma default_unique_EX_notation: "otherbot \<noteq> \<bottom> \<Longrightarrow>
          \<exists> G nP i f. wf_graph G \<and> \<not> sinvar G nP \<and> f \<in> set_offending_flows G nP \<and>
           sinvar (delete_edges G f) nP \<and>
           (i \<in> snd` f \<and> sinvar G (nP(i := otherbot)))"
          apply(erule contrapos_pp)
          apply(simp)
          using default_unique_IFS SecurityInvariant_withOffendingFlows.valid_without_offending_flows offending_notevalD
          by metis
      end

  sublocale SecurityInvariant_IFS \<subseteq> SecurityInvariant where receiver_violation=True
  apply(unfold_locales)
   apply(simp add: default_secure_IFS)
  apply(simp only: HOL.simp_thms)
  apply(drule default_unique_EX_notation)
  apply(assumption)
  done

  (*other direction*)
  locale SecurityInvariant_IFS_otherDirectrion = SecurityInvariant where receiver_violation=True
  sublocale SecurityInvariant_IFS_otherDirectrion \<subseteq> SecurityInvariant_IFS
  apply(unfold_locales)
   apply (metis default_secure offending_notevalD)
  apply(erule contrapos_pp)
  apply(simp)
  apply(drule default_unique)
  apply(simp)
  apply(blast)
  done

lemma default_uniqueness_by_counterexample_IFS:
  assumes "(\<forall>G F nP i. wf_graph G \<and> F \<in> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP \<and> i \<in> snd` F
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
  and "otherbot \<noteq> default_value \<Longrightarrow>
    \<exists>G nP i F. wf_graph G \<and> \<not> sinvar G nP \<and> F \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP) \<and>
       sinvar (delete_edges G F) nP \<and>
        i \<in> snd ` F \<and> sinvar G (nP(i := otherbot)) "
   shows "otherbot = default_value"
   using assms by blast

subsection \<open>Access Control Strategy (ACS)\<close>
  locale SecurityInvariant_ACS = SecurityInvariant_preliminaries sinvar
      for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
      +
      fixes default_node_properties :: "'a" ("\<bottom>")
      assumes  default_secure_ACS:
        "\<lbrakk> wf_graph G; f \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
          \<forall>i \<in> fst` f. \<not> sinvar G (nP(i := \<bottom>))"
      and
      default_unique_ACS:
      "(\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> fst` f
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<Longrightarrow> otherbot = \<bottom>"
      begin
        lemma default_unique_EX_notation: "otherbot \<noteq> \<bottom> \<Longrightarrow>
          \<exists> G nP i f. wf_graph G \<and> \<not> sinvar G nP \<and> f \<in> set_offending_flows G nP \<and>
           sinvar (delete_edges G f) nP \<and>
           (i \<in> fst` f \<and> sinvar G (nP(i := otherbot)))"
          apply(erule contrapos_pp)
          apply(simp)
          using default_unique_ACS SecurityInvariant_withOffendingFlows.valid_without_offending_flows offending_notevalD
          by metis
      end

  sublocale SecurityInvariant_ACS \<subseteq> SecurityInvariant where receiver_violation=False
  apply(unfold_locales)
   apply(simp add: default_secure_ACS)
  apply(simp only: HOL.simp_thms)
  apply(drule default_unique_EX_notation)
  apply(assumption)
  done

  (*other direction*)
  locale SecurityInvariant_ACS_otherDirectrion = SecurityInvariant where receiver_violation=False
  sublocale SecurityInvariant_ACS_otherDirectrion \<subseteq> SecurityInvariant_ACS
  apply(unfold_locales)
   apply (metis default_secure offending_notevalD)
  apply(erule contrapos_pp)
  apply(simp)
  apply(drule default_unique)
  apply(simp)
  apply(blast)
  done

lemma default_uniqueness_by_counterexample_ACS:
  assumes "(\<forall>G F nP i. wf_graph G \<and> F \<in> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP \<and> i \<in> fst ` F
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
  and "otherbot \<noteq> default_value \<Longrightarrow>
    \<exists>G nP i F. wf_graph G \<and> \<not> sinvar G nP \<and> F \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP) \<and>
       sinvar (delete_edges G F) nP \<and>
        i \<in> fst ` F \<and> sinvar G (nP(i := otherbot))"
  shows "otherbot = default_value"
  using assms by blast

text\<open>The sublocale relationships tell that the simplified @{const SecurityInvariant_ACS} and @{const SecurityInvariant_IFS}
  assumptions suffice to do tho generic SecurityInvariant assumptions.\<close>

end


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

section \<open> Verification components for hybrid systems \<close>

text \<open> A light-weight version of the verification components. We define the forward box
operator to compute weakest liberal preconditions (wlps) of hybrid programs. Then we
introduce three methods for verifying correctness specifications of the continuous
dynamics of a HS. \<close>

theory HS_VC_Spartan
  imports HS_ODEs

begin

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

no_notation Transitive_Closure.rtrancl ("(_\<^sup>*)" [1000] 999)

notation Union ("\<mu>")
     and g_orbital ("(1x\<acute>=_ & _ on _ _ @ _)")

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

text \<open> Lemmas for verification condition generation \<close>

definition fbox :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b pred \<Rightarrow> 'a pred" ("|_] _" [61,81] 82)
  where "|F] P = (\<lambda>s. (\<forall>s'. s' \<in> F s \<longrightarrow> P s'))"

lemma fbox_iso: "P \<le> Q \<Longrightarrow> |F] P \<le> |F] Q"
  unfolding fbox_def by auto

lemma fbox_anti: "\<forall>s. F\<^sub>1 s \<subseteq> F\<^sub>2 s \<Longrightarrow> |F\<^sub>2] P \<le> |F\<^sub>1] P"
  unfolding fbox_def by auto

lemma fbox_invariants:
  assumes "I \<le> |F] I" and "J \<le> |F] J"
  shows "(\<lambda>s. I s \<and> J s) \<le> |F] (\<lambda>s. I s \<and> J s)"
    and "(\<lambda>s. I s \<or> J s) \<le> |F] (\<lambda>s. I s \<or> J s)"
  using assms unfolding fbox_def by auto

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

abbreviation "skip \<equiv> (\<lambda>s. {s})"

lemma fbox_eta[simp]: "fbox skip P = P"
  unfolding fbox_def by simp

\<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 fbox_test[simp]: "(\<lambda>s. ( |\<questiondown>P?] Q) s) = (\<lambda>s. P s \<longrightarrow> Q s)"
  unfolding fbox_def test_def by simp

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

definition vec_upd :: "'a^'n \<Rightarrow> 'n \<Rightarrow> 'a \<Rightarrow> 'a^'n"
  where "vec_upd s i a = (\<chi> j. ((($) s)(i := a)) j)"

lemma vec_upd_eq: "vec_upd s i a = (\<chi> j. if j = i then a else s$j)"
  by (simp add: vec_upd_def)

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 fbox_assign[simp]: "|x ::= e] Q = (\<lambda>s. Q (\<chi> j. ((($) s)(x := (e s))) j))"
  unfolding vec_upd_def assign_def by (subst fbox_def) 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]: "|x ::= ?] P = (\<lambda>s. \<forall>k. P (\<chi> j. if j = x then k else s$j))"
  unfolding fbox_def 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 fbox_choice: "|(\<lambda>s. F s \<union> G s)] P = (\<lambda>s. ( |F] P) s \<and> ( |G] P) s)"
  unfolding fbox_def by auto

lemma le_fbox_choice_iff: "P \<le> |(\<lambda>s. F s \<union> G s)] Q \<longleftrightarrow> P \<le> |F] Q \<and> P \<le> |G] Q"
  unfolding fbox_def by auto

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

definition kcomp :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('b \<Rightarrow> 'c set) \<Rightarrow> ('a  \<Rightarrow> 'c set)" (infixl ";" 75) where
  "F ; G = \<mu> \<circ> \<P> G \<circ> F"

lemma kcomp_eq: "(f ; g) x = \<Union> {g y |y. y \<in> f x}"
  unfolding kcomp_def image_def by auto

lemma fbox_kcomp[simp]: "|G ; F] P = |G] |F] P"
  unfolding fbox_def kcomp_def by auto

lemma hoare_kcomp:
  assumes "P \<le> |G] R" "R \<le> |F] Q"
  shows "P \<le> |G ; F] Q"
  apply(subst fbox_kcomp)
  by (rule order.trans[OF assms(1)]) (rule fbox_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 \<equiv> (\<lambda>s. if P s then X s else Y s)"

lemma fbox_if_then_else[simp]:
  "|IF T THEN X ELSE Y] Q = (\<lambda>s. (T s \<longrightarrow> ( |X] Q) s) \<and> (\<not> T s \<longrightarrow> ( |Y] Q) s))"
  unfolding fbox_def ifthenelse_def by auto

lemma hoare_if_then_else:
  assumes "(\<lambda>s. P s \<and> T s) \<le> |X] Q"
    and "(\<lambda>s. P s \<and> \<not> T s) \<le> |Y] Q"
  shows "P \<le> |IF T THEN X ELSE Y] Q"
  using assms unfolding fbox_def ifthenelse_def by auto

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

definition kpower :: "('a \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a set)"
  where "kpower f n = (\<lambda>s. ((;) f ^^ n) skip s)"

lemma kpower_base:
  shows "kpower f 0 s = {s}" and "kpower f (Suc 0) s = f s"
  unfolding kpower_def by(auto simp: kcomp_eq)

lemma kpower_simp: "kpower f (Suc n) s = (f ; kpower f n) s"
  unfolding kcomp_eq
  apply(induct n)
  unfolding kpower_base
   apply(force simp: subset_antisym)
  unfolding kpower_def kcomp_eq by simp

definition kleene_star :: "('a \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> 'a set)" ("(_\<^sup>*)" [1000] 999)
  where "(f\<^sup>*) s = \<Union> {kpower f n s |n. n \<in> UNIV}"

lemma kpower_inv:
  fixes F :: "'a \<Rightarrow> 'a set"
  assumes "\<forall>s. I s \<longrightarrow> (\<forall>s'. s' \<in> F s \<longrightarrow> I s')"
  shows "\<forall>s. I s \<longrightarrow> (\<forall>s'. s' \<in> (kpower F n s) \<longrightarrow> I s')"
  apply(clarsimp, induct n)
  unfolding kpower_base kpower_simp
   apply(simp_all add: kcomp_eq, clarsimp)
  apply(subgoal_tac "I y", simp)
  using assms by blast

lemma kstar_inv: "I \<le> |F] I \<Longrightarrow> I \<le> |F\<^sup>*] I"
  unfolding kleene_star_def fbox_def
  apply clarsimp
  apply(unfold le_fun_def, subgoal_tac "\<forall>x. I x \<longrightarrow> (\<forall>s'. s' \<in> F x \<longrightarrow> I s')")
  using kpower_inv[of I F] by blast simp

lemma fbox_kstarI:
  assumes "P \<le> I" and "I \<le> Q" and "I \<le> |F] I"
  shows "P \<le> |F\<^sup>*] Q"
proof-
  have "I \<le> |F\<^sup>*] I"
    using assms(3) kstar_inv by blast
  hence "P \<le> |F\<^sup>*] I"
    using assms(1) by auto
  also have "|F\<^sup>*] I \<le> |F\<^sup>*] Q"
    by (rule fbox_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> (F\<^sup>*)"

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

lemma fbox_loopI: "P \<le> I \<Longrightarrow> I \<le> Q \<Longrightarrow> I \<le> |F] I \<Longrightarrow> P \<le> |LOOP F INV I] Q"
  unfolding loopi_def using fbox_kstarI[of "P"] by simp

lemma wp_loopI_break:
  "P \<le> |Y] I \<Longrightarrow> I \<le> |X] I \<Longrightarrow> I \<le> Q \<Longrightarrow> P \<le> |Y ; (LOOP X INV I)] Q"
  by (rule hoare_kcomp, force) (rule fbox_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 "|EVOL \<phi> G U] Q = (\<lambda>s. (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  unfolding g_evol_def g_orbit_eq fbox_def by auto

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

lemma fbox_g_orbital: "|x\<acute>=f & G on U S @ t\<^sub>0] Q =
  (\<lambda>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> Q (X t))"
  unfolding fbox_def g_orbital_eq by (auto simp: fun_eq_iff)

context local_flow
begin

lemma fbox_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 "|x\<acute>= (\<lambda>t. f) & G on U S @ 0] Q =
  (\<lambda> s. s \<in> S \<longrightarrow> (\<forall>t\<in>(U s). (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  apply(unfold fbox_g_orbital fun_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 fbox_g_ode: "|x\<acute>=(\<lambda>t. f) & G on (\<lambda>s. T) S @ 0] Q =
  (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  by (subst fbox_g_ode_subset, simp_all add: init_time interval_time)

lemma fbox_g_ode_ivl: "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> |x\<acute>=(\<lambda>t. f) & G on (\<lambda>s. {0..t}) S @ 0] Q =
  (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  apply(subst fbox_g_ode_subset, simp_all add: subintervalI init_time real_Icc_closed_segment)
  by (auto simp: closed_segment_eq_real_ivl)

lemma fbox_orbit: "|\<gamma>\<^sup>\<phi>] Q = (\<lambda>s. s \<in> S \<longrightarrow> (\<forall> t \<in> T. Q (\<phi> t s)))"
  unfolding orbit_def fbox_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 fbox_g_orbital_guard:
  assumes "H = (\<lambda>s. G s \<and> Q s)"
  shows "|x\<acute>=f & G on U S @ t\<^sub>0] Q = |x\<acute>=f & G on U S @ t\<^sub>0] H "
  unfolding fbox_g_orbital using assms by auto

lemma fbox_g_orbital_inv:
  assumes "P \<le> I" and "I \<le> |x\<acute>=f & G on U S @ t\<^sub>0] I" and "I \<le> Q"
  shows "P \<le> |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 fbox_iso[OF assms(3)])

lemma fbox_diff_inv[simp]:
  "(I \<le> |x\<acute>=f & G on U S @ t\<^sub>0] I) = diff_invariant I f U S t\<^sub>0 G"
  by (auto simp: diff_invariant_def ivp_sols_def fbox_def g_orbital_eq)

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

context local_flow
begin

lemma fbox_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) =
  ((\<lambda>s. s \<in> S \<longrightarrow> I s) = |x\<acute>= (\<lambda>t. f) & (\<lambda>s. True) on U S @ 0] (\<lambda>s. s \<in> S \<longrightarrow> I s))"
  unfolding fbox_diff_inv[symmetric]
  apply(subst fbox_g_ode_subset[OF assms], simp)+
  apply(clarsimp simp: le_fun_def fun_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 fbox_g_odei: "P \<le> I \<Longrightarrow> I \<le> |x\<acute>= f & G on U S @ t\<^sub>0] I \<Longrightarrow> (\<lambda>s. I s \<and> G s) \<le> Q \<Longrightarrow>
  P \<le> |x\<acute>= f & G on U S @ t\<^sub>0 DINV I] Q"
  unfolding g_ode_inv_def
  apply(rule_tac b="|x\<acute>= f & G on U S @ t\<^sub>0] I" in order.trans)
   apply(rule_tac I="I" in fbox_g_orbital_inv, simp_all)
  apply(subst fbox_g_orbital_guard, simp)
  by (rule fbox_iso, force)

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

text \<open> We derive rules of differential dynamic logic (dL). This allows the components to reason
in the style of that logic. \<close>

abbreviation g_dl_ode ::"(('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 "|x\<acute>= f & G] Q =
  (\<lambda>s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  by (subst local_flow.fbox_g_ode_subset[OF assms], auto)

lemma diff_solve_axiom2:
  fixes c::"'a::{heine_borel, banach}"
  shows "|x\<acute>=(\<lambda>s. c) & G] Q =
  (\<lambda>s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s + \<tau> *\<^sub>R c)) \<longrightarrow> Q (s + t *\<^sub>R c))"
  by (subst local_flow.fbox_g_ode_subset[OF line_is_local_flow, of UNIV], auto)

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

lemma diff_weak_axiom1: "( |x\<acute>= f & G on U S @ t\<^sub>0] G) s"
  unfolding fbox_def g_orbital_eq by auto

lemma diff_weak_axiom2: "|x\<acute>= f & G on T S @ t\<^sub>0] Q = |x\<acute>= f & G on T S @ t\<^sub>0] (\<lambda>s. G s \<longrightarrow> Q s)"
  unfolding fbox_g_orbital image_def by force

lemma diff_weak_rule: "G \<le> Q \<Longrightarrow> P \<le> |x\<acute>= f & G on T S @ t\<^sub>0] Q"
  by(auto intro: g_orbitalD simp: le_fun_def g_orbital_eq fbox_def)

lemma fbox_g_orbital_eq_univD:
  assumes "|x\<acute>= f & G on U S @ t\<^sub>0] C = (\<lambda>s. True)"
    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>s'. s' \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s \<longrightarrow> C s'"
    using assms(1) unfolding fbox_def by meson
  ultimately show "C (x \<tau>)"
    by blast
qed

lemma diff_cut_axiom:
  assumes "|x\<acute>= f & G on U S @ t\<^sub>0] C = (\<lambda>s. True)"
  shows "|x\<acute>= f & G on U S @ t\<^sub>0] Q = |x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0] Q"
proof(rule_tac f="\<lambda> x. |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 U 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 fbox_def by meson
    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> 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 fbox_C: "P \<le> |x\<acute>= f & G on U S @ t\<^sub>0] C"
    and fbox_Q: "P \<le> |x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0] Q"
  shows "P \<le> |x\<acute>= f & G on U S @ t\<^sub>0] Q"
proof(subst fbox_def, subst g_orbital_eq, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s assume "P s" 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 fbox_C \<open>P s\<close> by (subst (asm) fbox_def, 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 "Q (X t)"
    using \<open>P s\<close> fbox_Q by (subst (asm) fbox_def) 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 "( |x\<acute>= f & G] I) s"
  using assms unfolding fbox_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 "|x\<acute>= f & G] I = |(\<lambda>s. {x. s = x \<and> G s})] I"
proof(unfold fbox_g_orbital, subst fbox_def, clarsimp simp: fun_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> I" and "diff_invariant I f U S t\<^sub>0 G" and "I \<le> Q"
  shows "P \<le> |x\<acute>= f & G on U S @ t\<^sub>0] Q"
  apply(rule fbox_g_orbital_inv[OF assms(1) _ assms(3)])
  unfolding fbox_diff_inv using assms(2) .

end


theory Scratch
imports Main
begin

lemma \<open>\<forall>x. P x\<close>
  oops

text \<open>This is another test.
  There are multiple things to do.
  \<close>

notepad
begin
  fix S T :: 'a
  have \<open>T = S\<close>
    if \<open>S = T\<close>
    for S
    using that
    by auto

  have \<open>T = S\<close>
    if \<open>S = T\<close>
    for S
    unfolding that
    by auto
end

datatype finite_type = A | B

instantiation finite_type :: finite
begin
lemma UNIV_finite_type: \<open>UNIV = {A, B}\<close>
  apply auto
  using finite_type.exhaust by blast

instance
  apply standard
  unfolding UNIV_finite_type
  apply auto
  done
end

proposition
  fixes x
  assumes
    \<open>P x\<close> and
    \<open>Q x\<close>
  obtains y z where
    \<open>y = P x\<close> and
    \<open>z = Q x\<close> and
    \<open>True\<close>
  using TrueI
  oops

lemma \<open>P x\<close>
proof -
  have \<open>P x\<close>
    if \<open>P x\<close>
    for x
  proof -
    have \<open>P x\<close>
      if \<open>P x\<close>
      for x
      by (use that in auto)
    have \<open>True\<close>
      by auto
    show ?thesis
      using that by auto
  qed
  then show \<open>?thesis\<close>
    oops

lemma \<open>True\<close>
  ..

lemma \<open>P x\<close> if \<open>P x\<close>
proof -
  show \<open>P x\<close>
    by (use that in auto)
qed

lemma \<open>P x\<close> for x :: \<open>nat list\<close>
proof (induction x)
  case Nil
  then show ?case sorry
next
  case (Cons a x)
  have H: \<open>P \<Longrightarrow> P\<close> for P
    by auto
  show ?case
    apply -
    apply (rule H)
    sorry
qed

lemma \<open>P x\<close> for x :: \<open>nat list\<close>
proof -
  show \<open>P x\<close> for x
  proof (induction x)
    case Nil
    then show ?case sorry
  next
    case (Cons a x)
    then show ?case sorry
  qed
qed

section \<open>There is more\<close>
subsection \<open>Indented to the right\<close>

notepad
begin
  have P if "P ==> P" for P
    apply (rule that)
    subgoal sorry
    done
end

lemma name_with_boundary: \<open>P \<Longrightarrow> P\<close>
  by auto

lemma \<open>P \<Longrightarrow> P\<close>
  apply (rule
    name_with_boundary)
  oops

section \<open>Known indentation bugs\<close>
notepad
begin
  have P if "P \<Longrightarrow> P" "P" for P
    apply (rule that)
    subgoal apply (rule that(2))
    done \<comment> \<open>This done is wrong, but I cannot fix it without knowdegde from the goals.\<close>
    done
end

text \<open>The labels in the following predicate is wrongly indented, but jEdit is not better:\<close>
inductive rtranclp :: \<open>('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool\<close> for r :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> where
  base:
  \<open>rtranclp r a a\<close> |
  step:
  \<open>rtranclp r a c\<close>
  if
    \<open>r a b\<close>
    \<open>rtranclp r b c\<close>

section \<open>Test part\<close>

lemma False
  by auto

lemma True
  by simp

lemma True
  by simp

end