(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory FastMap
imports
  LemmaBucket
begin

text \<open>
  Efficient rules and tactics for working with large lookup tables (maps).

  Features:
    \<^item> Define a binary lookup tree for any lookup table (requires linorder keys)
    \<^item> Conversion from lookup tree to lookup lists
    \<^item> Pre-computation of lookup results and domain/range sets

  See FastMap_Test for examples.
\<close>

(*
 * TODO:
 *
 *   • Storing the auxilliary list theorems with Local_Theory.notes
 *     takes quadratic time. Unfortunately, this seems to be a problem
 *     deep inside the Isabelle implementation. One might try to wrap
 *     the lists in new constants, but Local_Theory.define also takes
 *     quadratic time.
 *
 *   • Still a bit slower than the StaticFun package. Streamline the
 *     rulesets and proofs.
 *
 *   • We use a lot of manual convs for performance and to avoid
 *     relying on the dynamic simpset. However, we should clean up the
 *     convs and move as much as possible to (simp only:) invocations.
 *
 *     Note that running simp on deeply nested terms (e.g. lists)
 *     always takes quadratic time and we can't use it there. This is
 *     because rewritec unconditionally calls eta_conversion (urgh).
 *
 *   • The injectivity prover currently hardcodes inj_def into the
 *     simpset. This should be changed at some point, probably by
 *     asking the user to prove it beforehand.
 *
 *   • The key ordering prover is currently hardcoded to simp_tac;
 *     this should also be generalised. On the other hand, the user
 *     could work around this by manually supplying a simpset with
 *     precisely the needed theorems.
 *
 *   • Using the simplifier to evaluate tree lookups is still quite
 *     slow because it looks at the entire tree term (even though
 *     most of it is irrelevant for any given lookup). We should
 *     provide a tactic or simproc to do this.
 *
 *     We already generate lookup theorems for keys in the map, so
 *     this tactic should be optimised for missing keys.
 *
 *   • The linorder requirement can be cumbersome. It arises because
 *     we express the map_of conversion as a general theorem using
 *     lookup_tree_valid. An alternative approach is to extend what
 *     StaticFun does, and cleverly extract the set of all relevant
 *     bindings from the tree on a case-by-case basis.
 *
 *     We would still need to evaluate the key ordering function on
 *     the input keys, but any arbitrary relation would be allowed.
 *     This one probably calls for a wizard.
 *)

locale FastMap begin

text \<open>
  Binary lookup tree. This is largely an implementation detail, so we
  choose the structure to make automation easier (e.g. separate fields
  for the key and value).

  We could reuse HOL.Tree instead, but the proofs would need changing.
\<close>
datatype ('k, 'v) Tree =
    Leaf
  | Node 'k 'v "('k, 'v) Tree" "('k, 'v) Tree"

primrec lookup_tree :: "('k \<Rightarrow> 'ok :: linorder) \<Rightarrow> ('k, 'v) Tree \<Rightarrow> 'k \<Rightarrow> 'v option"
  where
    "lookup_tree key Leaf x = None"
  | "lookup_tree key (Node k v l r) x =
       (if key x = key k then Some v
        else if key x < key k then lookup_tree key l x
        else lookup_tree key r x)"

text \<open>
  Predicate for well-formed lookup trees.
  This states that the keys are distinct and appear in ascending order.
  It also returns the lowest and highest keys in the tree (or None for empty trees).
\<close>
primrec lookup_tree_valid ::
        "('k \<Rightarrow> 'ok :: linorder) \<Rightarrow> ('k, 'v) Tree \<Rightarrow> bool \<times> ('k \<times> 'k) option"
  where
    "lookup_tree_valid key Leaf = (True, None)"
  | "lookup_tree_valid key (Node k v lt rt) =
       (let (lt_valid, lt_range) = lookup_tree_valid key lt;
            (rt_valid, rt_range) = lookup_tree_valid key rt;
            lt_low = (case lt_range of None \<Rightarrow> k | Some (low, high) \<Rightarrow> low);
            rt_high = (case rt_range of None \<Rightarrow> k | Some (low, high) \<Rightarrow> high)
        in (lt_valid \<and> rt_valid \<and>
            (case lt_range of None \<Rightarrow> True | Some (low, high) \<Rightarrow> key high < key k) \<and>
            (case rt_range of None \<Rightarrow> True | Some (low, high) \<Rightarrow> key k < key low),
            Some (lt_low, rt_high)))"

lemma lookup_tree_valid_simps':
  "lookup_tree_valid key Leaf = (True, None)"
  "lookup_tree_valid key (Node k v Leaf Leaf) = (True, Some (k, k))"
  "\<lbrakk> lookup_tree_valid key (Node lk lv llt lrt) = (True, Some (llow, lhigh));
     key lhigh < key k
   \<rbrakk> \<Longrightarrow> lookup_tree_valid key (Node k v (Node lk lv llt lrt) Leaf) =
           (True, Some (llow, k))"
  "\<lbrakk> lookup_tree_valid key (Node rk rv rlt rrt) = (True, Some (rlow, rhigh));
     key k < key rlow
   \<rbrakk> \<Longrightarrow> lookup_tree_valid key (Node k v Leaf (Node rk rv rlt rrt)) =
           (True, Some (k, rhigh))"
  "\<lbrakk> lookup_tree_valid key (Node lk lv llt lrt) = (True, Some (llow, lhigh));
     lookup_tree_valid key (Node rk rv rlt rrt) = (True, Some (rlow, rhigh));
     key lhigh < key k;
     key k < key rlow
   \<rbrakk> \<Longrightarrow> lookup_tree_valid key (Node k v (Node lk lv llt lrt) (Node rk rv rlt rrt)) =
           (True, Some (llow, rhigh))"
  by auto

lemma lookup_tree_valid_empty:
  "lookup_tree_valid key tree = (True, None) \<Longrightarrow> tree = Leaf"
  apply (induct tree)
   apply simp
  apply (fastforce split: prod.splits option.splits if_splits)
  done

lemma lookup_tree_valid_range:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow> key low \<le> key high"
  apply (induct tree arbitrary: low high)
   apply simp
  apply (fastforce split: prod.splits option.splits if_splits)
  done

lemma lookup_tree_valid_in_range:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow>
   lookup_tree key tree k = Some v \<Longrightarrow>
   key k \<in> {key low .. key high}"
  apply (induct tree arbitrary: k v low high)
   apply simp
  apply (fastforce split: prod.splits option.splits if_split_asm
                   dest: lookup_tree_valid_empty lookup_tree_valid_range)
  done

lemma lookup_tree_valid_in_range_None:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow>
   key k \<notin> {key low .. key high} \<Longrightarrow>
   lookup_tree key tree k = None"
  using lookup_tree_valid_in_range by fastforce

text \<open>
  Flatten a lookup tree into an assoc-list.
  As long as the tree is well-formed, both forms are equivalent.
\<close>
primrec lookup_tree_to_list :: "('k, 'v) Tree \<Rightarrow> ('k \<times> 'v) list"
  where
    "lookup_tree_to_list Leaf = []"
  | "lookup_tree_to_list (Node k v lt rt) =
        lookup_tree_to_list lt @ [(k, v)] @ lookup_tree_to_list rt"

lemma lookup_tree_to_list_range:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow>
   (k, v) \<in> set (lookup_tree_to_list tree) \<Longrightarrow>
   key k \<in> {key low .. key high}"
  apply (induct tree arbitrary: k v low high)
   apply simp
  apply (fastforce split: prod.splits option.splits if_split_asm
                   dest: lookup_tree_valid_empty lookup_tree_valid_range)
  done

lemma lookup_tree_dom_distinct_sorted_:
  "fst (lookup_tree_valid key tree) \<Longrightarrow>
   distinct (lookup_tree_to_list tree) \<and> sorted (map (key o fst) (lookup_tree_to_list tree))"
  apply (induct tree)
   apply simp
  apply (fastforce simp: sorted_append
                   split: prod.splits option.splits if_splits
                   dest: lookup_tree_valid_empty lookup_tree_valid_range
                         lookup_tree_valid_in_range lookup_tree_to_list_range
                   elim: lookup_tree_valid_in_range_None)
  done

lemmas lookup_tree_dom_distinct = lookup_tree_dom_distinct_sorted_[THEN conjunct1]
lemmas lookup_tree_dom_sorted = lookup_tree_dom_distinct_sorted_[THEN conjunct2]

(* This goal is eta-expanded and flipped, which seems to help its proof *)
lemma lookup_tree_to_list_of_:
  "fst (lookup_tree_valid key tree) \<Longrightarrow>
   map_of (map (apfst key) (lookup_tree_to_list tree)) (key k) = lookup_tree key tree k"
  apply (induct tree arbitrary: k)
   apply simp
  (* this big blob just does case distinctions of both subtrees and
     all possible lookup results within each, then solves *)
  (* slow 10s *)
  by (fastforce simp: apfst_def map_prod_def map_add_def
                split: prod.splits option.splits if_splits
                dest: lookup_tree_valid_empty lookup_tree_valid_range lookup_tree_valid_in_range
                elim: lookup_tree_valid_in_range_None)

(* Standard form of above *)
lemma lookup_tree_to_list_of:
  "fst (lookup_tree_valid key tree) \<Longrightarrow>
   lookup_tree key tree = map_of (map (apfst key) (lookup_tree_to_list tree)) o key"
  apply (rule ext)
  apply (simp add: lookup_tree_to_list_of_)
  done

lemma map_of_key:
  "inj key \<Longrightarrow> map_of (map (apfst key) binds) o key = map_of binds"
  apply (rule ext)
  apply (induct binds)
   apply simp
  apply (clarsimp simp: inj_def dom_def)
  done

lemma lookup_tree_to_list_of_distinct:
  "\<lbrakk> fst (lookup_tree_valid key tree);
     lookup_tree_to_list tree = binds;
     lookup_tree key tree = map_of (map (apfst key) binds) o key
   \<rbrakk> \<Longrightarrow> distinct (map (key o fst) binds)"
  apply (drule sym[where t = binds])
  apply clarsimp
  apply (thin_tac "binds = _")
  apply (induct tree)
   apply simp
  apply (fastforce simp: map_add_def lookup_tree_to_list_of
                   split: prod.splits option.splits if_splits
                   dest: lookup_tree_valid_empty lookup_tree_valid_range
                         lookup_tree_valid_in_range lookup_tree_to_list_range
                   elim: lookup_tree_valid_in_range_None)
  done

(* Top-level rule for converting to lookup list.
   We add a distinctness assertion for inferring the range of values. *)
lemma lookup_tree_to_list_of_gen:
  "\<lbrakk> inj key;
     fst (lookup_tree_valid key tree);
     lookup_tree_to_list tree = binds
   \<rbrakk> \<Longrightarrow> lookup_tree key tree = map_of binds \<and> distinct (map fst binds)"
  using lookup_tree_to_list_of
  apply (fastforce intro: lookup_tree_to_list_of_distinct
                   simp: map_of_key distinct_inj)
  done

text \<open>
  Domain and range of a @{const map_of}.
  Like @{thm dom_map_of_conv_image_fst} but leaving out the set bloat.
\<close>
lemma dom_map_of_conv_list:
  "dom (map_of xs) = set (map fst xs)"
  by (simp add: dom_map_of_conv_image_fst)

lemma ran_map_of_conv_list:
  "distinct (map fst xs) \<Longrightarrow> ran (map_of xs) = set (map snd xs)"
  by (erule distinct_map_via_ran)

text \<open>
  Read lookup rules from a @{const map_of}.
\<close>

lemma map_of_lookups:
  "m = map_of binds \<and> distinct (map fst binds) \<Longrightarrow>
   list_all (\<lambda>(k, v). m k = Some v) binds"
  apply (induct binds)
   apply simp
  apply (force simp: list_all_iff)
  done

(* Helper for converting from maps defined as @{const fun_upd} chains,
 * which are applied in reverse order *)
lemma map_of_rev:
  "distinct (map fst binds) \<Longrightarrow>
   map_of (rev binds) = map_of binds"
  apply (subgoal_tac "distinct (map fst (rev binds))")
   apply (rule ext)
   apply (induct binds)
    apply simp
   apply (force simp: map_add_def split: option.splits)
  apply (metis distinct_rev rev_map)
  done

lemma list_all_dest:
  "list_all P [(x, y)] \<equiv> P (x, y)"
  "list_all P ((x, y) # z # xs) \<equiv> (P (x, y) \<and> list_all P (z # xs))"
  by auto

(* Install lookup rules that don't depend on if_cong/if_weak_cong setup *)
lemma lookup_tree_simps':
  "lookup_tree key Leaf x = None"
  "key x = key k \<Longrightarrow> lookup_tree key (Node k v l r) x = Some v"
  "key x < key k \<Longrightarrow> lookup_tree key (Node k v l r) x = lookup_tree key l x"
  "key x > key k \<Longrightarrow> lookup_tree key (Node k v l r) x = lookup_tree key r x"
  by auto
end

declare FastMap.lookup_tree.simps[simp del]
declare FastMap.lookup_tree_simps'[simp]

ML \<open>
structure FastMap = struct

(* utils *)
fun mk_optionT typ = Type ("Option.option", [typ])
fun dest_optionT (Type ("Option.option", [typ])) = typ
  | dest_optionT t = raise TYPE ("dest_optionT", [t], [])

(* O(1) version of thm RS @{thm eq_reflection} *)
fun then_eq_reflection thm = let
  val (x, y) = Thm.dest_binop (Thm.dest_arg (Thm.cprop_of thm));
  val cT = Thm.ctyp_of_cterm x;
  val rule = @{thm eq_reflection} |> Thm.instantiate' [SOME cT] [SOME x, SOME y];
  in Thm.implies_elim rule thm end;

val lhs_conv = Conv.fun_conv o Conv.arg_conv
val rhs_conv = Conv.arg_conv
(* first order rewr_conv *)
fun fo_rewr_conv rule ct = let
  val (pure_eq, eqn) =
        ((true, Thm.instantiate (Thm.first_order_match (Thm.lhs_of rule, ct)) rule)
         handle TERM _ =>
           (false, Thm.instantiate (Thm.first_order_match
                      (fst (Thm.dest_binop (Thm.dest_arg (Thm.cprop_of rule))), ct)) rule))
        handle Pattern.MATCH => raise CTERM ("fo_rewr_conv", [Thm.cprop_of rule, ct]);
  in if pure_eq then eqn else then_eq_reflection eqn end;
fun fo_rewrs_conv rules = Conv.first_conv (map fo_rewr_conv rules);

(* Evaluate a term with rewrite rules. Unlike the simplifier, this
 * does only one top-down pass, but that's enough for tasks like
 * pushing List.map through a list. Also runs much faster. *)
fun fo_topdown_rewr_conv rules ctxt =
      Conv.top_conv (K (Conv.try_conv (fo_rewrs_conv rules))) ctxt

(* Allow recursive conv in cv2, deferred by function application *)
infix 1 then_conv'
fun (cv1 then_conv' cv2) ct =
  let
    val eq1 = cv1 ct;
    val eq2 = cv2 () (Thm.rhs_of eq1);
  in
    if Thm.is_reflexive eq1 then eq2
    else if Thm.is_reflexive eq2 then eq1
    else Thm.transitive eq1 eq2
  end;

(*
 * Helper that makes it easier to describe where to apply a conv.
 * This takes a skeleton term and applies the conversion wherever "HERE"
 * appears in the skeleton.
 *
 * FIXME: use HOL-Library.Rewrite instead
 *)
fun conv_at skel conv ctxt ct = let
  fun mismatch current_skel current_ct =
    raise TERM ("conv_at mismatch", [current_skel, Thm.term_of current_ct, skel, Thm.term_of ct])

  fun walk (Free ("HERE", _)) _ ct = conv ct
    | walk (skel as skel_f $ skel_x) ctxt ct =
        (case Thm.term_of ct of
            _ $ _ => Conv.combination_conv (walk skel_f ctxt) (walk skel_x ctxt) ct
          | _ => mismatch skel ct)
    | walk (skel as Abs (_, _, skel_body)) ctxt ct =
        (case Thm.term_of ct of
            Abs _ => Conv.abs_conv (fn (_, ctxt') => walk skel_body ctxt') ctxt ct
          | _ => mismatch skel ct)
    (* Also check that Consts match the skeleton pattern *)
    | walk (skel as Const (skel_name, _)) _ ct =
        if (case Thm.term_of ct of Const (name, _) => name = skel_name | _ => false)
        then Thm.reflexive ct
        else mismatch skel ct
    (* Default case *)
    | walk _ _ ct = Thm.reflexive ct
  in walk skel ctxt ct end

fun gconv_at_tac pat conv ctxt = Conv.gconv_rule (conv_at pat conv ctxt) 1 #> Seq.succeed

(* Tree builder code, copied from StaticFun *)

(* Actually build the tree -- theta (n lg(n)) *)
fun build_tree' _ mk_leaf [] = mk_leaf
  | build_tree' mk_node mk_leaf xs = let
    val len = length xs
    val (ys, zs) = chop (len div 2) xs
  in case zs of [] => error "build_tree': impossible"
    | ((a, b) :: zs) => mk_node a b (build_tree' mk_node mk_leaf ys)
        (build_tree' mk_node mk_leaf zs)
  end

fun build_tree xs = case xs of [] => error "build_tree : empty"
  | (idx, v) :: _ => let
    val idxT = fastype_of idx
    val vT = fastype_of v
    val treeT = Type (@{type_name FastMap.Tree}, [idxT, vT])
    val mk_leaf = Const (@{const_name FastMap.Leaf}, treeT)
    val node = Const (@{const_name FastMap.Node},
        idxT --> vT --> treeT --> treeT --> treeT)
    fun mk_node a b l r = node $ a $ b $ l $ r
  in
    build_tree' mk_node mk_leaf xs
  end

fun define_partial_map_tree map_name mappings ord_term ctxt = let
    val (idxT, vT) = apply2 fastype_of (hd mappings)
    val treeT = Type (@{type_name FastMap.Tree}, [idxT, vT])
    val lookup = Const (@{const_name FastMap.lookup_tree},
                        fastype_of ord_term --> treeT --> idxT
                            --> Type (@{type_name option}, [vT]))
    val map_term = lookup $ ord_term $ build_tree mappings
    val ((map_const, (_, map_def)), ctxt) =
          Local_Theory.define ((map_name, NoSyn), ((Thm.def_binding map_name, []), map_term)) ctxt
  in
    ((map_const, map_def), ctxt)
  end

(* Prove key ordering theorems. This lets us issue precise error messages
   when the user gives us keys whose ordering cannot be verified.
   We will also need these thms to prove the lookup_tree_valid property. *)
fun prove_key_ord_thms tree_name keyT mappings get_key simp_ctxt ctxt =
  let
    val solver = simp_tac (simp_ctxt ctxt [] []) 1;
  in
    fst (split_last mappings) ~~ tl mappings
    |> map_index (fn (i, ((k1, _), (k2, _))) => let
           val prop = Const (@{const_name less}, keyT --> keyT --> HOLogic.boolT) $
                            (get_key $ k1) $ (get_key $ k2)
                      |> HOLogic.mk_Trueprop;
           in case try (Goal.prove ctxt [] [] prop) (K solver) of
                  SOME x => x
                | _ => raise TERM (tree_name ^ ": failed to prove less-than ordering for keys #" ^
                                   string_of_int i ^ ", #" ^ string_of_int (i + 1),
                                   [prop])
           end)
  end;

(* Prove lookup_tree_valid *)
fun prove_tree_valid tree_name mappings kT keyT tree_term get_key simp_ctxt ctxt = let
    val key_ord_thms = prove_key_ord_thms tree_name keyT mappings get_key simp_ctxt ctxt;
    val treeT = fastype_of tree_term
    val valid_resultT = HOLogic.mk_prodT (HOLogic.boolT, mk_optionT (HOLogic.mk_prodT (kT, kT)))
    val tree_valid_prop =
          HOLogic.mk_Trueprop (
            Const (@{const_name fst}, valid_resultT --> HOLogic.boolT) $
            (Const (@{const_name FastMap.lookup_tree_valid},
                    (kT --> keyT) --> treeT --> valid_resultT) $
               get_key $ tree_term))
    val solver = simp_tac (put_simpset HOL_basic_ss ctxt
                           addsimps (@{thms prod.sel FastMap.lookup_tree_valid_simps'} @
                                     key_ord_thms)) 1
  in Goal.prove ctxt [] [] tree_valid_prop (K solver) end

fun solve_simp_tac name ctxt = SUBGOAL (fn (t, i) =>
      (simp_tac ctxt THEN_ALL_NEW SUBGOAL (fn (t', _) =>
          raise TERM (name ^ ": unsolved", [t, t']))) i)

fun convert_to_lookup_list kT valT mappings map_const map_def tree_valid_thm simp_ctxt ctxt = let
  val lookupT = fastype_of map_const
  (* map_eq = "<tree_const> = map_of <mappings>" *)
  val bindT = HOLogic.mk_prodT (kT, valT)
  val lookup_list = HOLogic.mk_list bindT (map HOLogic.mk_prod mappings)
  val map_of_Const = Const (@{const_name map_of}, HOLogic.listT bindT --> lookupT)
  val map_eq = HOLogic.mk_eq (map_const, map_of_Const $ lookup_list)
  (* distinct_pred = "distinct (map fst <mappings>)" *)
  val distinct_pred =
        Const (@{const_name distinct}, HOLogic.listT kT --> HOLogic.boolT) $
          (Const (@{const_name map}, (bindT --> kT) --> HOLogic.listT bindT --> HOLogic.listT kT) $
             Const (@{const_name fst}, bindT --> kT) $
             lookup_list)
  val convert_prop = HOLogic.mk_Trueprop (
        HOLogic.mk_conj (map_eq, distinct_pred)
        )
  fun TIMED desc tac = fn st =>
        Seq.make (K (Timing.timeap_msg ("tactic timing for " ^ desc)
                          (fn () => Seq.pull (tac st)) ()))

  val append_basecase = @{thm append.simps(1)}
  val append_rec = @{thm append.simps(2)}
  val lookup_tree_to_list_basecase = @{thm FastMap.lookup_tree_to_list.simps(1)}
  val lookup_tree_to_list_rec = @{thm FastMap.lookup_tree_to_list.simps(2)[simplified append.simps]}

  val lookup_tree_to_list_eval = let
    fun append_conv () =
            fo_rewr_conv append_basecase else_conv
            (fo_rewr_conv append_rec then_conv'
             (fn () => rhs_conv (append_conv ())))
    fun to_map_conv () =
            fo_rewr_conv lookup_tree_to_list_basecase else_conv
            (fo_rewr_conv lookup_tree_to_list_rec then_conv'
             (fn () => lhs_conv (to_map_conv ())) then_conv'
             (fn () => rhs_conv (rhs_conv (to_map_conv ()))) then_conv
             append_conv ())
  in to_map_conv () end

  val solver =
        TIMED "unfold" (gconv_at_tac @{term "Trueprop (HERE = map_of dummy1 \<and> dummy2)"}
                                     (K map_def) ctxt)
        THEN
        TIMED "main rule" (resolve_tac ctxt @{thms FastMap.lookup_tree_to_list_of_gen} 1)
        THEN
          TIMED "solve inj" (solve_simp_tac "solve inj"
                              (simp_ctxt ctxt @{thms simp_thms} @{thms inj_def}) 1)
          THEN
         TIMED "resolve valid" (resolve_tac ctxt [tree_valid_thm] 1)
         THEN
        TIMED "convert tree" (gconv_at_tac @{term "Trueprop (HERE = dummy1)"}
                                           lookup_tree_to_list_eval ctxt)
        THEN
        resolve_tac ctxt @{thms refl} 1
  val convert_thm = Goal.prove ctxt [] [] convert_prop (K solver)
  in convert_thm end

(* Obtain domain and range from lookup list *)
fun domain_range_common dom_ran_const xT xs map_const lookup_list_eqn intro_conv_tac ctxt = let
  val mapT = fastype_of map_const
  val prop = HOLogic.mk_Trueprop (
        HOLogic.mk_eq (
          Const (dom_ran_const, mapT --> HOLogic.mk_setT xT) $ map_const,
          Const (@{const_name set}, HOLogic.listT xT --> HOLogic.mk_setT xT) $
            (HOLogic.mk_list xT xs)
        ))
  val lookup_list_eqn' = then_eq_reflection lookup_list_eqn
  val map_fst_snd_conv = fo_topdown_rewr_conv @{thms list.map prod.sel} ctxt
  val solver =
        (gconv_at_tac @{term "Trueprop (dom_ran_dummy1 HERE = dummy2)"}
                      (K lookup_list_eqn') ctxt)
        THEN
        intro_conv_tac
        THEN
        gconv_at_tac @{term "Trueprop (HERE = dummy1)"} map_fst_snd_conv ctxt
        THEN
        resolve_tac ctxt @{thms refl} 1
  in Goal.prove ctxt [] [] prop (K solver) end;

fun tree_domain kT mappings map_const lookup_list_eqn ctxt =
  domain_range_common
    @{const_name dom} kT (map fst mappings) map_const lookup_list_eqn
    (* like (subst dom_map_of_conv_list) but faster *)
    (resolve_tac ctxt @{thms FastMap.dom_map_of_conv_list[THEN trans]} 1)
    ctxt;

fun tree_range valT mappings map_const lookup_list_eqn map_distinct_thm ctxt =
  domain_range_common
    @{const_name ran} valT (map snd mappings) map_const lookup_list_eqn
    (* like (subst ran_map_of_conv_list) but faster *)
    (resolve_tac ctxt @{thms FastMap.ran_map_of_conv_list[THEN trans]} 1 THEN
     resolve_tac ctxt [map_distinct_thm] 1)
    ctxt;

(* Choosing names for the const and its theorems. The constant will be named with
   map_name; Local_Theory.define may also add extra names (e.g. <map_name>_def) *)
type name_opts = {
    map_name: string,
    tree_valid_thm: string,
    to_lookup_list: string,
    keys_distinct_thm: string,
    lookup_thms: string,
    domain_thm: string,
    range_thm: string
};

fun name_opts_default (map_name: string): name_opts = {
    map_name = map_name,
    tree_valid_thm = map_name ^ "_tree_valid",
    to_lookup_list = map_name ^ "_to_lookup_list",
    keys_distinct_thm = map_name ^ "_keys_distinct",
    lookup_thms = map_name ^ "_lookups",
    domain_thm = map_name ^ "_domain",
    range_thm = map_name ^ "_range"
};

(* Top level interface *)
fun define_map
            (name_opts: name_opts)
            (mappings: (term * term) list)
            (get_key: term) (* function to get linorder key, must be injective *)
            (extra_simps: thm list)
            (minimal_simp: bool) (* true: start with minimal simpset; extra_simps must be adequate *)
            ctxt = let
    fun simp_ctxt ctxt basic_simps more_simps = if minimal_simp
      then put_simpset HOL_basic_ss ctxt addsimps (basic_simps @ extra_simps @ more_simps)
      else ctxt addsimps (extra_simps @ more_simps)

    val (kT, keyT) = dest_funT (fastype_of get_key)
    val valT = fastype_of (snd (hd mappings))

    val _ = tracing (#map_name name_opts ^ ": defining tree")
    val start = Timing.start ()
    val ((map_const, map_def), ctxt) =
            define_partial_map_tree
                (Binding.name (#map_name name_opts))
                mappings get_key ctxt
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    val _ = tracing (#map_name name_opts ^ ": proving tree is well-formed")
    val start = Timing.start ()
    val _ $ _ $ tree_term = Thm.term_of (Thm.rhs_of map_def)
    val tree_valid_thm =
          prove_tree_valid (#map_name name_opts) mappings kT keyT tree_term get_key simp_ctxt ctxt
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#tree_valid_thm name_opts), []), [([tree_valid_thm], [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    val _ = tracing (#map_name name_opts ^ ": converting tree to map")
    val start = Timing.start ()
    val convert_thm =
          convert_to_lookup_list kT valT mappings map_const map_def tree_valid_thm simp_ctxt ctxt
    val [lookup_list_eqn, map_distinct_thm] = HOLogic.conj_elims ctxt convert_thm
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))
    val _ = tracing (#map_name name_opts ^ ": storing map and distinctness theorems")
    val start = Timing.start ()
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#to_lookup_list name_opts), []), [([lookup_list_eqn], [])]),
         ((Binding.name (#keys_distinct_thm name_opts), []), [([map_distinct_thm], [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    val _ = tracing (#map_name name_opts ^ ": obtaining lookup rules")
    val start = Timing.start ()
    fun dest_list_all_conv () =
          fo_rewr_conv @{thm FastMap.list_all_dest(1)} else_conv
          (fo_rewr_conv @{thm FastMap.list_all_dest(2)} then_conv'
           (fn () => rhs_conv (dest_list_all_conv())))
    val combined_lookup_thm =
          (convert_thm RS @{thm FastMap.map_of_lookups})
          |> Conv.fconv_rule (conv_at @{term "Trueprop HERE"} (dest_list_all_conv ()) ctxt)
    val _ = tracing ("  splitting... " ^ Timing.message (Timing.result start))
    val lookup_thms =
          HOLogic.conj_elims ctxt combined_lookup_thm
          |> map (Conv.fconv_rule (conv_at @{term "Trueprop HERE"}
                                     (fo_rewr_conv @{thm prod.case[THEN eq_reflection]}) ctxt))

    val _ = if length lookup_thms = length mappings then () else
              raise THM ("wrong number of lookup thms: " ^ string_of_int (length lookup_thms) ^
                         " instead of " ^ string_of_int (length mappings), 0,
                         lookup_thms)
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#lookup_thms name_opts), []), [(lookup_thms, [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    (* domain and range *)
    val _ = tracing (#map_name name_opts ^ ": getting domain and range")
    val start = Timing.start ()
    val domain_thm = timeap_msg "  calculate domain"
            (tree_domain kT mappings map_const lookup_list_eqn) ctxt
    val range_thm = timeap_msg "  calculate range"
            (tree_range valT mappings map_const lookup_list_eqn map_distinct_thm) ctxt
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#domain_thm name_opts), []), [([domain_thm], [])]),
         ((Binding.name (#range_thm name_opts), []), [([range_thm], [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))
  in ctxt end

end
\<close>

end


theory IICF_List_MsetO
imports "../Intf/IICF_Multiset"
begin

  definition "lmso_assn A \<equiv> hr_comp (list_assn A) (br mset (\<lambda>_. True))"
  lemmas [fcomp_norm_unfold] = lmso_assn_def[symmetric]

  lemma lmso_is_pure[safe_constraint_rules]: "is_pure A \<Longrightarrow> is_pure (lmso_assn A)"
    unfolding lmso_assn_def by safe_constraint

  lemma lmso_empty_aref: "(uncurry0 (RETURN []), uncurry0 (RETURN op_mset_empty)) \<in> unit_rel \<rightarrow>\<^sub>f \<langle>br mset (\<lambda>_. True)\<rangle>nres_rel"
    by (auto intro!: frefI nres_relI simp: in_br_conv)

  (*
  definition [simp]: "list_single x \<equiv> [x]"
  lemma lmso_single_aref: "(RETURN o list_single,RETURN o op_mset_single) \<in> Id \<rightarrow>\<^sub>f \<langle>br mset (\<lambda>_. True)\<rangle>nres_rel"
    by (auto intro!: frefI nres_relI simp: in_br_conv)
  *)

  lemma lmso_is_empty_aref: "(RETURN o List.null, RETURN o op_mset_is_empty) \<in> br mset (\<lambda>_. True) \<rightarrow>\<^sub>f \<langle>bool_rel\<rangle>nres_rel"
    by (auto intro!: frefI nres_relI simp: in_br_conv List.null_def split: list.split)

  lemma lmso_insert_aref: "(uncurry (RETURN oo (#) ), uncurry (RETURN oo op_mset_insert)) \<in> (Id \<times>\<^sub>r br mset (\<lambda>_. True)) \<rightarrow>\<^sub>f \<langle>br mset (\<lambda>_. True)\<rangle>nres_rel"
    by (auto intro!: frefI nres_relI simp: in_br_conv)

  (*
  lemma list_single_hnr: "(return o list_single, RETURN o list_single) \<in> A\<^sup>d \<rightarrow>\<^sub>a list_assn A"
    apply sepref_to_hoare
    apply sep_auto
    done
  *)

  definition [simp]: "hd_tl l \<equiv> (hd l, tl l)"

  lemma hd_tl_opt[sepref_opt_simps]: "hd_tl l = (case l of (x#xs) \<Rightarrow> (x,xs) | _ \<Rightarrow> CODE_ABORT (\<lambda>_. (hd l, tl l)))"
    by (auto split: list.split)

  lemma lmso_pick_aref: "(RETURN o hd_tl,op_mset_pick) \<in> [\<lambda>m. m\<noteq>{#}]\<^sub>f br mset (\<lambda>_. True) \<rightarrow> \<langle>Id \<times>\<^sub>r br mset (\<lambda>_. True)\<rangle>nres_rel"
    by (auto intro!: frefI nres_relI simp: in_br_conv pw_le_iff refine_pw_simps neq_Nil_conv algebra_simps)

  lemma hd_tl_hnr: "(return o hd_tl,RETURN o hd_tl) \<in> [\<lambda>l. \<not>is_Nil l]\<^sub>a (list_assn A)\<^sup>d \<rightarrow> prod_assn A (list_assn A)"
    apply sepref_to_hoare
    subgoal for l li by (cases l; cases li; sep_auto)
    done

  sepref_decl_impl (no_register) lmso_empty: hn_Nil[to_hfref] uses lmso_empty_aref .
  definition [simp]: "op_lmso_empty \<equiv> op_mset_empty"
  sepref_register op_lmso_empty
  lemma lmso_fold_custom_empty:
    "{#} = op_lmso_empty"
    "op_mset_empty = op_lmso_empty"
    "mop_mset_empty = RETURN op_lmso_empty"
    by auto
  lemmas [sepref_fr_rules] = lmso_empty_hnr[folded op_lmso_empty_def]

  (*
  sepref_decl_impl (no_register) lmso_single: list_single_hnr uses lmso_single_aref .
  definition [simp]: "op_lmso_single \<equiv> op_mset_single"
  sepref_register op_lmso_single
  lemma lmso_fold_custom_single:
    "{#x#} = op_lmso_single x"
    "op_mset_single x = op_lmso_single x"
    "mop_mset_single x = RETURN (op_lmso_single x)"
    by auto
  lemmas [sepref_fr_rules] = lmso_single_hnr[folded op_lmso_single_def]
 *)

  sepref_decl_impl lmso_is_empty: list_null_hnr uses lmso_is_empty_aref .

  sepref_decl_impl lmso_insert: hn_Cons[to_hfref] uses lmso_insert_aref .

  (* As parametricity heuristics of sepref_decl_impl fails here,
    we use FCOMP and some dummy-lemma to still get the automation benefits of
    sepref_decl_impl. *)
  context notes [simp] = in_br_conv and [split] = list.splits begin
    text \<open>Dummy lemma, to exloit \<open>sepref_decl_impl\<close> automation without parametricity stuff.\<close>
    private lemma op_mset_pick_dummy_param: "(op_mset_pick, op_mset_pick) \<in> Id \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel"
      by (auto intro!: frefI nres_relI)

    sepref_decl_impl lmso_pick: hd_tl_hnr[FCOMP lmso_pick_aref] uses op_mset_pick_dummy_param by simp
  end

end


(*  Title:      HOL/Auth/n_mutualEx_lemma_inv__1_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_mutualEx Protocol Case Study*}

theory n_mutualEx_lemma_inv__1_on_rules imports n_mutualEx_lemma_on_inv__1
begin
section{*All lemmas on causal relation between inv__1*}
lemma lemma_inv__1_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__1  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__1) done
    }

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

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

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

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

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Author: Andrew Boyton, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Defining some separation logic maps-to predicates on top of the instantiation."

theory Separation_D
imports Abstract_Separation_D
begin

type_synonym sep_pred = "sep_state \<Rightarrow> bool"

definition
  state_sep_projection :: "cdl_state \<Rightarrow> sep_state"
where
  "state_sep_projection \<equiv> \<lambda>s. SepState (cdl_objects s) (cdl_ghost_state s)"

(* This turns a separation logic predicate into a predicate on the capDL state. *)
abbreviation
  lift' :: "(sep_state \<Rightarrow> 'a) \<Rightarrow> cdl_state \<Rightarrow> 'a" ("<_>")
where
  "<P> s \<equiv> P (state_sep_projection s)"

(* The generalisation of the maps to operator for separation logic. *)
definition
  sep_map_general :: "cdl_object_id \<Rightarrow> cdl_object \<Rightarrow> cdl_components \<Rightarrow> sep_pred"
where
  "sep_map_general p obj gs \<equiv> \<lambda>s. sep_heap s = [p \<mapsto> obj] \<and> sep_ghost_state s p = gs"

(* Alternate definition without the [p \<mapsto> obj] notation. *)
lemma sep_map_general_def2:
  "sep_map_general p obj gs s =
   (dom (sep_heap s) = {p} \<and> ko_at obj p (sep_heap s) \<and> sep_ghost_state s p = gs)"
  apply (clarsimp simp: sep_map_general_def object_at_def)
  apply (rule)
   apply clarsimp
  apply (clarsimp simp: fun_upd_def)
  apply (rule ext)
  apply (fastforce simp: dom_def split:if_split)
  done

(* There is an object there. *)
definition
  sep_map_i :: "cdl_object_id \<Rightarrow> cdl_object \<Rightarrow> sep_pred" ("_ \<mapsto>i _" [76,71] 76)
where
  "p \<mapsto>i obj \<equiv> sep_map_general p obj UNIV"

(* The fields are there (and there are no caps). *)
definition
  sep_map_f :: "cdl_object_id \<Rightarrow> cdl_object \<Rightarrow> sep_pred" ("_ \<mapsto>f _" [76,71] 76)
where
  "p \<mapsto>f obj \<equiv> sep_map_general p (update_slots empty obj) {None}"

(* There is that cap there. *)
definition
  sep_map_c :: "cdl_cap_ref \<Rightarrow> cdl_cap \<Rightarrow> sep_pred" ("_ \<mapsto>c _" [76,71] 76)
where
  "p \<mapsto>c cap \<equiv> \<lambda>s. let (obj_id, slot) = p; heap = sep_heap s in
  \<exists>obj. sep_map_general obj_id obj {Some slot} s \<and> object_slots obj = [slot \<mapsto> cap]"

definition
  sep_any :: "('a \<Rightarrow> 'b \<Rightarrow> sep_pred) \<Rightarrow> ('a \<Rightarrow> sep_pred)" where
  "sep_any m \<equiv> (\<lambda>p s. \<exists>v. (m p v) s)"

abbreviation "sep_any_map_i \<equiv> sep_any sep_map_i"
notation sep_any_map_i ("_ \<mapsto>i -" 76)

abbreviation "sep_any_map_c \<equiv> sep_any sep_map_c"
notation sep_any_map_c ("_ \<mapsto>c -" 76)

end


section \<open>Control Flow Graph\<close>
theory SM_Cfg
imports
  SM_Syntax
  "../Lib/LTS"
  "../Lib/SOS_Misc_Add"
begin
  text \<open>
    We define the control flow graph of SM, in the style of
    an structural operational semantics.
\<close>

  text \<open>
    The edges of the CFG are labeled with actions. These are
    assignments, tests, and skip.
    Assignment actions come in three versions: Assignment to local variables,
    assignment to global variables, and assignment to variables without
    specification of a scope. These will be mapped to local or global variables,
    depending on the scope.
\<close>
  datatype action =
      AAssign exp ident exp | AAssign_local exp ident exp | AAssign_global exp ident exp
    | ATest exp | ASkip

  text \<open>
    Moreover, the semantics uses internal actions to handle break and continue
    statements. For well-formed programs, this type of actions will
    never be exposed
\<close>
  datatype brk_ctd = AIBreak | AIContinue

  text \<open>
    The control flow graph is a graph over commands, labeled with actions
\<close>
  inductive cfg :: "cmd \<Rightarrow> (action + brk_ctd) \<Rightarrow> cmd \<Rightarrow> bool" where
    Ass: "cfg (Assign c x e) (Inl (AAssign c x e)) Skip"
  | Assl: "cfg (Assign_local c x e) (Inl (AAssign_local c x e)) Skip"
  | Assg: "cfg (Assign_global c x e) (Inl (AAssign_global c x e)) Skip"
  | Test: "cfg (Test e) (Inl (ATest e)) Skip"

  | Seq1: "cfg (Seq Skip c2) (Inl ASkip) c2"
  | Seq2': "\<lbrakk> cfg c1 e Skip \<rbrakk> \<Longrightarrow> cfg (Seq c1 c2) e c2"
  | Seq2: "\<lbrakk> cfg c1 e c1'; c1'\<noteq>Skip \<rbrakk> \<Longrightarrow> cfg (Seq c1 c2) e (Seq c1' c2)"

  | Or1: "cfg c1 e c1' \<Longrightarrow> cfg (Or c1 c2) e c1'"
  | Or2: "cfg c2 e c2' \<Longrightarrow> cfg (Or c1 c2) e c2'"

  | Break: "cfg (Break) (Inr AIBreak) Invalid"
  | Continue: "cfg (Continue) (Inr AIContinue) Invalid"

  | Iterate1: "cfg (Iterate Skip c) (Inl ASkip) (Iterate c c)"
  | Iterate2': "\<lbrakk> cfg c (Inl e) Skip \<rbrakk> \<Longrightarrow> cfg (Iterate c cb) (Inl e) (Iterate cb cb)"
  | Iterate2: "\<lbrakk> cfg c (Inl e) c'; c'\<noteq>Skip \<rbrakk> \<Longrightarrow> cfg (Iterate c cb) (Inl e) (Iterate c' cb)"
  | IterateBrk: "\<lbrakk> cfg c (Inr AIBreak) _  \<rbrakk> \<Longrightarrow> cfg (Iterate c cb) (Inl ASkip) Skip"
  | IterateCtd: "\<lbrakk> cfg c (Inr AIContinue) _  \<rbrakk> \<Longrightarrow> cfg (Iterate c cb) (Inl ASkip) (Iterate cb cb)"

  inductive_cases Seq_cases: "cfg (Seq c1 c2) e c'"

section \<open>Reachable Nodes\<close>

interpretation cfg_lts: LTS cfg .

text \<open>Finite set of reachable CFG nodes\<close>

primrec reachable_term_order_aux :: "cmd \<Rightarrow> nat" where
  "reachable_term_order_aux (Assign c x e) = 0"
| "reachable_term_order_aux (Assign_local c x e) = 0"
| "reachable_term_order_aux (Assign_global c x e) = 0"
| "reachable_term_order_aux (Test e) = 0"
| "reachable_term_order_aux (Skip) = 0"
| "reachable_term_order_aux (Seq c1 c2) = reachable_term_order_aux c1 + reachable_term_order_aux c2"
| "reachable_term_order_aux (Or c1 c2) = reachable_term_order_aux c1 + reachable_term_order_aux c2"
| "reachable_term_order_aux (Break) = 0"
| "reachable_term_order_aux (Continue) = 0"
| "reachable_term_order_aux (Iterate c1 c2) = reachable_term_order_aux c1 + reachable_term_order_aux c2"
| "reachable_term_order_aux Invalid = 0"

function approx_reachable :: "cmd \<Rightarrow> cmd set" where
  "approx_reachable (Assign c x e) = {Assign c x e, Skip}"
| "approx_reachable (Assign_local c x e) = {Assign_local c x e, Skip}"
| "approx_reachable (Assign_global c x e) = {Assign_global c x e, Skip}"
| "approx_reachable (Test e) = {Test e, Skip}"
| "approx_reachable (Skip) = {Skip}"
| "approx_reachable (Seq c1 c2) = (approx_reachable c2) \<union> (do { c1\<leftarrow>approx_reachable c1; {Seq c1 c2} })"
| "approx_reachable (Or c1 c2) = insert (Or c1 c2) (approx_reachable c1 \<union> approx_reachable c2)"
| "approx_reachable (Break) = {Break,Invalid}"
| "approx_reachable (Continue) = {Continue,Invalid}"
| "approx_reachable (Iterate c1 c2) = insert Skip
    (do { c1\<leftarrow>approx_reachable c1; {Iterate c1 c2} })
  \<union> (do { c2'\<leftarrow>approx_reachable c2; {Iterate c2' c2} })"
| "approx_reachable Invalid = {Invalid}"
by pat_completeness auto

termination
  apply (relation "reachable_term_order_aux <*mlex*> measure size")
  apply (metis wf_measure wf_mlex)
  apply (auto simp: mlex_prod_def)
  done

lemma finite_approx_reachable[simp, intro!]: "finite (approx_reachable c)"
  by (induction c rule: approx_reachable.induct) auto

lemma approx_reachable_refl[simp]: "c\<in>approx_reachable c"
  by (induction c rule: approx_reachable.induct) auto

lemma approx_reachable_closed:
  assumes "c\<in>approx_reachable c0"
  assumes "cfg c a c'"
  shows "c'\<in>approx_reachable c0"
  using assms
  apply (induction c0 arbitrary: c c' rule: approx_reachable.induct)
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  apply (auto, erule cfg.cases, simp_all, force+) []
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  apply (auto elim: cfg.cases) []
  done

lemma approx_reachable_approx: "cfg_lts.reachable c c' \<Longrightarrow> c'\<in>approx_reachable c"
  unfolding cfg_lts.reachable_def
proof safe
  fix p
  assume "cfg_lts.path c p c'"
  thus "c'\<in>approx_reachable c"
    by (induction p arbitrary: c' rule: rev_induct)
       (auto intro: approx_reachable_closed)
qed

lemma finite_cfg_reachable: "finite (Collect (cfg_lts.reachable c))"
  apply (rule finite_subset[OF _ finite_approx_reachable])
  using approx_reachable_approx by auto

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      ProcParEx.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2007-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section "Examples for Procedures as Parameters using Statespaces"
theory ProcParExSP imports "../Vcg" begin

lemma conseq_exploit_pre':
             "\<lbrakk>\<forall>s \<in> S. \<Gamma>,\<Theta> \<turnstile> ({s} \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile> (P \<inter> S)c Q,A"
  apply (rule HoarePartialDef.Conseq)
  apply clarify
  by (metis IntI insertI1 subset_refl)

lemma conseq_exploit_pre'':
             "\<lbrakk>\<forall>Z. \<forall>s \<in> S Z.  \<Gamma>,\<Theta> \<turnstile> ({s} \<inter> P Z) c (Q Z),(A Z)\<rbrakk>
              \<Longrightarrow>
              \<forall>Z. \<Gamma>,\<Theta>\<turnstile> (P Z \<inter> S Z)c (Q Z),(A Z)"
  apply (rule allI)
  apply (rule conseq_exploit_pre')
  apply blast
  done

lemma conseq_exploit_pre''':
             "\<lbrakk>\<forall>s \<in> S. \<forall>Z. \<Gamma>,\<Theta> \<turnstile> ({s} \<inter> P Z) c (Q Z),(A Z)\<rbrakk>
              \<Longrightarrow>
              \<forall>Z. \<Gamma>,\<Theta>\<turnstile> (P Z \<inter> S)c (Q Z),(A Z)"
  apply (rule allI)
  apply (rule conseq_exploit_pre')
  apply blast
  done

procedures compare(i::nat,j::nat|r::bool) "NoBody"

print_locale! compare_signature

context compare_impl
begin
declare [[hoare_use_call_tr' = false]]
term "\<acute>r :== CALL compare(\<acute>i,\<acute>j)"
declare [[hoare_use_call_tr' = true]]
end

(* FIXME: typing issue with modifies locale*)
procedures
  LEQ (i::nat,j::nat | r::bool) "\<acute>r :== \<acute>i \<le> \<acute>j"
  LEQ_spec: "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>}  PROC LEQ(\<acute>i,\<acute>j,\<acute>r) \<lbrace>\<acute>r = (\<^bsup>\<sigma>\<^esup>i \<le> \<^bsup>\<sigma>\<^esup>j)\<rbrace>"

  LEQ_modifies: "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} PROC LEQ(\<acute>i,\<acute>j,\<acute>r) {t. t may_only_modify_globals \<sigma> in []}"

definition mx:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "mx leq a b = (if leq a b then a else b)"

procedures (imports compare_signature)
  Max (compare::string, n::nat, m::nat | k::nat)
  where b::bool
  in
  "\<acute>b :== DYNCALL \<acute>compare(\<acute>n,\<acute>m);;
   IF \<acute>b THEN \<acute>k :== \<acute>n ELSE \<acute>k :== \<acute>m FI"

  Max_spec: "\<And>leq. \<forall>\<sigma>. \<Gamma>\<turnstile>
  ({\<sigma>} \<inter> {s. (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
              (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})})
    PROC Max(\<acute>compare,\<acute>n,\<acute>m,\<acute>k)
  \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"

context Max_spec
begin
thm Max_spec
end
context Max_impl
begin
term "\<acute>b :== DYNCALL \<acute>compare(\<acute>n,\<acute>m)"
declare [[hoare_use_call_tr' = false]]
term "\<acute>b :== DYNCALL \<acute>compare(\<acute>n,\<acute>m)"
declare [[hoare_use_call_tr' = true]]
end

lemma (in Max_impl ) Max_spec1:
shows
"\<forall>\<sigma> leq. \<Gamma>\<turnstile>
  ({\<sigma>} \<inter> \<lbrace> (\<forall>\<tau>. \<Gamma>\<turnstile>{\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
      (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
proof -
  fix \<sigma>:: "('a, 'b, 'c, 'd) stateSP_scheme" and s::"('a, 'b, 'c, 'd) stateSP_scheme" and leq
   assume compare_spec:
       "\<forall>\<tau>. \<Gamma>\<turnstile>{\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j\<rbrace>"

  assume compare_modifies:
        "\<forall>\<tau>. \<Gamma>\<turnstile>{\<tau>} \<acute>r :== PROC \<^bsup>s\<^esup>compare(\<acute>i,\<acute>j)
                {t. t may_only_modify_globals \<tau> in []}"

   show "\<Gamma>\<turnstile>({s} \<inter> {\<sigma>})
            \<acute>b :== DYNCALL \<acute>compare (\<acute>n,\<acute>m);;
            IF \<acute>b THEN \<acute>k :== \<acute>n ELSE \<acute>k :== \<acute>m FI
            \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
     apply vcg
     apply (clarsimp simp add: mx_def)
     done
 qed

lemma (in Max_impl) Max_spec2:
shows
"\<forall>\<sigma> leq. \<Gamma>\<turnstile>
  ({\<sigma>} \<inter> \<lbrace>(\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
      (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
apply vcg
apply (clarsimp simp add: mx_def)
done

lemma (in Max_impl) Max_spec3:
shows
"\<forall>n m leq. \<Gamma>\<turnstile>
  (\<lbrace>\<acute>n=n \<and> \<acute>m=m\<rbrace>  \<inter>
   \<lbrace>(\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq \<^bsup>\<tau>\<^esup>i \<^bsup>\<tau>\<^esup>j)\<rbrace>) \<and>
     (\<forall>\<tau>. \<Gamma>\<turnstile> {\<tau>} \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) {t. t may_only_modify_globals \<tau> in []})\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq n m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
apply vcg
apply (clarsimp simp add: mx_def)
done

print_locale Max_spec

(* We have to rename the parameters of the compare procedure to match the LEQ procedure *)
locale Max_test = Max_spec where
        i_'compare_' = i_'LEQ_' and
        j_'compare_' = j_'LEQ_' and
        r_'compare_' = r_'LEQ_'
       + LEQ_spec + LEQ_modifies

lemma (in Max_test)
  shows
  "\<Gamma>\<turnstile> {\<sigma>} \<acute>k :== CALL Max(LEQ_'proc,\<acute>n,\<acute>m) \<lbrace>\<acute>k = mx (\<le>) \<^bsup>\<sigma>\<^esup>n \<^bsup>\<sigma>\<^esup>m\<rbrace>"
proof -
  note Max_spec = Max_spec [where leq="(\<le>)"]
  show ?thesis
    apply vcg
    apply (clarsimp)
    apply (rule conjI)
    apply (rule LEQ_spec)
    apply (rule LEQ_modifies)
    done
qed

lemma (in Max_impl) Max_spec5:
shows
"\<forall>n m leq. \<Gamma>\<turnstile>
  (\<lbrace>\<acute>n=n \<and> \<acute>m=m\<rbrace> \<inter> \<lbrace>\<forall>n' m'. \<Gamma>\<turnstile> \<lbrace>\<acute>i=n' \<and> \<acute>j=m'\<rbrace> \<acute>r :== PROC \<acute>compare(\<acute>i,\<acute>j) \<lbrace>\<acute>r = (leq n' m')\<rbrace>\<rbrace>)
    \<acute>k :== PROC Max(\<acute>compare,\<acute>n,\<acute>m)
  \<lbrace>\<acute>k = mx leq n m\<rbrace>"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (intro allI)
apply (rule conseq_exploit_pre')
apply (rule)
apply clarify
apply vcg
apply clarsimp
apply (clarsimp simp add: mx_def)
done

lemma (in LEQ_impl)
 LEQ_spec: "\<forall>n m. \<Gamma>\<turnstile> \<lbrace>\<acute>i=n \<and> \<acute>j=m\<rbrace>  PROC LEQ(\<acute>i,\<acute>j,\<acute>r) \<lbrace>\<acute>r = (n \<le> m)\<rbrace>"
  apply vcg
  apply simp
  done

print_locale Max_impl
locale Max_test' = Max_impl where
        i_'compare_' = i_'LEQ_' and
        j_'compare_' = j_'LEQ_' and
        r_'compare_' = r_'LEQ_'
        + LEQ_impl
lemma (in Max_test')
  shows
  "\<forall>n m. \<Gamma>\<turnstile> \<lbrace>\<acute>n=n \<and> \<acute>m=m\<rbrace> \<acute>k :== CALL Max(LEQ_'proc,\<acute>n,\<acute>m) \<lbrace>\<acute>k = mx (\<le>) n m\<rbrace>"
proof -
  note Max_spec = Max_spec5
  show ?thesis
    apply vcg
    apply (rule_tac x="(\<le>)" in exI)
    apply clarsimp
    apply (rule LEQ_spec [rule_format])
    done
qed

end


section \<open>\isaheader{Specification of Sequences}\<close>
theory ListSpec
imports ICF_Spec_Base
begin

(*@intf List
  @abstype 'a list
  This interface specifies sequences.
*)

subsection "Definition"
locale list =
  \<comment> \<open>Abstraction to HOL-lists\<close>
  fixes \<alpha> :: "'s \<Rightarrow> 'x list"
  \<comment> \<open>Invariant\<close>
  fixes invar :: "'s \<Rightarrow> bool"

locale list_no_invar = list +
  assumes invar[simp, intro!]: "\<And>l. invar l"

subsection "Functions"

locale list_empty = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "\<alpha> (empty ()) = []"
    "invar (empty ())"

locale list_isEmpty = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
    "invar s \<Longrightarrow> isEmpty s \<longleftrightarrow> \<alpha> s = []"

locale poly_list_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
begin
  definition iteratei where
    iteratei_correct[code_unfold]: "iteratei s \<equiv> foldli (\<alpha> s)"
  definition iterate where
    iterate_correct[code_unfold]: "iterate s \<equiv> foldli (\<alpha> s) (\<lambda>_. True)"
end

locale poly_list_rev_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
begin
  definition rev_iteratei where
    rev_iteratei_correct[code_unfold]: "rev_iteratei s \<equiv> foldri (\<alpha> s)"
  definition rev_iterate where
    rev_iterate_correct[code_unfold]: "rev_iterate s \<equiv> foldri (\<alpha> s) (\<lambda>_. True)"
end

(*
locale list_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes iteratei :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
  assumes iteratei_correct:
    "invar s \<Longrightarrow> iteratei s = foldli (\<alpha> s)"
begin
  lemma iteratei_no_sel_rule:
    "invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> set_iterator (iteratei s) (set (\<alpha> s))"
    by (simp add: iteratei_correct set_iterator_foldli_correct)
end

lemma list_iteratei_iteratei_linord_rule:
  "list_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (\<alpha> s) \<Longrightarrow>
   set_iterator_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_iteratei_def set_iterator_linord_foldli_correct)

lemma list_iteratei_iteratei_rev_linord_rule:
  "list_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (rev (\<alpha> s)) \<Longrightarrow>
   set_iterator_rev_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_iteratei_def set_iterator_rev_linord_foldli_correct)

locale list_reverse_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes reverse_iteratei :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
  assumes reverse_iteratei_correct:
    "invar s \<Longrightarrow> reverse_iteratei s = foldri (\<alpha> s)"
begin
  lemma reverse_iteratei_no_sel_rule:
    "invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> set_iterator (reverse_iteratei s) (set (\<alpha> s))"
    by (simp add: reverse_iteratei_correct set_iterator_foldri_correct)
end

lemma list_reverse_iteratei_iteratei_linord_rule:
  "list_reverse_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (rev (\<alpha> s)) \<Longrightarrow>
   set_iterator_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_reverse_iteratei_def set_iterator_linord_foldri_correct)

lemma list_reverse_iteratei_iteratei_rev_linord_rule:
  "list_reverse_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (\<alpha> s) \<Longrightarrow>
   set_iterator_rev_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_reverse_iteratei_def set_iterator_rev_linord_foldri_correct)
*)

locale list_size = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes size :: "'s \<Rightarrow> nat"
  assumes size_correct:
    "invar s \<Longrightarrow> size s = length (\<alpha> s)"

locale list_appendl = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes appendl :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes appendl_correct:
    "invar s \<Longrightarrow> \<alpha> (appendl x s) = x#\<alpha> s"
    "invar s \<Longrightarrow> invar (appendl x s)"
begin
  abbreviation (input) "push \<equiv> appendl"
  lemmas push_correct = appendl_correct
end

locale list_removel = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes removel :: "'s \<Rightarrow> ('x \<times> 's)"
  assumes removel_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> fst (removel s) = hd (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (snd (removel s)) = tl (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> invar (snd (removel s))"
begin
  lemma removelE:
    assumes I: "invar s" "\<alpha> s \<noteq> []"
    obtains s' where "removel s = (hd (\<alpha> s), s')" "invar s'" "\<alpha> s' = tl (\<alpha> s)"
  proof -
    from removel_correct(1,2,3)[OF I] have
      C: "fst (removel s) = hd (\<alpha> s)"
         "\<alpha> (snd (removel s)) = tl (\<alpha> s)"
         "invar (snd (removel s))" .
    from that[of "snd (removel s)", OF _ C(3,2), folded C(1)] show thesis
      by simp
  qed

  text \<open>The following shortcut notations are not meant for generating efficient code,
    but solely to simplify reasoning\<close>
  (* TODO: Is this actually used somewhere ? *)
  (*
  definition "head s == fst (removef s)"
  definition "tail s == snd (removef s)"

  lemma tail_correct: "\<lbrakk>invar F; \<alpha> F \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (tail F) = tl (\<alpha> F)"
    by (simp add: tail_def removef_correct)

  lemma removef_split: "removef F = (head F, tail F)"
    apply (cases "removef F")
    apply (simp add: head_def tail_def)
    done
    *)

  abbreviation (input) "pop \<equiv> removel"
  lemmas pop_correct = removel_correct

  abbreviation (input) "dequeue \<equiv> removel"
  lemmas dequeue_correct = removel_correct
end

locale list_leftmost = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes leftmost :: "'s \<Rightarrow> 'x"
  assumes leftmost_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> leftmost s = hd (\<alpha> s)"
begin
  abbreviation (input) top where "top \<equiv> leftmost"
  lemmas top_correct = leftmost_correct
end

locale list_appendr = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes appendr :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes appendr_correct:
    "invar s \<Longrightarrow> \<alpha> (appendr x s) = \<alpha> s @ [x]"
    "invar s \<Longrightarrow> invar (appendr x s)"
begin
  abbreviation (input) "enqueue \<equiv> appendr"
  lemmas enqueue_correct = appendr_correct
end

locale list_remover = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes remover :: "'s \<Rightarrow> 's \<times> 'x"
  assumes remover_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (fst (remover s)) = butlast (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> snd (remover s) = last (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> invar (fst (remover s))"

locale list_rightmost = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes rightmost :: "'s \<Rightarrow> 'x"
  assumes rightmost_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> rightmost s = List.last (\<alpha> s)"
begin
  abbreviation (input) bot where "bot \<equiv> rightmost"
  lemmas bot_correct = rightmost_correct
end

subsubsection "Indexing"
locale list_get = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes get :: "'s \<Rightarrow> nat \<Rightarrow> 'x"
  assumes get_correct:
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> get s i = \<alpha> s ! i"

locale list_set = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes set :: "'s \<Rightarrow> nat \<Rightarrow> 'x \<Rightarrow> 's"
  assumes set_correct:
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> \<alpha> (set s i x) = (\<alpha> s) [i := x]"
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> invar (set s i x)"

record ('a,'s) list_ops =
  list_op_\<alpha> :: "'s \<Rightarrow> 'a list"
  list_op_invar :: "'s \<Rightarrow> bool"
  list_op_empty :: "unit \<Rightarrow> 's"
  list_op_isEmpty :: "'s \<Rightarrow> bool"
  list_op_size :: "'s \<Rightarrow> nat"
  list_op_appendl :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  list_op_removel :: "'s \<Rightarrow> 'a \<times> 's"
  list_op_leftmost :: "'s \<Rightarrow> 'a"
  list_op_appendr :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  list_op_remover :: "'s \<Rightarrow> 's \<times> 'a"
  list_op_rightmost :: "'s \<Rightarrow> 'a"
  list_op_get :: "'s \<Rightarrow> nat \<Rightarrow> 'a"
  list_op_set :: "'s \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 's"

locale StdListDefs =
  poly_list_iteratei "list_op_\<alpha> ops" "list_op_invar ops"
  + poly_list_rev_iteratei "list_op_\<alpha> ops" "list_op_invar ops"
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> \<equiv> list_op_\<alpha> ops"
  abbreviation invar where "invar \<equiv> list_op_invar ops"
  abbreviation empty where "empty \<equiv> list_op_empty ops"
  abbreviation isEmpty where "isEmpty \<equiv> list_op_isEmpty ops"
  abbreviation size where "size \<equiv> list_op_size ops"
  abbreviation appendl where "appendl \<equiv> list_op_appendl ops"
  abbreviation removel where "removel \<equiv> list_op_removel ops"
  abbreviation leftmost where "leftmost \<equiv> list_op_leftmost ops"
  abbreviation appendr where "appendr \<equiv> list_op_appendr ops"
  abbreviation remover where "remover \<equiv> list_op_remover ops"
  abbreviation rightmost where "rightmost \<equiv> list_op_rightmost ops"
  abbreviation get where "get \<equiv> list_op_get ops"
  abbreviation set where "set \<equiv> list_op_set ops"
end

locale StdList = StdListDefs ops
  + list \<alpha> invar
  + list_empty \<alpha> invar empty
  + list_isEmpty \<alpha> invar isEmpty
  + list_size \<alpha> invar size
  + list_appendl \<alpha> invar appendl
  + list_removel \<alpha> invar removel
  + list_leftmost \<alpha> invar leftmost
  + list_appendr \<alpha> invar appendr
  + list_remover \<alpha> invar remover
  + list_rightmost \<alpha> invar rightmost
  + list_get \<alpha> invar get
  + list_set \<alpha> invar set
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  lemmas correct =
    empty_correct
    isEmpty_correct
    size_correct
    appendl_correct
    removel_correct
    leftmost_correct
    appendr_correct
    remover_correct
    rightmost_correct
    get_correct
    set_correct

end

locale StdList_no_invar = StdList + list_no_invar \<alpha> invar

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Map Implementation by Associative Lists} *}
theory ListMapImpl
imports
  "../spec/MapSpec"
  "../../Lib/Assoc_List"
  "../gen_algo/MapGA"
begin
text_raw {*\label{thy:ListMapImpl}*}

(*@impl Map
  @type 'a lm
  @abbrv lm,l
  Maps implemented by associative lists. If you need efficient
  @{text "insert_dj"} operation, you should use list sets with explicit
  invariants (lmi).
*)

type_synonym ('k,'v) lm = "('k,'v) assoc_list"

definition [icf_rec_def]: "lm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = Assoc_List.lookup,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = (\<lambda>_::unit. Assoc_List.empty),
  bmap_op_lookup = (\<lambda>k m. Assoc_List.lookup m k),
  bmap_op_update = Assoc_List.update,
  bmap_op_update_dj = Assoc_List.update,
  bmap_op_delete = Assoc_List.delete,
  bmap_op_list_it = Assoc_List.iteratei
\<rparr>"

setup Locale_Code.open_block
interpretation lm_basic!: StdBasicMapDefs lm_basic_ops .
interpretation lm_basic!: StdBasicMap lm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf
    Assoc_List.lookup_empty' Assoc_List.iteratei_correct)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lm_ops \<equiv> lm_basic.dflt_ops"
setup Locale_Code.open_block
interpretation lm!: StdMapDefs lm_ops .
interpretation lm!: StdMap lm_ops
  unfolding lm_ops_def
  by (rule lm_basic.dflt_ops_impl)
interpretation lm!: StdMap_no_invar lm_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lm"*}

lemma pi_lm[proper_it]:
  "proper_it' Assoc_List.iteratei Assoc_List.iteratei"
  unfolding Assoc_List.iteratei_def[abs_def]
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lm: proper_it_loc Assoc_List.iteratei Assoc_List.iteratei
  apply unfold_locales
  apply (rule pi_lm)
  done

lemma pi_lm'[proper_it]:
  "proper_it' lm.iteratei lm.iteratei"
  unfolding lm.iteratei_def[abs_def]
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lm': proper_it_loc lm.iteratei lm.iteratei
  apply unfold_locales
  apply (rule pi_lm')
  done

text {* Code generator test *}
definition "test_codegen \<equiv> (
  lm.add ,
  lm.add_dj ,
  lm.ball ,
  lm.bex ,
  lm.delete ,
  lm.empty ,
  lm.isEmpty ,
  lm.isSng ,
  lm.iterate ,
  lm.iteratei ,
  lm.list_it ,
  lm.lookup ,
  lm.restrict ,
  lm.sel ,
  lm.size ,
  lm.size_abort ,
  lm.sng ,
  lm.to_list ,
  lm.to_map ,
  lm.update ,
  lm.update_dj)"

export_code test_codegen in SML

end


(*  Title:      HOL/MicroJava/J/Exceptions.thy

    Author:     Gerwin Klein, Martin Strecker
    Copyright   2002 Technische Universitaet Muenchen
*)

header {* \isaheader{Exceptions} *}

theory Exceptions imports Objects begin

definition NullPointer :: cname
where
  "NullPointer \<equiv> ''NullPointer''"

definition ClassCast :: cname
where
  "ClassCast \<equiv> ''ClassCast''"

definition OutOfMemory :: cname
where
  "OutOfMemory \<equiv> ''OutOfMemory''"

definition sys_xcpts :: "cname set"
where
  "sys_xcpts  \<equiv>  {NullPointer, ClassCast, OutOfMemory}"

definition addr_of_sys_xcpt :: "cname \<Rightarrow> addr"
where
  "addr_of_sys_xcpt s \<equiv> if s = NullPointer then 0 else
                        if s = ClassCast then 1 else
                        if s = OutOfMemory then 2 else undefined"

definition start_heap :: "'c prog \<Rightarrow> heap"
where
  "start_heap G \<equiv> empty (addr_of_sys_xcpt NullPointer \<mapsto> blank G NullPointer)
                        (addr_of_sys_xcpt ClassCast \<mapsto> blank G ClassCast)
                        (addr_of_sys_xcpt OutOfMemory \<mapsto> blank G OutOfMemory)"

definition preallocated :: "heap \<Rightarrow> bool"
where
  "preallocated h \<equiv> \<forall>C \<in> sys_xcpts. \<exists>fs. h(addr_of_sys_xcpt C) = Some (C,fs)"

section "System exceptions"

lemma sys_xcpts_cases [consumes 1, cases set]:
  "\<lbrakk> C \<in> sys_xcpts; P NullPointer; P OutOfMemory; P ClassCast\<rbrakk> \<Longrightarrow> P C"
(*<*)by (auto simp add: sys_xcpts_def)(*>*)

section "@{term preallocated}"

lemma preallocated_dom [simp]:
  "\<lbrakk> preallocated h; C \<in> sys_xcpts \<rbrakk> \<Longrightarrow> addr_of_sys_xcpt C \<in> dom h"
(*<*)by (fastforce simp:preallocated_def dom_def)(*>*)

lemma preallocatedD:
  "\<lbrakk> preallocated h; C \<in> sys_xcpts \<rbrakk> \<Longrightarrow> \<exists>fs. h(addr_of_sys_xcpt C) = Some (C, fs)"
(*<*)by(auto simp add: preallocated_def sys_xcpts_def)(*>*)

lemma preallocatedE [elim?]:
  "\<lbrakk> preallocated h;  C \<in> sys_xcpts; \<And>fs. h(addr_of_sys_xcpt C) = Some(C,fs) \<Longrightarrow> P h C\<rbrakk>
  \<Longrightarrow> P h C"
(*<*)by (fast dest: preallocatedD)(*>*)

lemma cname_of_xcp [simp]:
  "\<lbrakk> preallocated h; C \<in> sys_xcpts \<rbrakk> \<Longrightarrow> cname_of h (addr_of_sys_xcpt C) = C"
(*<*)by (auto elim: preallocatedE)(*>*)

lemma typeof_ClassCast [simp]:
  "preallocated h \<Longrightarrow> typeof\<^bsub>h\<^esub> (Addr(addr_of_sys_xcpt ClassCast)) = Some(Class ClassCast)"
(*<*)by (auto elim: preallocatedE)(*>*)

lemma typeof_OutOfMemory [simp]:
  "preallocated h \<Longrightarrow> typeof\<^bsub>h\<^esub> (Addr(addr_of_sys_xcpt OutOfMemory)) = Some(Class OutOfMemory)"
(*<*)by (auto elim: preallocatedE)(*>*)

lemma typeof_NullPointer [simp]:
  "preallocated h \<Longrightarrow> typeof\<^bsub>h\<^esub> (Addr(addr_of_sys_xcpt NullPointer)) = Some(Class NullPointer)"
(*<*)by (auto elim: preallocatedE)(*>*)

lemma preallocated_hext:
  "\<lbrakk> preallocated h; h \<unlhd> h' \<rbrakk> \<Longrightarrow> preallocated h'"
(*<*)by (simp add: preallocated_def hext_def)(*>*)

(*<*)
lemmas preallocated_upd_obj = preallocated_hext [OF _ hext_upd_obj]
lemmas preallocated_new  = preallocated_hext [OF _ hext_new]
(*>*)

lemma preallocated_start:
  "preallocated (start_heap P)"
(*<*)by (auto simp add: start_heap_def blank_def sys_xcpts_def fun_upd_apply
                     addr_of_sys_xcpt_def preallocated_def)(*>*)

end


section "Invariant Context Simplifications"
theory invContext_simps
imports repliss_sem
begin

text "Here we prove various simplifications for the invariant contexts."

lemma invContext_unchanged_happensBefore:
  assumes "co c \<triangleq> t" and "ts t \<triangleq> Uncommitted"
  shows "invContextH co to ts (hbOld \<union> vis \<times> {c}) cs ki io ir
    = invContextH co to ts hbOld cs ki io ir "
  using assms by (auto simp add: invContextH_def restrict_relation_def committedCallsH_def isCommittedH_def)

lemma invContext_unchanged_happensBefore2:
  assumes "co c = None"
  shows "invContextH co to ts (hbOld \<union> vis \<times> {c}) cs ki io ir
    = invContextH co to ts hbOld cs ki io ir  "
  using assms by (auto simp add: invContextH_def restrict_relation_def committedCallsH_def isCommittedH_def)

lemma committedCallsH_notin:
  assumes "co c = None"
  shows "c \<notin> committedCallsH co ts"
  by (simp add: assms committedCallsH_def isCommittedH_def)

lemma committedCallsH_in:
  shows "(c \<in> committedCallsH co ts) \<longleftrightarrow> (case co c of None \<Rightarrow> False | Some t \<Rightarrow> ts t \<triangleq> Committed) "
  by (auto simp add: committedCallsH_def isCommittedH_def split: option.splits)

lemma committedCalls_unchanged_callOrigin:
  assumes a1: "ts t \<triangleq> Uncommitted"
    and a2: "co c = None"
  shows "committedCallsH (co(c \<mapsto> t)) ts = committedCallsH co ts"
  using a1 a2 by (auto simp add: committedCallsH_def isCommittedH_def)

lemma invContextH_map_update_all:
  assumes "co c = None" and "ts t \<triangleq> Uncommitted"
  shows "invContextH (co(c \<mapsto> t)) to ts hb cs ki io ir   =
       invContextH co to ts hb cs ki io ir  "
  using assms by (auto simp add: invContextH_def committedCallsH_notin committedCalls_unchanged_callOrigin)

lemma invContextH_update_calls:
  assumes "co c \<triangleq> t" and "ts t \<triangleq> Uncommitted"
  shows "invContextH co to ts hb (cs(c \<mapsto> newCall)) ki io ir   =
       invContextH co to ts hb cs ki io ir  "
  using assms by (auto simp add: invContextH_def committedCallsH_in)

lemma committedCallsH_update_uncommitted:
  assumes "ts t = None"
  shows "committedCallsH co (ts(t \<mapsto> Uncommitted))
     = committedCallsH co ts"
  using assms by (auto simp add: committedCallsH_def isCommittedH_def, force)

lemma invContextH_update_txstatus:
  assumes "ts t = None"
  shows "invContextH co to (ts(t\<mapsto>Uncommitted)) hb cs ki io ir  =
       invContextH co to ts hb cs ki io ir "
  using assms by (auto simp add: invContextH_def restrict_map_def committedCallsH_update_uncommitted)

lemmas invContextH_simps = invContextH_update_calls invContextH_map_update_all invContextH_update_txstatus

end


subsection \<open>Stuttering\<close>

theory Stuttering
  imports
    Semantics.IRStepThms
begin

inductive stutter:: "IRGraph \<Rightarrow> MapState \<Rightarrow> Params \<Rightarrow> FieldRefHeap \<Rightarrow> ID \<Rightarrow> ID \<Rightarrow> bool" ("_ _ _ _ \<turnstile> _ \<leadsto> _" 55)
  for g m p h where

  StutterStep:
  "\<lbrakk>g, p \<turnstile> (nid,m,h) \<rightarrow> (nid',m,h)\<rbrakk>
   \<Longrightarrow> g m p h \<turnstile> nid \<leadsto> nid'" |

  Transitive:
  "\<lbrakk>g, p \<turnstile> (nid,m,h) \<rightarrow> (nid'',m,h);
    g m p h \<turnstile> nid'' \<leadsto> nid'\<rbrakk>
   \<Longrightarrow> g m p h \<turnstile> nid \<leadsto> nid'"

lemma stuttering_successor:
  assumes "(g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h))"
  shows "{P'. (g m p h \<turnstile> nid \<leadsto> P')} = {nid'} \<union> {nid''. (g m p h \<turnstile> nid' \<leadsto> nid'')}"
proof -
  have nextin: "nid' \<in> {P'. (g m p h \<turnstile> nid \<leadsto> P')}"
    using assms StutterStep by blast
  have nextsubset: "{nid''. (g m p h \<turnstile> nid' \<leadsto> nid'')} \<subseteq> {P'. (g m p h \<turnstile> nid \<leadsto> P')}"
    by (metis Collect_mono assms stutter.Transitive)
  have "\<forall>n \<in> {P'. (g m p h \<turnstile> nid \<leadsto> P')} . n = nid' \<or> n \<in> {nid''. (g m p h \<turnstile> nid' \<leadsto> nid'')}"
    using stepDet
    by (metis (no_types, lifting) Pair_inject assms mem_Collect_eq stutter.simps)
  then show ?thesis
    using insert_absorb mk_disjoint_insert nextin nextsubset by auto
qed

end