theory MainTheorems
imports PathLemmas
begin

context LocalLexing begin

theorem \<II>_is_generated_by_\<PP>: "\<II> = Gen \<PP>"
proof -
  have "wellformed_items (\<I> (length Doc))"
    using wellformed_items_\<I> by auto
  then have "\<And> x. x \<in> \<I> (length Doc) \<Longrightarrow> item_end x \<le> length Doc"
    using wellformed_item_def wellformed_items_def by blast
  then have "\<I> (length Doc) \<subseteq> items_le (length Doc) (\<I> (length Doc))"
    by (auto simp only: items_le_def)
  then have "\<I> (length Doc) = items_le (length Doc) (\<I> (length Doc))"
    using items_le_is_filter by blast
  then have \<II>_altdef: "\<II> = items_le (length Doc) (\<I> (length Doc))" using \<II>_def by auto
  have "\<And> p. p \<in> (\<Q> (length Doc)) \<Longrightarrow> charslength p \<le> length Doc"
    using \<PP>_are_doc_tokens \<PP>_def doc_tokens_length by auto
  then have "\<Q> (length Doc) \<subseteq> paths_le (length Doc) (\<Q> (length Doc))"
    by (auto simp only: paths_le_def)
  then have "\<Q> (length Doc) = paths_le (length Doc) (\<Q> (length Doc))"
    using paths_le_is_filter by blast
  then have \<PP>_altdef: "\<PP> = paths_le (length Doc) (\<Q> (length Doc))" using \<PP>_def by auto
  show ?thesis using \<II>_altdef \<PP>_altdef thmD14 by auto
qed

definition finished_item :: "symbol list \<Rightarrow> item"
where
  "finished_item \<alpha> = Item (\<SS>, \<alpha>) (length \<alpha>) 0 (length Doc)"

lemma item_rule_finished_item[simp]: "item_rule (finished_item \<alpha>) = (\<SS>, \<alpha>)"
  by (simp add: finished_item_def)

lemma item_origin_finished_item[simp]: "item_origin (finished_item \<alpha>) = 0"
  by (simp add: finished_item_def)

lemma item_end_finished_item[simp]: "item_end (finished_item \<alpha>) = length Doc"
  by (simp add: finished_item_def)

lemma item_dot_finished_item[simp]: "item_dot (finished_item \<alpha>) = length \<alpha>"
  by (simp add: finished_item_def)

lemma item_rhs_finished_item[simp]: "item_rhs (finished_item \<alpha>) = \<alpha>"
  by (simp add: finished_item_def)

lemma item_\<alpha>_finished_item[simp]: "item_\<alpha> (finished_item \<alpha>) = \<alpha>"
  by (simp add: finished_item_def item_\<alpha>_def)

lemma item_nonterminal_finished_item[simp]: "item_nonterminal (finished_item \<alpha>) = \<SS>"
  by (simp add: finished_item_def item_nonterminal_def)

lemma Derives1_of_singleton:
  assumes "Derives1 [N] i r \<alpha>"
  shows "i = 0 \<and> r = (N, \<alpha>)"
proof -
  from assms have "i = 0" using Derives1_bound
    using length_Cons less_Suc0 list.size(3) by fastforce
  then show ?thesis using assms
    using Derives1_def append_Cons append_self_conv append_self_conv2 length_0_conv
      list.inject by auto
qed

definition pvalid_with :: "tokens \<Rightarrow> item \<Rightarrow> nat \<Rightarrow> symbol list \<Rightarrow> bool"
where
  "pvalid_with p x u \<gamma> =
     (wellformed_tokens p \<and>
     wellformed_item x \<and>
     u \<le> length p \<and>
     charslength p = item_end x \<and>
     charslength (take u p) = item_origin x \<and>
     is_derivation (terminals (take u p) @ [item_nonterminal x] @ \<gamma>) \<and>
     derives (item_\<alpha> x) (terminals (drop u p)))"

lemma pvalid_with: "pvalid p x = (\<exists> u \<gamma>. pvalid_with p x u \<gamma>)"
  using pvalid_def pvalid_with_def by blast

theorem Completeness:
  assumes p_in_ll: "p \<in> ll"
  shows "\<exists> \<alpha>. pvalid_with p (finished_item \<alpha>) 0 [] \<and> finished_item \<alpha> \<in> \<II>"
proof -
  have p: "p \<in> \<PP> \<and> charslength p = length Doc \<and> terminals p \<in> \<L>"
    using p_in_ll ll_def by auto
  then have derives_p: "derives [\<SS>] (terminals p)"
    using \<L>_def is_derivation_def mem_Collect_eq by blast
  then have "\<exists> D. Derivation [\<SS>] D (terminals p)"
    by (simp add: derives_implies_Derivation)
  then obtain D where D: "Derivation [\<SS>] D (terminals p)" by blast
  have is_word_p: "is_word (terminals p)"  using leftlang p by blast
  have not_is_word_\<SS>: "\<not> (is_word [\<SS>])" using is_nonterminal_startsymbol is_terminal_nonterminal
    is_word_cons by blast
  have "D \<noteq> []" using D is_word_p not_is_word_\<SS> using Derivation.simps(1) by force
  then have "\<exists> d D'. D = d#D'" using D Derivation.elims(2) by blast
  then obtain d D' where d: "D = d#D'" by blast
  have "\<exists> \<alpha>. Derives1 [\<SS>] (fst d) (snd d) \<alpha> \<and> derives \<alpha> (terminals p)"
    using d D Derivation.simps(2) Derivation_implies_derives by blast
  then obtain \<alpha> where \<alpha>: "Derives1 [\<SS>] (fst d) (snd d) \<alpha> \<and> derives \<alpha> (terminals p)" by blast
  then have snd_d_in_\<RR>: "snd d \<in> \<RR>" using Derives1_rule by blast
  with \<alpha> have snd_d: "snd d = (\<SS>, \<alpha>)" using Derives1_of_singleton by blast
  have wellformed_p: "wellformed_tokens p" by (simp add: \<PP>_wellformed p)
  have wellformed_finished_item: "wellformed_item (finished_item \<alpha>)"
    apply (auto simp add: wellformed_item_def)
    using snd_d snd_d_in_\<RR> by metis
  have pvalid_with: "pvalid_with p (finished_item \<alpha>) 0 []"
    apply (auto simp add: pvalid_with_def)
    using wellformed_p apply blast
    using wellformed_finished_item apply blast
    using p apply (simp add: finished_item_def)
    apply (simp add: is_derivation_def)
    by (simp add: \<alpha>)
  then have "pvalid p (finished_item \<alpha>)" using pvalid_def pvalid_with_def by blast
  then have "finished_item \<alpha> \<in> Gen \<PP>" using Gen_def mem_Collect_eq p by blast
  then have "finished_item \<alpha> \<in> \<II>" using \<II>_is_generated_by_\<PP> by blast
  with pvalid_with show ?thesis by blast
qed

theorem Soundness:
  assumes finished_item_\<alpha>: "finished_item \<alpha> \<in> \<II>"
  shows "\<exists> p. pvalid_with p (finished_item \<alpha>) 0 [] \<and> p \<in> ll"
proof -
  have "finished_item \<alpha> \<in> Gen \<PP>"
    using \<II>_is_generated_by_\<PP> finished_item_\<alpha> by auto
  then obtain p where p: "p \<in> \<PP> \<and> pvalid p (finished_item \<alpha>)"
    using Gen_implies_pvalid by blast
  have pvalid_p_finished_item: "pvalid  p (finished_item \<alpha>)" using p by blast
  from iffD1[OF pvalid_def this, simplified] obtain r \<gamma> where pvalid:
    "wellformed_tokens p \<and>
     wellformed_item (finished_item \<alpha>) \<and>
     r \<le> length p \<and>
     length (chars p) = length Doc \<and>
     chars (take r p) = [] \<and>
     is_derivation (take r (terminals p) @ \<SS> # \<gamma>) \<and> derives \<alpha> (drop r (terminals p))"
     by  blast
  have "item_rule (finished_item \<alpha>) \<in> \<RR>" using pvalid
    using wellformed_item_def by blast
  then have "(\<SS>, \<alpha>) \<in> \<RR>" by simp
  then have is_derivation_\<alpha>: "is_derivation \<alpha>" by (simp add: is_derivation_def leftderives_rule)
  have drop_r_p_in_\<PP>: "drop r p \<in> \<PP>"
    apply (rule drop_empty_tokens)
    using p apply blast
    using pvalid apply blast
    using pvalid apply simp
    by (metis append_Nil2 derives_trans is_derivation_\<alpha> is_derivation_def
      is_derivation_implies_admissible is_word_terminals_drop pvalid terminals_drop)
  then have in_ll: "drop r p \<in> ll"
    apply (auto simp add: ll_def)
    apply (metis append_Nil append_take_drop_id chars_append pvalid)
    using is_derivation_\<alpha> pvalid
    by (metis (no_types, lifting) \<L>_def derives_trans is_derivation_def
      is_word_terminals_drop mem_Collect_eq terminals_drop)
  have "pvalid_with (drop r p) (finished_item \<alpha>) 0 []"
    apply (auto simp add: pvalid_with_def)
    using \<PP>_wellformed drop_r_p_in_\<PP> apply blast
    using pvalid apply blast
    apply (metis append_Nil append_take_drop_id chars_append pvalid)
    apply (simp add: is_derivation_def)
    using pvalid by blast
  with in_ll show ?thesis by auto
qed

lemma is_finished_and_finished_item:
  assumes wellformed_x: "wellformed_item x"
  shows "is_finished x = (\<exists> \<alpha>. x = finished_item \<alpha>)"
proof -
  {
    assume is_finished_x: "is_finished x"
    obtain \<alpha> where \<alpha>: "\<alpha> = item_rhs x" by blast
    have "x = finished_item \<alpha>"
      apply (rule item.expand)
      apply auto
      using \<alpha> is_finished_def is_finished_x item_nonterminal_def item_rhs_def apply auto[1]
      using \<alpha> assms is_complete_def is_finished_def is_finished_x wellformed_item_def apply auto[1]
      using is_finished_def is_finished_x apply blast
      using is_finished_def is_finished_x by auto
    then have "\<exists> \<alpha>. x = finished_item \<alpha>" by blast
  }
  note left_implies_right = this
  {
    assume "\<exists> \<alpha>. x = finished_item \<alpha>"
    then obtain \<alpha> where \<alpha>: "x = finished_item \<alpha>" by blast
    have "is_finished x" by (simp add: \<alpha> is_finished_def is_complete_def)
  }
  note right_implies_left = this
  show ?thesis using left_implies_right right_implies_left by blast
qed

theorem Correctness:
  shows "(ll \<noteq> {}) = earley_recognised"
proof -
  have 1: "(ll \<noteq> {}) = (\<exists> \<alpha>. finished_item \<alpha> \<in> \<II>)"
    using Soundness Completeness ex_in_conv by fastforce
  have 2: "(\<exists> \<alpha>. finished_item \<alpha> \<in> \<II>) = (\<exists> x \<in> \<II>. is_finished x)"
    using \<II>_def is_finished_and_finished_item wellformed_items_\<I> wellformed_items_def by auto
  show ?thesis using earley_recognised_def 1 2 by blast
qed

end

end


(*** This file is part of Lem.  eth-isabelle project just uses it.  See lem-license. ***)

chapter {* Generated by Lem from list.lem. *}

theory "Lem_list"

imports
 	 Main
	 "Lem_bool"
	 "Lem_maybe"
	 "Lem_basic_classes"
	 "Lem_function"
	 "Lem_tuple"
	 "Lem_num"
	 "Lem"

begin

(*open import Bool Maybe Basic_classes Function Tuple Num*)

(*open import {coq} `Coq.Lists.List`*)
(*open import {isabelle} `$LIB_DIR/Lem`*)
(*open import {hol} `lemTheory` `listTheory` `rich_listTheory` `sortingTheory`*)

(* ========================================================================== *)
(* Basic list functions                                                       *)
(* ========================================================================== *)

(* The type of lists as well as list literals like [], [1;2], ... are hardcoded.
   Thus, we can directly dive into derived definitions. *)

(* ----------------------- *)
(* cons                    *)
(* ----------------------- *)

(*val :: : forall 'a. 'a -> list 'a -> list 'a*)

(* ----------------------- *)
(* Emptyness check         *)
(* ----------------------- *)

(*val null : forall 'a. list 'a -> bool*)
(*let null l=  match l with [] -> true | _ -> false end*)

(* ----------------------- *)
(* Length                  *)
(* ----------------------- *)

(*val length : forall 'a. list 'a -> nat*)
(*let rec length l=
  match l with
    | [] -> 0
    | x :: xs -> (Instance_Num_NumAdd_nat.+) (length xs) 1
  end*)

(* ----------------------- *)
(* Equality                *)
(* ----------------------- *)

(*val listEqual : forall 'a. Eq 'a => list 'a -> list 'a -> bool*)
(*val listEqualBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*)

fun  listEqualBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " listEqualBy eq ([]) ([]) = ( True )"
|" listEqualBy eq ([]) (_ # _) = ( False )"
|" listEqualBy eq (_ # _) ([]) = ( False )"
|" listEqualBy eq (x # xs) (y # ys) = ( (eq x y \<and> listEqualBy eq xs ys))"
declare listEqualBy.simps [simp del]

(* ----------------------- *)
(* compare                 *)
(* ----------------------- *)

(*val lexicographicCompare : forall 'a. Ord 'a => list 'a -> list 'a -> ordering*)
(*val lexicographicCompareBy : forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a -> ordering*)

fun  lexicographicCompareBy  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> ordering "  where
     " lexicographicCompareBy cmp ([]) ([]) = ( EQ )"
|" lexicographicCompareBy cmp ([]) (_ # _) = ( LT )"
|" lexicographicCompareBy cmp (_ # _) ([]) = ( GT )"
|" lexicographicCompareBy cmp (x # xs) (y # ys) = ( (
      (case  cmp x y of
          LT => LT
        | GT => GT
        | EQ => lexicographicCompareBy cmp xs ys
      )
    ))"
declare lexicographicCompareBy.simps [simp del]

(*val lexicographicLess : forall 'a. Ord 'a => list 'a -> list 'a -> bool*)
(*val lexicographicLessBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*)
fun  lexicographicLessBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " lexicographicLessBy less1 less_eq1 ([]) ([]) = ( False )"
|" lexicographicLessBy less1 less_eq1 ([]) (_ # _) = ( True )"
|" lexicographicLessBy less1 less_eq1 (_ # _) ([]) = ( False )"
|" lexicographicLessBy less1 less_eq1 (x # xs) (y # ys) = ( ((less1 x y) \<or> ((less_eq1 x y) \<and> (lexicographicLessBy less1 less_eq1 xs ys))))"
declare lexicographicLessBy.simps [simp del]

(*val lexicographicLessEq : forall 'a. Ord 'a => list 'a -> list 'a -> bool*)
(*val lexicographicLessEqBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*)
fun  lexicographicLessEqBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " lexicographicLessEqBy less1 less_eq1 ([]) ([]) = ( True )"
|" lexicographicLessEqBy less1 less_eq1 ([]) (_ # _) = ( True )"
|" lexicographicLessEqBy less1 less_eq1 (_ # _) ([]) = ( False )"
|" lexicographicLessEqBy less1 less_eq1 (x # xs) (y # ys) = ( (less1 x y \<or> (less_eq1 x y \<and> lexicographicLessEqBy less1 less_eq1 xs ys)))"
declare lexicographicLessEqBy.simps [simp del]

definition instance_Basic_classes_Ord_list_dict  :: " 'a Ord_class \<Rightarrow>('a list)Ord_class "  where
     " instance_Basic_classes_Ord_list_dict dict_Basic_classes_Ord_a = ((|

  compare_method = (lexicographicCompareBy
  (compare_method   dict_Basic_classes_Ord_a)),

  isLess_method = (lexicographicLessBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a)),

  isLessEqual_method = (lexicographicLessEqBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a)),

  isGreater_method = (\<lambda> x y. (lexicographicLessBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a) y x)),

  isGreaterEqual_method = (\<lambda> x y. (lexicographicLessEqBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a) y x))|) )"

(* ----------------------- *)
(* Append                  *)
(* ----------------------- *)

(*val ++ : forall 'a. list 'a -> list 'a -> list 'a*) (* originally append *)
(*let rec ++ xs ys=  match xs with
                     | [] -> ys
                     | x :: xs' -> x :: (xs' ++ ys)
                   end*)

(* ----------------------- *)
(* snoc                    *)
(* ----------------------- *)

(*val snoc : forall 'a. 'a -> list 'a -> list 'a*)
(*let snoc e l=  l ++ [e]*)

(* ----------------------- *)
(* Reverse                 *)
(* ----------------------- *)

(* First lets define the function [reverse_append], which is
   closely related to reverse. [reverse_append l1 l2] appends the list [l2] to the reverse of [l1].
   This can be implemented more efficienctly than appending and is
   used to implement reverse. *)

(*val reverseAppend : forall 'a. list 'a -> list 'a -> list 'a*) (* originally named rev_append *)
(*let rec reverseAppend l1 l2=  match l1 with
                                | [] -> l2
                                | x :: xs -> reverseAppend xs (x :: l2)
                               end*)

(* Reversing a list *)
(*val reverse : forall 'a. list 'a -> list 'a*) (* originally named rev *)
(*let reverse l=  reverseAppend l []*)

(* ----------------------- *)
(* Map                     *)
(* ----------------------- *)

(*val map_tr : forall 'a 'b. list 'b -> ('a -> 'b) -> list 'a -> list 'b*)
function (sequential,domintros)  map_tr  :: " 'b list \<Rightarrow>('a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> 'b list "  where
     " map_tr rev_acc f ([]) = ( List.rev rev_acc )"
|" map_tr rev_acc f (x # xs) = ( map_tr ((f x) # rev_acc) f xs )"
by pat_completeness auto

(* taken from: https://blogs.janestreet.com/optimizing-list-map/ *)
(*val count_map : forall 'a 'b. ('a -> 'b) -> list 'a -> nat -> list 'b*)
function (sequential,domintros)  count_map  :: "('a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'b list "  where
     " count_map f ([]) ctr = ( [])"
|" count_map f (hd1 # tl1) ctr = ( f hd1 #
    (if ctr <( 5000 :: nat) then count_map f tl1 (ctr +( 1 :: nat))
    else map_tr [] f tl1))"
by pat_completeness auto

(*val map : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*)
(*let map f l=  count_map f l 0*)

(* ----------------------- *)
(* Reverse Map             *)
(* ----------------------- *)

(*val reverseMap : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*)

(* ========================================================================== *)
(* Folding                                                                    *)
(* ========================================================================== *)

(* ----------------------- *)
(* fold left               *)
(* ----------------------- *)

(*val foldl : forall 'a 'b. ('a -> 'b -> 'a) -> 'a -> list 'b -> 'a*) (* originally foldl *)

(*let rec foldl f b l=  match l with
  | []      -> b
  | x :: xs -> foldl f (f b x) xs
end*)

(* ----------------------- *)
(* fold right              *)
(* ----------------------- *)

(*val foldr : forall 'a 'b. ('a -> 'b -> 'b) -> 'b -> list 'a -> 'b*) (* originally foldr with different argument order *)
(*let rec foldr f b l=  match l with
  | []      -> b
  | x :: xs -> f x (foldr f b xs)
end*)

(* ----------------------- *)
(* concatenating lists     *)
(* ----------------------- *)

(*val concat : forall 'a. list (list 'a) -> list 'a*) (* before also called flatten *)
(*let concat=  foldr (++) []*)

(* -------------------------- *)
(* concatenating with mapping *)
(* -------------------------- *)

(*val concatMap : forall 'a 'b. ('a -> list 'b) -> list 'a -> list 'b*)

(* ------------------------- *)
(* universal qualification   *)
(* ------------------------- *)

(*val all : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally for_all *)
(*let all P l=  foldl (fun r e -> P e && r) true l*)

(* ------------------------- *)
(* existential qualification *)
(* ------------------------- *)

(*val any : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally exist *)
(*let any P l=  foldl (fun r e -> P e || r) false l*)

(* ------------------------- *)
(* dest_init                 *)
(* ------------------------- *)

(* get the initial part and the last element of the list in a safe way *)

(*val dest_init : forall 'a. list 'a -> maybe (list 'a * 'a)*)

fun  dest_init_aux  :: " 'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list*'a "  where
     " dest_init_aux rev_init last_elem_seen ([]) = ( (List.rev rev_init, last_elem_seen))"
|" dest_init_aux rev_init last_elem_seen (x # xs) = ( dest_init_aux (last_elem_seen # rev_init) x xs )"
declare dest_init_aux.simps [simp del]

fun dest_init  :: " 'a list \<Rightarrow>('a list*'a)option "  where
     " dest_init ([]) = ( None )"
|" dest_init (x # xs) = ( Some (dest_init_aux [] x xs))"
declare dest_init.simps [simp del]

(* ========================================================================== *)
(* Indexing lists                                                             *)
(* ========================================================================== *)

(* ------------------------- *)
(* index / nth with maybe   *)
(* ------------------------- *)

(*val index : forall 'a. list 'a -> nat -> maybe 'a*)

(*let rec index l n=  match l with
  | []      -> Nothing
  | x :: xs -> if (Instance_Basic_classes_Eq_nat.=) n 0 then Just x else index xs ((Instance_Num_NumMinus_nat.-)n 1)
end*)

(* ------------------------- *)
(* findIndices               *)
(* ------------------------- *)

(* [findIndices P l] returns the indices of all elements of list [l] that satisfy predicate [P].
   Counting starts with 0, the result list is sorted ascendingly *)
(*val findIndices : forall 'a. ('a -> bool) -> list 'a -> list nat*)

fun  findIndices_aux  :: " nat \<Rightarrow>('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow>(nat)list "  where
     " findIndices_aux (i::nat) P ([]) = ( [])"
|" findIndices_aux (i::nat) P (x # xs) = ( if P x then i # findIndices_aux (i +( 1 :: nat)) P xs else findIndices_aux (i +( 1 :: nat)) P xs )"
declare findIndices_aux.simps [simp del]

(*let findIndices P l=  findIndices_aux 0 P l*)

(* ------------------------- *)
(* findIndex                 *)
(* ------------------------- *)

(* findIndex returns the first index of a list that satisfies a given predicate. *)
(*val findIndex : forall 'a. ('a -> bool) -> list 'a -> maybe nat*)
(*let findIndex P l=  match findIndices P l with
  | [] -> Nothing
  | x :: _ -> Just x
end*)

(* ------------------------- *)
(* elemIndices               *)
(* ------------------------- *)

(*val elemIndices : forall 'a. Eq 'a => 'a -> list 'a -> list nat*)

(* ------------------------- *)
(* elemIndex                 *)
(* ------------------------- *)

(*val elemIndex : forall 'a. Eq 'a => 'a -> list 'a -> maybe nat*)

(* ========================================================================== *)
(* Creating lists                                                             *)
(* ========================================================================== *)

(* ------------------------- *)
(* genlist                   *)
(* ------------------------- *)

(* [genlist f n] generates the list [f 0; f 1; ... (f (n-1))] *)
(*val genlist : forall 'a. (nat -> 'a) -> nat -> list 'a*)

(*let rec genlist f n=
  match n with
    | 0 -> []
    | n' + 1 -> snoc (f n') (genlist f n')
  end*)

(* ------------------------- *)
(* replicate                 *)
(* ------------------------- *)

(*val replicate : forall 'a. nat -> 'a -> list 'a*)
(*let rec replicate n x=
  match n with
    | 0 -> []
    | n' + 1 -> x :: replicate n' x
  end*)

(* ========================================================================== *)
(* Sublists                                                                   *)
(* ========================================================================== *)

(* ------------------------- *)
(* splitAt                   *)
(* ------------------------- *)

(* [splitAt n xs] returns a tuple (xs1, xs2), with append xs1 xs2 = xs and
   length xs1 = n. If there are not enough elements
   in [xs], the original list and the empty one are returned. *)
(*val splitAtAcc : forall 'a. list 'a -> nat -> list 'a -> (list 'a * list 'a)*)
function (sequential,domintros)  splitAtAcc  :: " 'a list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list*'a list "  where
     " splitAtAcc revAcc n l = (
  (case  l of
      []    => (List.rev revAcc, [])
    | x # xs => if n \<le>( 0 :: nat) then (List.rev revAcc, l) else splitAtAcc (x # revAcc) (n-( 1 :: nat)) xs
  ))"
by pat_completeness auto

(*val splitAt : forall 'a. nat -> list 'a -> (list 'a * list 'a)*)
(*let rec splitAt n l=
   splitAtAcc [] n l*)

(* ------------------------- *)
(* take                      *)
(* ------------------------- *)

(* take n xs returns the prefix of xs of length n, or xs itself if n > length xs *)
(*val take : forall 'a. nat -> list 'a -> list 'a*)
(*let take n l=  fst (splitAt n l)*)

(* ------------------------- *)
(* drop                      *)
(* ------------------------- *)

(* [drop n xs] drops the first [n] elements of [xs]. It returns the empty list, if [n] > [length xs]. *)
(*val drop : forall 'a. nat -> list 'a -> list 'a*)
(*let drop n l=  snd (splitAt n l)*)

(* ------------------------- *)
(* dropWhile                 *)
(* ------------------------- *)

(* [dropWhile p xs] drops the first elements of [xs] that satisfy [p]. *)
(*val dropWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*)
fun  dropWhile  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " dropWhile p l = ( (case  l of
    [] => []
  | x # xs => if p x then dropWhile p xs else l
))"
declare dropWhile.simps [simp del]

(* ------------------------- *)
(* takeWhile                 *)
(* ------------------------- *)

(* [takeWhile p xs] takes the first elements of [xs] that satisfy [p]. *)
(*val takeWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*)
fun  takeWhile  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " takeWhile p ([]) = ( [])"
|" takeWhile p (x # xs) = ( if p x then x # takeWhile p xs else [])"
declare takeWhile.simps [simp del]

(* ------------------------- *)
(* splitWhile                *)
(* ------------------------- *)

(*val splitWhile : forall 'a. ('a -> bool) -> list 'a -> (list 'a * list 'a)*)
definition splitWhile  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list*'a list "  where
     " splitWhile p xs = ( (takeWhile p xs, dropWhile p xs))"

(* ------------------------- *)
(* isPrefixOf                *)
(* ------------------------- *)

(*val isPrefixOf : forall 'a. Eq 'a => list 'a -> list 'a -> bool*)
fun  isPrefixOf  :: " 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " isPrefixOf ([]) _ = ( True )"
|" isPrefixOf (_ # _) ([]) = ( False )"
|" isPrefixOf (x # xs) (y # ys) = ( (x = y) \<and> isPrefixOf xs ys )"
declare isPrefixOf.simps [simp del]

(* ------------------------- *)
(* update                    *)
(* ------------------------- *)
(*val update : forall 'a. list 'a -> nat -> 'a -> list 'a*)
(*let rec update l n e=
  match l with
    | []      -> []
    | x :: xs -> if (Instance_Basic_classes_Eq_nat.=) n 0 then e :: xs else x :: (update xs ((Instance_Num_NumMinus_nat.-) n 1) e)
end*)

(* ========================================================================== *)
(* Searching lists                                                            *)
(* ========================================================================== *)

(* ------------------------- *)
(* Membership test           *)
(* ------------------------- *)

(* The membership test, one of the basic list functions, is actually tricky for
   Lem, because it is tricky, which equality to use. From Lem`s point of
   perspective, we want to use the equality provided by the equality type - class.
   This allows for example to check whether a set is in a list of sets.

   However, in order to use the equality type class, elem essentially becomes
   existential quantification over lists. For types, which implement semantic
   equality (=) with syntactic equality, this is overly complicated. In
   our theorem prover backend, we would end up with overly complicated, harder
   to read definitions and some of the automation would be harder to apply.
   Moreover, nearly all the old Lem generated code would change and require
   (hopefully minor) adaptions of proofs.

   For now, we ignore this problem and just demand, that all instances of
   the equality type class do the right thing for the theorem prover backends.
*)

(*val elem : forall 'a. Eq 'a => 'a -> list 'a -> bool*)
(*val elemBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> bool*)

definition elemBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " elemBy eq e l = ( ((\<exists> x \<in> (set l).  (eq e) x)))"

(*let elem=  elemBy (=)*)

(* ------------------------- *)
(* Find                      *)
(* ------------------------- *)
(*val find : forall 'a. ('a -> bool) -> list 'a -> maybe 'a*) (* previously not of maybe type *)
(*let rec find P l=  match l with
  | []      -> Nothing
  | x :: xs -> if P x then Just x else find P xs
end*)

(* ----------------------------- *)
(* Lookup in an associative list *)
(* ----------------------------- *)
(*val lookup   : forall 'a 'b. Eq 'a              => 'a -> list ('a * 'b) -> maybe 'b*)
(*val lookupBy : forall 'a 'b. ('a -> 'a -> bool) -> 'a -> list ('a * 'b) -> maybe 'b*)

(* DPM: eta-expansion for Coq backend type-inference. *)
definition lookupBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow>('a*'b)list \<Rightarrow> 'b option "  where
     " lookupBy eq k m = ( map_option (\<lambda> x .  snd x) (List.find (\<lambda> (k', _) .  eq k k') m))"

(* ------------------------- *)
(* filter                    *)
(* ------------------------- *)
(*val filter : forall 'a. ('a -> bool) -> list 'a -> list 'a*)
(*let rec filter P l=  match l with
                       | [] -> []
                       | x :: xs -> if (P x) then x :: (filter P xs) else filter P xs
                     end*)

(* ------------------------- *)
(* partition                 *)
(* ------------------------- *)
(*val partition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*)
(*let partition P l=  (filter P l, filter (fun x -> not (P x)) l)*)

(*val reversePartition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*)
definition reversePartition  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list*'a list "  where
     " reversePartition P l = ( List.partition P (List.rev l))"

(* ------------------------- *)
(* delete first element      *)
(* with certain property     *)
(* ------------------------- *)

(*val deleteFirst : forall 'a. ('a -> bool) -> list 'a -> maybe (list 'a)*)
(*let rec deleteFirst P l=  match l with
                            | [] -> Nothing
                            | x :: xs -> if (P x) then Just xs else Maybe.map (fun xs' -> x :: xs') (deleteFirst P xs)
                          end*)

(*val delete : forall 'a. Eq 'a => 'a -> list 'a -> list 'a*)
(*val deleteBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a*)

definition deleteBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " deleteBy eq x l = ( case_option l id (delete_first (eq x) l))"

(* ========================================================================== *)
(* Zipping and unzipping lists                                                *)
(* ========================================================================== *)

(* ------------------------- *)
(* zip                       *)
(* ------------------------- *)

(* zip takes two lists and returns a list of corresponding pairs. If one input list is short, excess elements of the longer list are discarded. *)
(*val zip : forall 'a 'b. list 'a -> list 'b -> list ('a * 'b)*) (* before combine *)
(*let rec zip l1 l2=  match (l1, l2) with
  | (x :: xs, y :: ys) -> (x, y) :: zip xs ys
  | _ -> []
end*)

(* ------------------------- *)
(* unzip                     *)
(* ------------------------- *)

(*val unzip: forall 'a 'b. list ('a * 'b) -> (list 'a * list 'b)*)
(*let rec unzip l=  match l with
  | [] -> ([], [])
  | (x, y) :: xys -> let (xs, ys) = unzip xys in (x :: xs, y :: ys)
end*)

(* ------------------------- *)
(* distinct elements         *)
(* ------------------------- *)

(*val allDistinct : forall 'a. Eq 'a => list 'a -> bool*)
fun  allDistinct  :: " 'a list \<Rightarrow> bool "  where
     " allDistinct ([]) = ( True )"
|" allDistinct (x # l') = ( \<not> (Set.member x (set l')) \<and> allDistinct l' )"
declare allDistinct.simps [simp del]

(* some more useful functions *)
(*val mapMaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> list 'b*)
function (sequential,domintros)  mapMaybe  :: "('a \<Rightarrow> 'b option)\<Rightarrow> 'a list \<Rightarrow> 'b list "  where
     " mapMaybe f ([]) = ( [])"
|" mapMaybe f (x # xs) = (
      (case  f x of
        None => mapMaybe f xs
      | Some y => y # (mapMaybe f xs)
      ))"
by pat_completeness auto

(*val mapi : forall 'a 'b. (nat -> 'a -> 'b) -> list 'a -> list 'b*)
function (sequential,domintros)  mapiAux  :: "(nat \<Rightarrow> 'b \<Rightarrow> 'a)\<Rightarrow> nat \<Rightarrow> 'b list \<Rightarrow> 'a list "  where
     " mapiAux f (n :: nat) ([]) = ( [])"
|" mapiAux f (n :: nat) (x # xs) = ( (f n x) # mapiAux f (n +( 1 :: nat)) xs )"
by pat_completeness auto

definition mapi  :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> 'b list "  where
     " mapi f l = ( mapiAux f(( 0 :: nat)) l )"

(*val deletes: forall 'a. Eq 'a => list 'a -> list 'a -> list 'a*)
definition deletes  :: " 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " deletes xs ys = (
  List.foldl ((\<lambda> x y. remove1 y x)) xs ys )"

(* ========================================================================== *)
(* Comments (not clean yet, please ignore the rest of the file)               *)
(* ========================================================================== *)

(* ----------------------- *)
(* skipped from Haskell Lib*)
(* -----------------------

intersperse :: a -> [a] -> [a]
intercalate :: [a] -> [[a]] -> [a]
transpose :: [[a]] -> [[a]]
subsequences :: [a] -> [[a]]
permutations :: [a] -> [[a]]
foldl` :: (a -> b -> a) -> a -> [b] -> aSource
foldl1` :: (a -> a -> a) -> [a] -> aSource

and
or
sum
product
maximum
minimum
scanl
scanr
scanl1
scanr1
Accumulating maps

mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source
mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source

iterate :: (a -> a) -> a -> [a]
repeat :: a -> [a]
cycle :: [a] -> [a]
unfoldr

takeWhile :: (a -> Bool) -> [a] -> [a]Source
dropWhile :: (a -> Bool) -> [a] -> [a]Source
dropWhileEnd :: (a -> Bool) -> [a] -> [a]Source
span :: (a -> Bool) -> [a] -> ([a], [a])Source
break :: (a -> Bool) -> [a] -> ([a], [a])Source
break p is equivalent to span (not . p).
stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]Source
group :: Eq a => [a] -> [[a]]Source
inits :: [a] -> [[a]]Source
tails :: [a] -> [[a]]Source

isPrefixOf :: Eq a => [a] -> [a] -> BoolSource
isSuffixOf :: Eq a => [a] -> [a] -> BoolSource
isInfixOf :: Eq a => [a] -> [a] -> BoolSource

notElem :: Eq a => a -> [a] -> BoolSource

zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]Source
zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]Source
zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]Source
zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]Source
zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)]Source

zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]Source
zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]Source
zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]Source
zipWith5 :: (a -> b -> c -> d -> e -> f) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f]Source
zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]Source
zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h]Source

unzip3 :: [(a, b, c)] -> ([a], [b], [c])Source
unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])Source
unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])Source
unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f])Source
unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g])Source

lines :: String -> [String]Source
words :: String -> [String]Source
unlines :: [String] -> StringSource
unwords :: [String] -> StringSource
nub :: Eq a => [a] -> [a]Source
delete :: Eq a => a -> [a] -> [a]Source

() :: Eq a => [a] -> [a] -> [a]Source
union :: Eq a => [a] -> [a] -> [a]Source
intersect :: Eq a => [a] -> [a] -> [a]Source
sort :: Ord a => [a] -> [a]Source
insert :: Ord a => a -> [a] -> [a]Source

nubBy :: (a -> a -> Bool) -> [a] -> [a]Source
deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]Source
deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source
unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source
intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source
groupBy :: (a -> a -> Bool) -> [a] -> [[a]]Source
sortBy :: (a -> a -> Ordering) -> [a] -> [a]Source
insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]Source
maximumBy :: (a -> a -> Ordering) -> [a] -> aSource
minimumBy :: (a -> a -> Ordering) -> [a] -> aSource
genericLength :: Num i => [b] -> iSource
genericTake :: Integral i => i -> [a] -> [a]Source
genericDrop :: Integral i => i -> [a] -> [a]Source
genericSplitAt :: Integral i => i -> [b] -> ([b], [b])Source
genericIndex :: Integral a => [b] -> a -> bSource
genericReplicate :: Integral i => i -> a -> [a]Source

*)

(* ----------------------- *)
(* skipped from Lem Lib    *)
(* -----------------------

val for_all2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool
val exists2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool
val map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c
val rev_map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c
val fold_left2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'a) -> 'a -> list 'b -> list 'c -> 'a
val fold_right2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'c) -> list 'a -> list 'b -> 'c -> 'c

(* now maybe result and called lookup *)
val assoc : forall 'a 'b. 'a -> list ('a * 'b) -> 'b
let inline {ocaml} assoc = Ocaml.List.assoc

val mem_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> bool
val remove_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> list ('a * 'b)

val stable_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a
val fast_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a

val merge : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a -> list 'a
val intersect : forall 'a. list 'a -> list 'a -> list 'a

*)

(*val     catMaybes : forall 'a. list (maybe 'a) -> list 'a*)
function (sequential,domintros)  catMaybes  :: "('a option)list \<Rightarrow> 'a list "  where
     " catMaybes ([]) = (
        [])"
|" catMaybes (None # xs') = (
        catMaybes xs' )"
|" catMaybes (Some x # xs') = (
        x # catMaybes xs' )"
by pat_completeness auto

end


(*<*)

(* Author: Kyndylan Nienhuis *)

theory CompartmentAuthority

imports
  "CHERI-core.CheriLemmas"
begin

(*>*)
section \<open>Generalised permissions\<close>

record CompartmentAuthority =
  SystemRegisterAccess :: bool
  ExecutableAddresses :: "VirtualAddress set"
  LoadableAddresses :: "VirtualAddress set"
  CapLoadableAddresses :: "VirtualAddress set"
  StorableAddresses :: "VirtualAddress set"
  CapStorableAddresses :: "VirtualAddress set"
  LocalCapStorableAddresses :: "VirtualAddress set"
  SealableTypes :: "ObjectType set"
  UnsealableTypes :: "ObjectType set"

subsection \<open>Order over generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (order) order
begin

  definition less_eq_CompartmentAuthority_ext ::
    "'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme \<Rightarrow> bool"
  where
    "less_eq_CompartmentAuthority_ext perm\<^sub>1 perm\<^sub>2 \<equiv>
     (SystemRegisterAccess perm\<^sub>1 \<le> SystemRegisterAccess perm\<^sub>2) \<and>
     (ExecutableAddresses perm\<^sub>1 \<le> ExecutableAddresses perm\<^sub>2) \<and>
     (LoadableAddresses perm\<^sub>1 \<le> LoadableAddresses perm\<^sub>2) \<and>
     (CapLoadableAddresses perm\<^sub>1 \<le> CapLoadableAddresses perm\<^sub>2) \<and>
     (StorableAddresses perm\<^sub>1 \<le> StorableAddresses perm\<^sub>2) \<and>
     (CapStorableAddresses perm\<^sub>1 \<le> CapStorableAddresses perm\<^sub>2) \<and>
     (LocalCapStorableAddresses perm\<^sub>1 \<le> LocalCapStorableAddresses perm\<^sub>2) \<and>
     (SealableTypes perm\<^sub>1 \<le> SealableTypes perm\<^sub>2) \<and>
     (UnsealableTypes perm\<^sub>1 \<le> UnsealableTypes perm\<^sub>2) \<and>
     (CompartmentAuthority.more perm\<^sub>1 \<le> CompartmentAuthority.more perm\<^sub>2)"

  definition less_CompartmentAuthority_ext :: "'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme \<Rightarrow> bool" where
    "less_CompartmentAuthority_ext perm\<^sub>1 perm\<^sub>2 \<equiv> perm\<^sub>1 \<le> perm\<^sub>2 \<and> \<not> (perm\<^sub>2 \<le> perm\<^sub>1)"

  instance
    by standard (auto simp: less_CompartmentAuthority_ext_def less_eq_CompartmentAuthority_ext_def)

end

subsubsection \<open>Eliminations\<close>

lemma SystemRegisterAccess_le [elim]:
  assumes "p \<le> q"
      and "SystemRegisterAccess p"
  shows "SystemRegisterAccess q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemma ExecutableAddresses_le:
  assumes "p \<le> q"
  shows "ExecutableAddresses p \<subseteq> ExecutableAddresses q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas ExecutableAddresses_le_subsetD [elim] =
  subsetD[OF ExecutableAddresses_le]

lemma LoadableAddresses_le:
  assumes "p \<le> q"
  shows "LoadableAddresses p \<subseteq> LoadableAddresses q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas LoadableAddresses_le_subsetD [elim] =
  subsetD[OF LoadableAddresses_le]

lemma CapLoadableAddresses_le:
  assumes "p \<le> q"
  shows "CapLoadableAddresses p \<subseteq> CapLoadableAddresses q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas CapLoadableAddresses_le_subsetD [elim] =
  subsetD[OF CapLoadableAddresses_le]

lemma StorableAddresses_le:
  assumes "p \<le> q"
  shows "StorableAddresses p \<subseteq> StorableAddresses q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas StorableAddresses_le_subsetD [elim] =
  subsetD[OF StorableAddresses_le]

lemma CapStorableAddresses_le:
  assumes "p \<le> q"
  shows "CapStorableAddresses p \<subseteq> CapStorableAddresses q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas CapStorableAddresses_le_subsetD [elim] =
  subsetD[OF CapStorableAddresses_le]

lemma LocalCapStorableAddresses_le:
  assumes "p \<le> q"
  shows "LocalCapStorableAddresses p \<subseteq> LocalCapStorableAddresses q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas LocalCapStorableAddresses_le_subsetD [elim] =
  subsetD[OF LocalCapStorableAddresses_le]

lemma SealableTypes_le:
  assumes "p \<le> q"
  shows "SealableTypes p \<subseteq> SealableTypes q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas SealableTypes_le_subsetD [elim] =
  subsetD[OF SealableTypes_le]

lemma UnsealableTypes_le:
  assumes "p \<le> q"
  shows "UnsealableTypes p \<subseteq> UnsealableTypes q"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
by auto

lemmas UnsealableTypes_le_subsetD [elim] =
  subsetD[OF UnsealableTypes_le]

subsection \<open>Complete lattice over generalised permissions\<close>

subsubsection \<open>Bottom of generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (order_bot) order_bot
begin

  definition bot_CompartmentAuthority_ext :: "'a CompartmentAuthority_scheme" where
    "bot_CompartmentAuthority_ext =
     \<lparr>SystemRegisterAccess = bot,
      ExecutableAddresses = bot,
      LoadableAddresses = bot,
      CapLoadableAddresses = bot,
      StorableAddresses = bot,
      CapStorableAddresses = bot,
      LocalCapStorableAddresses = bot,
      SealableTypes = bot,
      UnsealableTypes = bot,
      \<dots> = bot\<rparr>"

  instance
    by standard (auto simp: bot_CompartmentAuthority_ext_def less_eq_CompartmentAuthority_ext_def)

end

lemma bot_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess bot = bot"
    and "ExecutableAddresses bot = bot"
    and "LoadableAddresses bot = bot"
    and "CapLoadableAddresses bot = bot"
    and "StorableAddresses bot = bot"
    and "CapStorableAddresses bot = bot"
    and "LocalCapStorableAddresses bot = bot"
    and "SealableTypes bot = bot"
    and "UnsealableTypes bot = bot"
    and "more bot = bot"
unfolding bot_CompartmentAuthority_ext_def
by simp_all

subsubsection \<open>Top of generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (order_top) order_top
begin

  definition top_CompartmentAuthority_ext :: "'a CompartmentAuthority_scheme" where
    "top_CompartmentAuthority_ext =
     \<lparr>SystemRegisterAccess = top,
      ExecutableAddresses = top,
      LoadableAddresses = top,
      CapLoadableAddresses = top,
      StorableAddresses = top,
      CapStorableAddresses = top,
      LocalCapStorableAddresses = top,
      SealableTypes = top,
      UnsealableTypes = top,
      \<dots> = top\<rparr>"

  instance
    by standard (auto simp: top_CompartmentAuthority_ext_def less_eq_CompartmentAuthority_ext_def)

end

lemma top_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess top = top"
    and "ExecutableAddresses top = top"
    and "LoadableAddresses top = top"
    and "CapLoadableAddresses top = top"
    and "StorableAddresses top = top"
    and "CapStorableAddresses top = top"
    and "LocalCapStorableAddresses top = top"
    and "SealableTypes top = top"
    and "UnsealableTypes top = top"
    and "more top = top"
unfolding top_CompartmentAuthority_ext_def
by simp_all

subsubsection \<open>Infimum of generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (semilattice_inf) semilattice_inf
begin

  definition inf_CompartmentAuthority_ext ::
    "'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme"
  where
    "inf_CompartmentAuthority_ext left right =
     \<lparr>SystemRegisterAccess = inf (SystemRegisterAccess left) (SystemRegisterAccess right),
      ExecutableAddresses = inf (ExecutableAddresses left) (ExecutableAddresses right),
      LoadableAddresses = inf (LoadableAddresses left) (LoadableAddresses right),
      CapLoadableAddresses = inf (CapLoadableAddresses left) (CapLoadableAddresses right),
      StorableAddresses = inf (StorableAddresses left) (StorableAddresses right),
      CapStorableAddresses = inf (CapStorableAddresses left) (CapStorableAddresses right),
      LocalCapStorableAddresses = inf (LocalCapStorableAddresses left) (LocalCapStorableAddresses right),
      SealableTypes = inf (SealableTypes left) (SealableTypes right),
      UnsealableTypes = inf (UnsealableTypes left) (UnsealableTypes right),
      \<dots> = inf (more left) (more right)\<rparr>"

  instance
    by standard (auto simp: inf_CompartmentAuthority_ext_def less_eq_CompartmentAuthority_ext_def)

end

lemma inf_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess (inf left right) = inf (SystemRegisterAccess left) (SystemRegisterAccess right)"
    and "ExecutableAddresses (inf left right) = inf (ExecutableAddresses left) (ExecutableAddresses right)"
    and "LoadableAddresses (inf left right) = inf (LoadableAddresses left) (LoadableAddresses right)"
    and "CapLoadableAddresses (inf left right) = inf (CapLoadableAddresses left) (CapLoadableAddresses right)"
    and "StorableAddresses (inf left right) = inf (StorableAddresses left) (StorableAddresses right)"
    and "CapStorableAddresses (inf left right) = inf (CapStorableAddresses left) (CapStorableAddresses right)"
    and "LocalCapStorableAddresses (inf left right) = inf (LocalCapStorableAddresses left) (LocalCapStorableAddresses right)"
    and "SealableTypes (inf left right) = inf (SealableTypes left) (SealableTypes right)"
    and "UnsealableTypes (inf left right) = inf (UnsealableTypes left) (UnsealableTypes right)"
    and "more (inf left right) = inf (more left) (more right)"
unfolding inf_CompartmentAuthority_ext_def
by simp_all

instantiation "CompartmentAuthority_ext" :: (Inf) Inf
begin

  definition Inf_CompartmentAuthority_ext ::
    "'a CompartmentAuthority_scheme set \<Rightarrow> 'a CompartmentAuthority_scheme"
  where
    "Inf_CompartmentAuthority_ext permSet =
     \<lparr>SystemRegisterAccess = Inf (SystemRegisterAccess ` permSet),
      ExecutableAddresses = Inf (ExecutableAddresses ` permSet),
      LoadableAddresses = Inf (LoadableAddresses ` permSet),
      CapLoadableAddresses = Inf (CapLoadableAddresses ` permSet),
      StorableAddresses = Inf (StorableAddresses ` permSet),
      CapStorableAddresses = Inf (CapStorableAddresses ` permSet),
      LocalCapStorableAddresses = Inf (LocalCapStorableAddresses ` permSet),
      SealableTypes = Inf (SealableTypes ` permSet),
      UnsealableTypes = Inf (UnsealableTypes ` permSet),
      \<dots> = Inf (more ` permSet)\<rparr>"

  instance by standard

end

lemma Inf_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess (Inf permSet) = Inf (SystemRegisterAccess ` permSet)"
    and "ExecutableAddresses (Inf permSet) = Inf (ExecutableAddresses ` permSet)"
    and "LoadableAddresses (Inf permSet) = Inf (LoadableAddresses ` permSet)"
    and "CapLoadableAddresses (Inf permSet) = Inf (CapLoadableAddresses ` permSet)"
    and "StorableAddresses (Inf permSet) = Inf (StorableAddresses ` permSet)"
    and "CapStorableAddresses (Inf permSet) = Inf (CapStorableAddresses ` permSet)"
    and "LocalCapStorableAddresses (Inf permSet) = Inf (LocalCapStorableAddresses ` permSet)"
    and "SealableTypes (Inf permSet) = Inf (SealableTypes ` permSet)"
    and "UnsealableTypes (Inf permSet) = Inf (UnsealableTypes ` permSet)"
    and "more (Inf permSet) = Inf (more ` permSet)"
unfolding Inf_CompartmentAuthority_ext_def
by simp_all

subsubsection \<open>Supremum of generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (semilattice_sup) semilattice_sup
begin

  definition sup_CompartmentAuthority_ext ::
    "'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme"
  where
    "sup_CompartmentAuthority_ext left right =
     \<lparr>SystemRegisterAccess = sup (SystemRegisterAccess left) (SystemRegisterAccess right),
      ExecutableAddresses = sup (ExecutableAddresses left) (ExecutableAddresses right),
      LoadableAddresses = sup (LoadableAddresses left) (LoadableAddresses right),
      CapLoadableAddresses = sup (CapLoadableAddresses left) (CapLoadableAddresses right),
      StorableAddresses = sup (StorableAddresses left) (StorableAddresses right),
      CapStorableAddresses = sup (CapStorableAddresses left) (CapStorableAddresses right),
      LocalCapStorableAddresses = sup (LocalCapStorableAddresses left) (LocalCapStorableAddresses right),
      SealableTypes = sup (SealableTypes left) (SealableTypes right),
      UnsealableTypes = sup (UnsealableTypes left) (UnsealableTypes right),
      \<dots> = sup (more left) (more right)\<rparr>"

  instance
    by standard (auto simp: sup_CompartmentAuthority_ext_def less_eq_CompartmentAuthority_ext_def)

end

lemma sup_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess (sup left right) = sup (SystemRegisterAccess left) (SystemRegisterAccess right)"
    and "ExecutableAddresses (sup left right) = sup (ExecutableAddresses left) (ExecutableAddresses right)"
    and "LoadableAddresses (sup left right) = sup (LoadableAddresses left) (LoadableAddresses right)"
    and "CapLoadableAddresses (sup left right) = sup (CapLoadableAddresses left) (CapLoadableAddresses right)"
    and "StorableAddresses (sup left right) = sup (StorableAddresses left) (StorableAddresses right)"
    and "CapStorableAddresses (sup left right) = sup (CapStorableAddresses left) (CapStorableAddresses right)"
    and "LocalCapStorableAddresses (sup left right) = sup (LocalCapStorableAddresses left) (LocalCapStorableAddresses right)"
    and "SealableTypes (sup left right) = sup (SealableTypes left) (SealableTypes right)"
    and "UnsealableTypes (sup left right) = sup (UnsealableTypes left) (UnsealableTypes right)"
    and "more (sup left right) = sup (more left) (more right)"
unfolding sup_CompartmentAuthority_ext_def
by simp_all

instantiation "CompartmentAuthority_ext" :: (Sup) Sup
begin

  definition Sup_CompartmentAuthority_ext ::
    "'a CompartmentAuthority_scheme set \<Rightarrow> 'a CompartmentAuthority_scheme"
  where
    "Sup_CompartmentAuthority_ext permSet =
     \<lparr>SystemRegisterAccess = Sup (SystemRegisterAccess ` permSet),
      ExecutableAddresses = Sup (ExecutableAddresses ` permSet),
      LoadableAddresses = Sup (LoadableAddresses ` permSet),
      CapLoadableAddresses = Sup (CapLoadableAddresses ` permSet),
      StorableAddresses = Sup (StorableAddresses ` permSet),
      CapStorableAddresses = Sup (CapStorableAddresses ` permSet),
      LocalCapStorableAddresses = Sup (LocalCapStorableAddresses ` permSet),
      SealableTypes = Sup (SealableTypes ` permSet),
      UnsealableTypes = Sup (UnsealableTypes ` permSet),
      \<dots> = Sup (more ` permSet)\<rparr>"

  instance by standard

end

lemma Sup_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess (Sup permSet) = Sup (SystemRegisterAccess ` permSet)"
    and "ExecutableAddresses (Sup permSet) = Sup (ExecutableAddresses ` permSet)"
    and "LoadableAddresses (Sup permSet) = Sup (LoadableAddresses ` permSet)"
    and "CapLoadableAddresses (Sup permSet) = Sup (CapLoadableAddresses ` permSet)"
    and "StorableAddresses (Sup permSet) = Sup (StorableAddresses ` permSet)"
    and "CapStorableAddresses (Sup permSet) = Sup (CapStorableAddresses ` permSet)"
    and "LocalCapStorableAddresses (Sup permSet) = Sup (LocalCapStorableAddresses ` permSet)"
    and "SealableTypes (Sup permSet) = Sup (SealableTypes ` permSet)"
    and "UnsealableTypes (Sup permSet) = Sup (UnsealableTypes ` permSet)"
    and "more (Sup permSet) = Sup (more ` permSet)"
unfolding Sup_CompartmentAuthority_ext_def
by simp_all

subsubsection \<open>Bounded, distributive lattice over generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (Lattices.lattice) Lattices.lattice
begin

  instance by standard

end

instantiation "CompartmentAuthority_ext" :: (bounded_lattice) bounded_lattice
begin

  instance by standard

end

instantiation "CompartmentAuthority_ext" :: (distrib_lattice) distrib_lattice
begin

  instance
    by standard
       (auto simp: sup_inf_distrib1
                   inf_CompartmentAuthority_ext_def
                   sup_CompartmentAuthority_ext_def)

end

subsubsection \<open>Boolean algebra over generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (boolean_algebra) boolean_algebra
begin

  definition minus_CompartmentAuthority_ext ::
    "'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme"
  where
    "minus_CompartmentAuthority_ext left right =
     \<lparr>SystemRegisterAccess = minus (SystemRegisterAccess left) (SystemRegisterAccess right),
      ExecutableAddresses = minus (ExecutableAddresses left) (ExecutableAddresses right),
      LoadableAddresses = minus (LoadableAddresses left) (LoadableAddresses right),
      CapLoadableAddresses = minus (CapLoadableAddresses left) (CapLoadableAddresses right),
      StorableAddresses = minus (StorableAddresses left) (StorableAddresses right),
      CapStorableAddresses = minus (CapStorableAddresses left) (CapStorableAddresses right),
      LocalCapStorableAddresses = minus (LocalCapStorableAddresses left) (LocalCapStorableAddresses right),
      SealableTypes = minus (SealableTypes left) (SealableTypes right),
      UnsealableTypes = minus (UnsealableTypes left) (UnsealableTypes right),
      \<dots> = minus (more left) (more right)\<rparr>"

  definition uminus_CompartmentAuthority_ext ::
    "'a CompartmentAuthority_scheme \<Rightarrow> 'a CompartmentAuthority_scheme"
  where
    "uminus_CompartmentAuthority_ext perm =
     \<lparr>SystemRegisterAccess = uminus (SystemRegisterAccess perm),
      ExecutableAddresses = uminus (ExecutableAddresses perm),
      LoadableAddresses = uminus (LoadableAddresses perm),
      CapLoadableAddresses = uminus (CapLoadableAddresses perm),
      StorableAddresses = uminus (StorableAddresses perm),
      CapStorableAddresses = uminus (CapStorableAddresses perm),
      LocalCapStorableAddresses = uminus (LocalCapStorableAddresses perm),
      SealableTypes = uminus (SealableTypes perm),
      UnsealableTypes = uminus (UnsealableTypes perm),
      \<dots> = uminus (more perm)\<rparr>"

  instance
    by standard
       (auto simp: diff_eq
                   bot_CompartmentAuthority_ext_def
                   top_CompartmentAuthority_ext_def
                   inf_CompartmentAuthority_ext_def
                   sup_CompartmentAuthority_ext_def
                   minus_CompartmentAuthority_ext_def
                   uminus_CompartmentAuthority_ext_def)

end

lemma minus_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess (minus left right) = minus (SystemRegisterAccess left) (SystemRegisterAccess right)"
    and "ExecutableAddresses (minus left right) = minus (ExecutableAddresses left) (ExecutableAddresses right)"
    and "LoadableAddresses (minus left right) = minus (LoadableAddresses left) (LoadableAddresses right)"
    and "CapLoadableAddresses (minus left right) = minus (CapLoadableAddresses left) (CapLoadableAddresses right)"
    and "StorableAddresses (minus left right) = minus (StorableAddresses left) (StorableAddresses right)"
    and "CapStorableAddresses (minus left right) = minus (CapStorableAddresses left) (CapStorableAddresses right)"
    and "LocalCapStorableAddresses (minus left right) = minus (LocalCapStorableAddresses left) (LocalCapStorableAddresses right)"
    and "SealableTypes (minus left right) = minus (SealableTypes left) (SealableTypes right)"
    and "UnsealableTypes (minus left right) = minus (UnsealableTypes left) (UnsealableTypes right)"
    and "more (minus left right) = minus (more left) (more right)"
unfolding minus_CompartmentAuthority_ext_def
by simp_all

lemma uminus_CompartmentAuthority_ext_simp [simp]:
  shows "SystemRegisterAccess (uminus perm) = uminus (SystemRegisterAccess perm)"
    and "ExecutableAddresses (uminus perm) = uminus (ExecutableAddresses perm)"
    and "LoadableAddresses (uminus perm) = uminus (LoadableAddresses perm)"
    and "CapLoadableAddresses (uminus perm) = uminus (CapLoadableAddresses perm)"
    and "StorableAddresses (uminus perm) = uminus (StorableAddresses perm)"
    and "CapStorableAddresses (uminus perm) = uminus (CapStorableAddresses perm)"
    and "LocalCapStorableAddresses (uminus perm) = uminus (LocalCapStorableAddresses perm)"
    and "SealableTypes (uminus perm) = uminus (SealableTypes perm)"
    and "UnsealableTypes (uminus perm) = uminus (UnsealableTypes perm)"
    and "more (uminus perm) = uminus (more perm)"
unfolding uminus_CompartmentAuthority_ext_def
by simp_all

subsubsection \<open>Complete lattice over generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (complete_lattice) complete_lattice
begin

  instance
    proof standard
      fix x :: "'a CompartmentAuthority_ext" and A
      assume "x \<in> A"
      thus   "less_eq (Inf A) x"
        unfolding Inf_CompartmentAuthority_ext_def
        unfolding less_eq_CompartmentAuthority_ext_def
        by (simp add: INF_lower)
    next
      fix z :: "'a CompartmentAuthority_ext" and A
      assume "\<And>x. x \<in> A \<Longrightarrow> less_eq z x"
      thus   "less_eq z (Inf A)"
        unfolding Inf_CompartmentAuthority_ext_def
        unfolding less_eq_CompartmentAuthority_ext_def
        by (auto simp: INF_greatest)
    next
      fix x :: "'a CompartmentAuthority_ext" and A
      assume "x \<in> A"
      thus   "less_eq x (Sup A)"
        unfolding Sup_CompartmentAuthority_ext_def
        unfolding less_eq_CompartmentAuthority_ext_def
        by (auto simp: SUP_upper)
    next
      fix z :: "'a CompartmentAuthority_ext" and A
      assume "\<And>x. x \<in> A \<Longrightarrow> less_eq x z"
      thus   "less_eq (Sup A) z"
        unfolding Sup_CompartmentAuthority_ext_def
        unfolding less_eq_CompartmentAuthority_ext_def
        by (auto simp: SUP_least)
    next
      show "(Inf {}::'a CompartmentAuthority_ext) = top"
        unfolding Inf_CompartmentAuthority_ext_def
        unfolding top_CompartmentAuthority_ext_def
        by simp
    next
      show "(Sup {}::'a CompartmentAuthority_ext) = bot"
        unfolding Sup_CompartmentAuthority_ext_def
        unfolding bot_CompartmentAuthority_ext_def
        by simp
    qed

end

subsubsection \<open>Complete distributive lattice over generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (complete_distrib_lattice) complete_distrib_lattice
begin

  instance
    proof standard
      fix x :: "'a CompartmentAuthority_ext" and A
      show "sup x (Inf A) = (INF a:A. sup x a)"
        unfolding Inf_CompartmentAuthority_ext_def
        unfolding sup_CompartmentAuthority_ext_def
        using sup_Inf[where a="CompartmentAuthority.more x"]
        by simp
    next
      fix x :: "'a CompartmentAuthority_ext" and A
      show "inf x (Sup A) = (SUP a:A. inf x a)"
        unfolding Sup_CompartmentAuthority_ext_def
        unfolding inf_CompartmentAuthority_ext_def
        using inf_Sup[where a="CompartmentAuthority.more x"]
        by simp
    qed

end

subsubsection \<open>Complete boolean algebra over generalised permissions\<close>

instantiation "CompartmentAuthority_ext" :: (complete_boolean_algebra) complete_boolean_algebra
begin

  instance by standard

end

subsection \<open>Physical capability addresses\<close>

definition getTranslateCapAddresses ::
  "VirtualAddress set \<Rightarrow> AccessType \<Rightarrow> state \<Rightarrow> PhysicalCapAddress set"
where
  "getTranslateCapAddresses addrs t s \<equiv>
   GetCapAddress ` getTranslateAddresses addrs t s"

lemma Commute_getTranslateCapAddresses [Commute_compositeI]:
  assumes "Commute (read_state (getTranslateAddresses addrs t)) m"
  shows "Commute (read_state (getTranslateCapAddresses addrs t)) m"
using assms
unfolding getTranslateCapAddresses_def Commute_def
by auto

lemma getTranslateCapAddressesI [intro?]:
  assumes "getTranslateAddr (virtualAddress, t) s = Some physicalAddress"
      and "a = GetCapAddress physicalAddress"
      and "virtualAddress \<in> addrs"
  shows "a \<in> getTranslateCapAddresses addrs t s"
using assms
unfolding getTranslateCapAddresses_def
unfolding getTranslateAddresses_def
by auto

lemma getTranslateCapAddressesI_word_cat [elim]:
  assumes "getTranslateAddr (virtualAddress, t) s = Some (ExtendCapAddress a)"
      and "virtualAddress \<in> addrs"
  shows "a \<in> getTranslateCapAddresses addrs t s"
using assms
using slice_cat1[where a=a and b="0::5 word" and 'a=40]
by (intro getTranslateCapAddressesI) (auto simp: word_size)

lemma getTranslateCapAddressesE [elim]:
  assumes "a \<in> getTranslateCapAddresses addrs t s"
  obtains virtualAddress physicalAddress
    where "getTranslateAddr (virtualAddress, t) s = Some physicalAddress"
      and "virtualAddress \<in> addrs"
      and "a = GetCapAddress physicalAddress"
using assms
unfolding getTranslateCapAddresses_def
by auto

lemma getTranslateCapAddresses_le:
  assumes "addrs \<subseteq> addrs'"
  shows "getTranslateCapAddresses addrs t s \<subseteq> getTranslateCapAddresses addrs' t s"
using assms
unfolding getTranslateCapAddresses_def
by auto

lemmas getTranslateCapAddresses_le_subsetD [elim] =
  subsetD[OF getTranslateCapAddresses_le]

lemma getTranslateCapAddresses_eqI_getTranslateAddr:
  assumes "\<And>a. getTranslateAddr a s' = getTranslateAddr a s"
  shows "getTranslateCapAddresses addrs t s' = getTranslateCapAddresses addrs t s"
using getTranslateAddresses_eqI_getTranslateAddr[OF assms]
unfolding getTranslateCapAddresses_def
by simp

lemma getTranslateCapAddresses_distrib_union:
  shows "getTranslateCapAddresses (addrs \<union> addrs') t s =
         (getTranslateCapAddresses addrs t s \<union> getTranslateCapAddresses addrs' t s)"
unfolding getTranslateCapAddresses_def
unfolding getTranslateAddresses_distrib_union
by auto

lemma getTranslateCapAddresses_distrib_Union:
  shows "getTranslateCapAddresses (\<Union>addrsSet) t s =
         (\<Union>addrs\<in>addrsSet. getTranslateCapAddresses addrs t s)"
unfolding getTranslateCapAddresses_def
unfolding getTranslateAddresses_distrib_Union
by auto

subsection \<open>Data writable addresses\<close>

definition StorablePhysAddresses where
  "StorablePhysAddresses gperm s \<equiv>
   getTranslateAddresses (StorableAddresses gperm) STORE s"

lemma StorablePhysAddresses_le:
  assumes "p \<le> q"
  shows "StorablePhysAddresses p s \<subseteq> StorablePhysAddresses q s"
using getTranslateAddresses_le[OF StorableAddresses_le[OF assms]]
unfolding StorablePhysAddresses_def
by auto

subsection \<open>Capability writable addresses\<close>

definition StorablePhysCapAddresses where
  "StorablePhysCapAddresses gperm s \<equiv>
   getTranslateCapAddresses (StorableAddresses gperm) STORE s"

lemma StorablePhysCapAddresses_le:
  assumes "p \<le> q"
  shows "StorablePhysCapAddresses p s \<subseteq> StorablePhysCapAddresses q s"
using StorableAddresses_le[OF assms]
using getTranslateCapAddresses_le
unfolding StorablePhysCapAddresses_def
by auto

subsection \<open>Always accessible registers\<close>

definition RegisterIsAlwaysAccessible :: "CapRegister \<Rightarrow> bool" where
  "RegisterIsAlwaysAccessible r \<equiv>
   case r of RegSpecial cd \<Rightarrow> cd = 0 \<or> cd = 1
           | _ \<Rightarrow> True"

lemma RegisterIsAlwaysAccessible_simps [simp]:
  shows "RegisterIsAlwaysAccessible RegPCC"
    and "RegisterIsAlwaysAccessible RegBranchDelayPCC"
    and "RegisterIsAlwaysAccessible RegBranchToPCC"
    and "RegisterIsAlwaysAccessible (RegGeneral cd)"
    and "RegisterIsAlwaysAccessible (RegSpecial 0)"
    and "RegisterIsAlwaysAccessible (RegSpecial 1)"
unfolding RegisterIsAlwaysAccessible_def
by simp_all

subsection \<open>Readable locations\<close>

definition ReadableLocations :: "CompartmentAuthority \<Rightarrow> state \<Rightarrow> CapLocation set" where
  "ReadableLocations f s \<equiv>
   {loc. case loc of
      LocReg r \<Rightarrow> RegisterIsAlwaysAccessible r
    | LocMem addr \<Rightarrow> addr \<in> getTranslateCapAddresses (CapLoadableAddresses f) LOAD s}"

lemma Commute_ReadableLocations [Commute_compositeI]:
  assumes "\<And>addrs. Commute (read_state (getTranslateCapAddresses addrs LOAD)) m"
  shows "Commute (read_state (ReadableLocations perm)) m"
using assms
unfolding ReadableLocations_def Commute_def
by auto

lemma ReadableLocations_simps [simp]:
  shows "(LocReg r) \<in> ReadableLocations f s =
         (RegisterIsAlwaysAccessible r)"
    and "(LocMem addr) \<in> ReadableLocations f s =
         (addr \<in> getTranslateCapAddresses (CapLoadableAddresses f) LOAD s)"
unfolding ReadableLocations_def
by simp_all

lemma ReadableLocations_le_subsetD [elim]:
  assumes "p \<le> q"
      and "loc \<in> ReadableLocations p s"
  shows "loc \<in> ReadableLocations q s"
proof (cases loc)
  case LocReg
  thus?thesis
    using assms by auto
next
  case (LocMem a)
  have "CapLoadableAddresses p \<subseteq> CapLoadableAddresses q"
    using assms by auto
  from getTranslateCapAddresses_le[OF this]
  show ?thesis
    using LocMem assms(2)
    by auto
qed

lemma ReadableLocations_le:
  assumes "p \<le> q"
  shows "ReadableLocations p s \<subseteq> ReadableLocations q s"
using ReadableLocations_le_subsetD[OF assms]
by auto

subsection \<open>Readable capabilities\<close>

definition ReadableCaps where
  "ReadableCaps perm s \<equiv>
   {getCap loc s
    |loc. loc \<in> ReadableLocations perm s \<and> getTag (getCap loc s)}"

lemma ReadableCapsI [intro?]:
  assumes "cap = getCap loc s"
      and "loc \<in> ReadableLocations perm s"
      and "getTag cap"
  shows "cap \<in> ReadableCaps perm s"
using assms
unfolding ReadableCaps_def
by auto

lemma ReadableCapsI_loc [elim!]:
  assumes "loc \<in> ReadableLocations perm s"
      and "getTag (getCap loc s)"
  shows "getCap loc s \<in> ReadableCaps perm s"
using assms
unfolding ReadableCaps_def
by auto

lemma ReadableCapsE_tag [elim!]:
  assumes "cap \<in> ReadableCaps perm s"
  shows "getTag cap"
using assms
unfolding ReadableCaps_def
by auto

lemma ReadableCapsE_loc [elim]:
  assumes "cap \<in> ReadableCaps perm s"
  obtains loc where "cap = getCap loc s"
                    "loc \<in> ReadableLocations perm s"
using assms
unfolding ReadableCaps_def
by auto

lemma ReadableCaps_le_subsetD [elim]:
  assumes "p \<le> q"
      and "cap \<in> ReadableCaps p s"
  shows "cap \<in> ReadableCaps q s"
using assms
unfolding ReadableCaps_def
by auto

lemma ReadableCaps_le:
  assumes "p \<le> q"
  shows "ReadableCaps p s \<subseteq> ReadableCaps q s"
using assms
by auto

subsection \<open>Generalised permissions of capabilities\<close>

definition GetAuthority :: "Capability \<Rightarrow> CompartmentAuthority" where
  "GetAuthority cap \<equiv>
   if getTag cap
   then let perms = getPerms cap in
         \<lparr>SystemRegisterAccess = Access_System_Registers perms,
          ExecutableAddresses = if Permit_Execute perms then RegionOfCap cap else {},
          LoadableAddresses = if Permit_Load perms then RegionOfCap cap else {},
          CapLoadableAddresses = if Permit_Load_Capability perms then RegionOfCap cap else {},
          StorableAddresses = if Permit_Store perms then RegionOfCap cap else {},
          CapStorableAddresses = if Permit_Store_Capability perms then RegionOfCap cap else {},
          LocalCapStorableAddresses = if Permit_Store_Local_Capability perms then RegionOfCap cap else {},
          SealableTypes = if Permit_Seal perms then {t. ucast t \<in> RegionOfCap cap} else {},
          UnsealableTypes = if Permit_Unseal perms then {t. ucast t \<in> RegionOfCap cap} else {}\<rparr>
   else bot"

lemma GetAuthority_accessors:
  shows "SystemRegisterAccess (GetAuthority cap) =
         (getTag cap \<and> Access_System_Registers (getPerms cap))"
    and "ExecutableAddresses (GetAuthority cap) =
         (if getTag cap \<and> Permit_Execute (getPerms cap)
          then RegionOfCap cap else {})"
    and "LoadableAddresses (GetAuthority cap) =
         (if getTag cap \<and> Permit_Load (getPerms cap)
          then RegionOfCap cap else {})"
    and "CapLoadableAddresses (GetAuthority cap) =
         (if getTag cap \<and> Permit_Load_Capability (getPerms cap)
          then RegionOfCap cap else {})"
    and "StorableAddresses (GetAuthority cap) =
         (if getTag cap \<and> Permit_Store (getPerms cap)
          then RegionOfCap cap else {})"
    and "CapStorableAddresses (GetAuthority cap) =
         (if getTag cap \<and> Permit_Store_Capability (getPerms cap)
          then RegionOfCap cap else {})"
    and "LocalCapStorableAddresses (GetAuthority cap) =
         (if getTag cap \<and> Permit_Store_Local_Capability (getPerms cap)
          then RegionOfCap cap else {})"
    and "SealableTypes (GetAuthority cap) =
         (if getTag cap \<and> Permit_Seal (getPerms cap)
          then {t. ucast t \<in> RegionOfCap cap} else {})"
    and "UnsealableTypes (GetAuthority cap) =
         (if getTag cap \<and> Permit_Unseal (getPerms cap)
          then {t. ucast t \<in> RegionOfCap cap} else {})"
unfolding GetAuthority_def Let_def
by simp_all

lemma GetAuthority_setMember_simp [simp]:
  shows "GetAuthority (setSealed (cap, v1)) = GetAuthority cap"
    and "GetAuthority (setType (cap, v2)) = GetAuthority cap"
    and "GetAuthority (setOffset (cap, v3)) = GetAuthority cap"
    and "GetAuthority (setUPerms (cap, v5)) = GetAuthority cap"
    and "GetAuthority (setTag (cap, False)) = bot"
unfolding GetAuthority_def
by (simp_all cong: cong)

lemma GetAuthority_le [intro]:
  assumes "cap' \<le> cap"
  shows "GetAuthority cap' \<le> GetAuthority cap"
proof (cases "getTag cap'")
  case False
  hence "GetAuthority cap' = bot"
    unfolding GetAuthority_def
    by simp
  thus ?thesis by auto
next
  case True
  have tag: "getTag cap"
  and segment: "RegionOfCap cap' \<subseteq> RegionOfCap cap"
  and perms: "getPerms cap' \<le> getPerms cap"
    using True assms
    by auto
  have *: "(if b then RegionOfCap cap' else {}) \<subseteq>
           (if b' then RegionOfCap cap else {})"
     if "RegionOfCap cap' \<noteq> {} \<longrightarrow> b \<longrightarrow> b'" for b b'
    using segment that by auto
  have "(if b then ({t. ucast t \<in> RegionOfCap cap'}::ObjectType set) else {}) \<subseteq>
        (if b' then {t. ucast t \<in> RegionOfCap cap} else {})"
     if "RegionOfCap cap' \<noteq> {} \<longrightarrow> b \<longrightarrow> b'" for b b'
    using segment that by auto
  thus ?thesis
    using True tag perms *
    unfolding less_eq_CompartmentAuthority_ext_def
    unfolding less_eq_Perms_ext_alt
    by (strong_cong_simp add: GetAuthority_accessors)
qed

definition GetAuthorityOfCaps where
  "GetAuthorityOfCaps caps \<equiv> Sup {GetAuthority cap |cap. cap \<in> caps}"

lemma GetAuthorityOfCaps_empty [simp]:
  shows "GetAuthorityOfCaps {} = bot"
unfolding GetAuthorityOfCaps_def
by simp

lemma GetAuthorityOfCaps_singleton [simp]:
  shows "GetAuthorityOfCaps {cap} = GetAuthority cap"
unfolding GetAuthorityOfCaps_def
by simp

lemma GetAuthorityOfCaps_accessors [simp]:
  shows "SystemRegisterAccess (GetAuthorityOfCaps caps) = (\<exists>cap\<in>caps. SystemRegisterAccess (GetAuthority cap))"
    and "ExecutableAddresses (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. ExecutableAddresses (GetAuthority cap))"
    and "LoadableAddresses (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. LoadableAddresses (GetAuthority cap))"
    and "CapLoadableAddresses (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. CapLoadableAddresses (GetAuthority cap))"
    and "StorableAddresses (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. StorableAddresses (GetAuthority cap))"
    and "CapStorableAddresses (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. CapStorableAddresses (GetAuthority cap))"
    and "LocalCapStorableAddresses (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. LocalCapStorableAddresses (GetAuthority cap))"
    and "SealableTypes (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. SealableTypes (GetAuthority cap))"
    and "UnsealableTypes (GetAuthorityOfCaps caps) = (\<Union>cap\<in>caps. UnsealableTypes (GetAuthority cap))"
    and "more (GetAuthorityOfCaps caps) = Sup (more ` GetAuthority ` caps)"
unfolding GetAuthorityOfCaps_def
by auto

lemma GetAuthorityOfCaps_subset [elim!]:
  assumes "caps \<subseteq> caps'"
  shows "GetAuthorityOfCaps caps \<le> GetAuthorityOfCaps caps'"
using assms
unfolding less_eq_CompartmentAuthority_ext_def
unfolding GetAuthorityOfCaps_def
unfolding Sup_CompartmentAuthority_ext_def
by auto

(*<*)
end
(*>*)


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

header{*The n_mutualExFsm Protocol Case Study*}

theory n_mutualExFsm_lemma_inv__2_on_rules imports n_mutualExFsm_lemma_on_inv__2
begin
section{*All lemmas on causal relation between inv__2*}
lemma lemma_inv__2_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0. p__Inv0\<le>N\<and>f=inv__2  p__Inv0)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_fsm  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_fsm  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_fsmVsinv__2) done
    }

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

end