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

imports
  "../ml-helpers/MLUtils"
  "../ml-helpers/TermPatternAntiquote"
begin

text \<open>
  Introduces a method for improving unification outcomes for schematics with
  datatype expressions as parameters.

  There are two variants:
    1. In cases where a schematic is applied to a constant like @{term True},
       we wrap the constant to avoid some undesirable unification candidates.

    2. In cases where a schematic is applied to a constructor expression like
       @{term "Some x"} or @{term "(x, y)"}, we supply selector expressions
       like @{term "the"} or @{term "fst"} to provide more unification
       candidates.  This is only done if parameter that would be selected (e.g.
       @{term x} in @{term "Some x"}) contains bound variables which the
       schematic does not have as parameters.

  In the "constructor expression" case, we let users supply additional
  constructor handlers via the `datatype_schematic` attribute. The method uses
  rules of the following form:

    @{term "\<And>x1 x2 x3. getter (constructor x1 x2 x3) = x2"}

  These are essentially simp rules for simple "accessor" primrec functions,
  which are used to turn schematics like

    @{text "?P (constructor x1 x2 x3)"}

  into

    @{text "?P' x2 (constructor x1 x2 x3)"}.
\<close>

ML \<open>
  \<comment> \<open>
    Anchor used to link error messages back to the documentation above.
  \<close>
  val usage_pos = @{here};
\<close>

definition
  ds_id :: "'a \<Rightarrow> 'a"
where
  "ds_id = (\<lambda>x. x)"

lemma wrap_ds_id:
  "x = ds_id x"
  by (simp add: ds_id_def)

ML \<open>
structure Datatype_Schematic = struct

fun eq ((idx1, name1, thm1), (idx2, name2, thm2)) =
  idx1 = idx2 andalso
  name1 = name2 andalso
  (Thm.full_prop_of thm1) aconv (Thm.full_prop_of thm2);

structure Datatype_Schematic_Data = Generic_Data
(
  \<comment> \<open>
    Keys are names of datatype constructors (like @{const Cons}), values are
    `(index, function_name, thm)`.

    - `function_name` is the name of an "accessor" function that accesses part
      of the constructor specified by the key (so the accessor @{const hd} is
      related to the constructor/key @{const Cons}).

    - `thm` is a theorem showing that the function accesses one of the
      arguments to the constructor (like @{thm list.sel(1)}).

    - `idx` is the index of the constructor argument that the accessor
      accesses.  (eg. since `hd` accesses the first argument, `idx = 0`; since
      `tl` accesses the second argument, `idx = 1`).
  \<close>
  type T = ((int * string * thm) list) Symtab.table;
  val empty = Symtab.empty;
  val extend = I;
  val merge = Symtab.merge_list eq;
);

fun gen_att m =
  Thm.declaration_attribute (fn thm => fn context =>
    Datatype_Schematic_Data.map (m (Context.proof_of context) thm) context);

(* gathers schematic applications from the goal. no effort is made
   to normalise bound variables here, since we'll always be comparing
   elements within a compound application which will be at the same
   level as regards lambdas. *)
fun gather_schem_apps (f $ x) insts = let
    val (f, xs) = strip_comb (f $ x)
    val insts = fold (gather_schem_apps) (f :: xs) insts
  in if is_Var f then (f, xs) :: insts else insts end
  | gather_schem_apps (Abs (_, _, t)) insts
    = gather_schem_apps t insts
  | gather_schem_apps _ insts = insts

fun sfirst xs f = get_first f xs

fun get_action ctxt prop = let
    val schem_insts = gather_schem_apps prop [];
    val actions = Datatype_Schematic_Data.get (Context.Proof ctxt);
    fun mk_sel selname T i = let
        val (argTs, resT) = strip_type T
      in Const (selname, resT --> nth argTs i) end
  in
    sfirst schem_insts
    (fn (var, xs) => sfirst (Library.tag_list 0 xs)
        (try (fn (idx, x) => let
            val (c, ys) = strip_comb x
            val (fname, T) = dest_Const c
            val acts = Symtab.lookup_list actions fname
            fun interesting arg = not (member Term.aconv_untyped xs arg)
                andalso exists (fn i => not (member (=) xs (Bound i)))
                    (Term.loose_bnos arg)
          in the (sfirst acts (fn (i, selname, thms) => if interesting (nth ys i)
            then SOME (var, idx, mk_sel selname T i, thms) else NONE))
          end)))
  end

fun get_bound_tac ctxt = SUBGOAL (fn (t, i) => case get_action ctxt t of
  SOME (Var ((nm, ix), T), idx, sel, thm) => (fn t => let
    val (argTs, _) = strip_type T
    val ix2 = Thm.maxidx_of t + 1
    val xs = map (fn (i, T) => Free ("x" ^ string_of_int i, T))
        (Library.tag_list 1 argTs)
    val nx = sel $ nth xs idx
    val v' = Var ((nm, ix2), fastype_of nx --> T)
    val inst_v = fold lambda (rev xs) (betapplys (v' $ nx, xs))
    val t' = Drule.infer_instantiate ctxt
        [((nm, ix), Thm.cterm_of ctxt inst_v)] t
    val t'' = Conv.fconv_rule (Thm.beta_conversion true) t'
  in safe_full_simp_tac (clear_simpset ctxt addsimps [thm]) i t'' end)
  | _ => no_tac)

fun id_applicable (f $ x) = let
    val (f, xs) = strip_comb (f $ x)
    val here = is_Var f andalso exists is_Const xs
  in here orelse exists id_applicable (f :: xs) end
  | id_applicable (Abs (_, _, t)) = id_applicable t
  | id_applicable _ = false

fun combination_conv cv1 cv2 ct =
  let
    val (ct1, ct2) = Thm.dest_comb ct
    val r1 = SOME (cv1 ct1) handle Option => NONE
    val r2 = SOME (cv2 ct2) handle Option => NONE
    fun mk _ (SOME res) = res
      | mk ct NONE = Thm.reflexive ct
  in case (r1, r2) of
      (NONE, NONE) => raise Option
    | _ => Thm.combination (mk ct1 r1) (mk ct2 r2)
  end

val wrap = mk_meta_eq @{thm wrap_ds_id}

fun wrap_const_conv _ ct = if is_Const (Thm.term_of ct)
        andalso fastype_of (Thm.term_of ct) <> @{typ unit}
    then Conv.rewr_conv wrap ct
    else raise Option

fun combs_conv conv ctxt ct = case Thm.term_of ct of
    _ $ _ => combination_conv (combs_conv conv ctxt) (conv ctxt) ct
  | _ => conv ctxt ct

fun wrap_conv ctxt ct = case Thm.term_of ct of
    Abs _ => Conv.sub_conv wrap_conv ctxt ct
  | f $ x => if is_Var (head_of f) then combs_conv wrap_const_conv ctxt ct
    else if not (id_applicable (f $ x)) then raise Option
    else combs_conv wrap_conv ctxt ct
  | _ => raise Option

fun CONVERSION_opt conv i t = CONVERSION conv i t
    handle Option => no_tac t

exception Datatype_Schematic_Error of Pretty.T;

fun apply_pos_markup pos text =
  let
    val props = Position.def_properties_of pos;
    val markup = Markup.properties props (Markup.entity "" "");
  in Pretty.mark_str (markup, text) end;

fun invalid_accessor ctxt thm : exn =
  Datatype_Schematic_Error ([
    Pretty.str "Bad input theorem '",
    Syntax.pretty_term ctxt (Thm.full_prop_of thm),
    Pretty.str "'. Click ",
    apply_pos_markup usage_pos "*here*",
    Pretty.str " for info on the required rule format." ] |> Pretty.paragraph);

local
  fun dest_accessor' thm =
    case (thm |> Thm.full_prop_of |> HOLogic.dest_Trueprop) of
      @{term_pat "?fun_name ?data_pat = ?rhs"} =>
        let
          val fun_name = Term.dest_Const fun_name |> fst;
          val (data_const, data_args) = Term.strip_comb data_pat;
          val data_vars = data_args |> map (Term.dest_Var #> fst);
          val rhs_var = rhs |> Term.dest_Var |> fst;
          val data_name = Term.dest_Const data_const |> fst;
          val rhs_idx = ListExtras.find_index (curry op = rhs_var) data_vars |> the;
        in (fun_name, data_name, rhs_idx) end;
in
  fun dest_accessor ctxt thm =
    case try dest_accessor' thm of
      SOME x => x
    | NONE => raise invalid_accessor ctxt thm;
end

fun add_rule ctxt thm data =
  let
    val (fun_name, data_name, idx) = dest_accessor ctxt thm;
    val entry = (data_name, (idx, fun_name, thm));
  in Symtab.insert_list eq entry data end;

fun del_rule ctxt thm data =
  let
    val (fun_name, data_name, idx) = dest_accessor ctxt thm;
    val entry = (data_name, (idx, fun_name, thm));
  in Symtab.remove_list eq entry data end;

val add = gen_att add_rule;
val del = gen_att del_rule;

fun wrap_tac ctxt = CONVERSION_opt (wrap_conv ctxt)

fun tac1 ctxt = REPEAT_ALL_NEW (get_bound_tac ctxt) THEN' (TRY o wrap_tac ctxt)

fun tac ctxt = tac1 ctxt ORELSE' wrap_tac ctxt

val add_section =
  Args.add -- Args.colon >> K (Method.modifier add @{here});

val method =
  Method.sections [add_section] >> (fn _ => fn ctxt => Method.SIMPLE_METHOD' (tac ctxt));

end
\<close>

setup \<open>
  Attrib.setup
    @{binding "datatype_schematic"}
    (Attrib.add_del Datatype_Schematic.add Datatype_Schematic.del)
    "Accessor rules to fix datatypes in schematics"
\<close>

method_setup datatype_schem = \<open>
  Datatype_Schematic.method
\<close>

declare prod.sel[datatype_schematic]
declare option.sel[datatype_schematic]
declare list.sel(1,3)[datatype_schematic]

locale datatype_schem_demo begin

lemma handles_nested_constructors:
  "\<exists>f. \<forall>y. f True (Some [x, (y, z)]) = y"
  apply (rule exI, rule allI)
  apply datatype_schem
  apply (rule refl)
  done

datatype foo =
    basic nat int
  | another nat

primrec get_basic_0 where
  "get_basic_0 (basic x0 x1) = x0"

primrec get_nat where
    "get_nat (basic x _) = x"
  | "get_nat (another z) = z"

lemma selectively_exposing_datatype_arugments:
  notes get_basic_0.simps[datatype_schematic]
  shows "\<exists>x. \<forall>a b. x (basic a b) = a"
  apply (rule exI, (rule allI)+)
  apply datatype_schem \<comment> \<open>Only exposes `a` to the schematic.\<close>
  by (rule refl)

lemma method_handles_primrecs_with_two_constructors:
  shows "\<exists>x. \<forall>a b. x (basic a b) = a"
  apply (rule exI, (rule allI)+)
  apply (datatype_schem add: get_nat.simps)
  by (rule refl)

end

end


(*  Title:       OAWN_Convert.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Transfer standard invariants into open invariants"

theory OAWN_Convert
imports AWN_SOS_Labels AWN_Invariants
        OAWN_SOS OAWN_Invariants
begin

definition initiali :: "'i \<Rightarrow> (('i \<Rightarrow> 'g) \<times> 'l) set \<Rightarrow> ('g \<times> 'l) set \<Rightarrow> bool"
where "initiali i OI CI \<equiv> ({(\<sigma> i, p)|\<sigma> p. (\<sigma>, p) \<in> OI} = CI)"

lemma initialiI [intro]:
  assumes OICI: "\<And>\<sigma> p. (\<sigma>, p) \<in> OI \<Longrightarrow> (\<sigma> i, p) \<in> CI"
      and CIOI: "\<And>\<xi> p. (\<xi>, p) \<in> CI \<Longrightarrow> \<exists>\<sigma>. \<xi> = \<sigma> i \<and> (\<sigma>, p) \<in> OI"
    shows "initiali i OI CI"
  unfolding initiali_def
  by (intro set_eqI iffI) (auto elim!: OICI CIOI)

lemma open_from_initialiD [dest]:
  assumes "initiali i OI CI"
      and "(\<sigma>, p) \<in> OI"
    shows "\<exists>\<xi>. \<sigma> i = \<xi> \<and> (\<xi>, p) \<in> CI"
  using assms unfolding initiali_def by auto

lemma closed_from_initialiD [dest]:
  assumes "initiali i OI CI"
      and "(\<xi>, p) \<in> CI"
    shows "\<exists>\<sigma>. \<sigma> i = \<xi> \<and> (\<sigma>, p) \<in> OI"
  using assms unfolding initiali_def by auto

definition
  seql :: "'i \<Rightarrow> (('s \<times> 'l) \<Rightarrow> bool) \<Rightarrow> (('i \<Rightarrow> 's) \<times> 'l) \<Rightarrow> bool"
where
  "seql i P \<equiv> (\<lambda>(\<sigma>, p). P (\<sigma> i, p))"

lemma seqlI [intro]:
  "P (fst s i, snd s) \<Longrightarrow> seql i P s"
  by (clarsimp simp: seql_def)

lemma same_seql [elim]:
  assumes "\<forall>j\<in>{i}. \<sigma>' j = \<sigma> j"
      and "seql i P (\<sigma>', s)"
    shows "seql i P (\<sigma>, s)"
  using assms unfolding seql_def by (clarsimp)

lemma seqlsimp:
  "seql i P (\<sigma>, p) = P (\<sigma> i, p)"
  unfolding seql_def by simp

lemma other_steps_resp_local [intro!, simp]: "other_steps (other A I) I"
  by (clarsimp elim!: otherE)

lemma seql_onl_swap:
  "seql i (onl \<Gamma> P) = onl \<Gamma> (seql i P)"
  unfolding seql_def onl_def by simp

lemma oseqp_sos_resp_local_steps [intro!, simp]:
  fixes \<Gamma> :: "'p \<Rightarrow> ('s, 'm, 'p, 'l) seqp"
  shows "local_steps (oseqp_sos \<Gamma> i) {i}"
  proof
    fix \<sigma> \<sigma>' \<zeta> \<zeta>' :: "nat \<Rightarrow> 's" and s a s'
    assume tr: "((\<sigma>, s), a, \<sigma>', s') \<in> oseqp_sos \<Gamma> i"
       and "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
    thus "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, s), a, (\<zeta>', s')) \<in> oseqp_sos \<Gamma> i"
    proof induction
      fix \<sigma> \<sigma>' l ms p
      assume "\<sigma>' i = \<sigma> i"
         and "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
      hence "((\<zeta>, {l}broadcast(ms).p), broadcast (ms (\<sigma> i)), (\<sigma>', p)) \<in> oseqp_sos \<Gamma> i"
        by (metis obroadcastT singleton_iff)
      with \<open>\<forall>j\<in>{i}. \<zeta> j = \<sigma> j\<close> show "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and>
            ((\<zeta>, {l}broadcast(ms).p), broadcast (ms (\<sigma> i)), (\<zeta>', p)) \<in> oseqp_sos \<Gamma> i"
        by blast
    next
      fix \<sigma> \<sigma>' :: "nat \<Rightarrow> 's" and fmsg :: "'m \<Rightarrow> 's \<Rightarrow> 's" and msg l p
      assume *:  "\<sigma>' i = fmsg msg (\<sigma> i)"
         and **: "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
      hence "\<forall>j\<in>{i}. (\<zeta>(i := fmsg msg (\<zeta> i))) j = \<sigma>' j" by clarsimp
      moreover from * **
        have "((\<zeta>, {l}receive(fmsg).p), receive msg, (\<zeta>(i := fmsg msg (\<zeta> i)), p)) \<in> oseqp_sos \<Gamma> i"
        by (metis fun_upd_same oreceiveT)
      ultimately show "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and>
                            ((\<zeta>, {l}receive(fmsg).p), receive msg, (\<zeta>', p)) \<in> oseqp_sos \<Gamma> i"
        by blast
    next
      fix \<sigma>' \<sigma> l p and fas :: "'s \<Rightarrow> 's"
      assume *:  "\<sigma>' i = fas (\<sigma> i)"
         and **: "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
      hence "\<forall>j\<in>{i}. (\<zeta>(i := fas (\<zeta> i))) j = \<sigma>' j" by clarsimp
      moreover from * ** have "((\<zeta>, {l}\<lbrakk>fas\<rbrakk> p), \<tau>, (\<zeta>(i := fas (\<zeta> i)), p)) \<in> oseqp_sos \<Gamma> i"
        by (metis fun_upd_same oassignT)
      ultimately show "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, {l}\<lbrakk>fas\<rbrakk> p), \<tau>, (\<zeta>', p)) \<in> oseqp_sos \<Gamma> i"
        by blast
    next
      fix g :: "'s \<Rightarrow> 's set" and \<sigma> \<sigma>' l p
      assume *:  "\<sigma>' i \<in> g (\<sigma> i)"
         and **: "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
      hence "\<forall>j\<in>{i}. (SOME \<zeta>'. \<zeta>' i = \<sigma>' i) j = \<sigma>' j" by simp (metis (lifting, full_types) some_eq_ex)
      moreover with * ** have "((\<zeta>, {l}\<langle>g\<rangle> p), \<tau>, (SOME \<zeta>'. \<zeta>' i = \<sigma>' i, p)) \<in> oseqp_sos \<Gamma> i"
        by simp (metis oguardT step_seq_tau)
      ultimately show "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, {l}\<langle>g\<rangle> p), \<tau>, (\<zeta>', p)) \<in> oseqp_sos \<Gamma> i"
        by blast
    next
      fix \<sigma> pn a \<sigma>' p'
      assume "((\<sigma>, \<Gamma> pn), a, (\<sigma>', p')) \<in> oseqp_sos \<Gamma> i"
         and IH: "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j \<Longrightarrow> \<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, \<Gamma> pn), a, (\<zeta>', p')) \<in> oseqp_sos \<Gamma> i"
         and "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
      then obtain \<zeta>' where "\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j"
                       and "((\<zeta>, \<Gamma> pn), a, (\<zeta>', p')) \<in> oseqp_sos \<Gamma> i"
        by blast
      thus "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, call(pn)), a, (\<zeta>', p')) \<in> oseqp_sos \<Gamma> i"
        by blast
    next
      fix \<sigma> p a \<sigma>' p' q
      assume "((\<sigma>, p), a, (\<sigma>', p')) \<in> oseqp_sos \<Gamma> i"
         and "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j \<Longrightarrow> \<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, p), a, (\<zeta>', p')) \<in> oseqp_sos \<Gamma> i"
         and "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
      then obtain \<zeta>' where "\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j"
                       and "((\<zeta>, p), a, (\<zeta>', p')) \<in> oseqp_sos \<Gamma> i"
        by blast
      thus "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, p \<oplus> q), a, (\<zeta>', p')) \<in> oseqp_sos \<Gamma> i"
        by blast
    next
      fix \<sigma> p a \<sigma>' q q'
      assume "((\<sigma>, q), a, (\<sigma>', q')) \<in> oseqp_sos \<Gamma> i"
         and "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j \<Longrightarrow> \<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, q), a, (\<zeta>', q')) \<in> oseqp_sos \<Gamma> i"
         and "\<forall>j\<in>{i}. \<zeta> j = \<sigma> j"
      then obtain \<zeta>' where "\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j"
                       and "((\<zeta>, q), a, (\<zeta>', q')) \<in> oseqp_sos \<Gamma> i"
        by blast
      thus "\<exists>\<zeta>'. (\<forall>j\<in>{i}. \<zeta>' j = \<sigma>' j) \<and> ((\<zeta>, p \<oplus> q), a, (\<zeta>', q')) \<in> oseqp_sos \<Gamma> i"
        by blast
    qed (simp_all, (metis ogroupcastT ounicastT onotunicastT osendT odeliverT)+)
  qed

lemma oseqp_sos_subreachable [intro!, simp]:
  assumes "trans OA = oseqp_sos \<Gamma> i"
    shows "subreachable OA (other ANY {i}) {i}"
  by rule (clarsimp simp add: assms(1))+

lemma oseq_step_is_seq_step:
    fixes \<sigma> :: "ip \<Rightarrow> 's"
  assumes "((\<sigma>, p), a :: 'm seq_action, (\<sigma>', p')) \<in> oseqp_sos \<Gamma> i"
      and "\<sigma> i = \<xi>"
    shows "\<exists>\<xi>'. \<sigma>' i = \<xi>' \<and> ((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
  using assms proof induction
    fix \<sigma> \<sigma>' l ms p
    assume "\<sigma>' i = \<sigma> i"
       and "\<sigma> i = \<xi>"
    hence "\<sigma>' i = \<xi>" by simp
    have "((\<xi>, {l}broadcast(ms).p), broadcast (ms \<xi>), (\<xi>, p)) \<in> seqp_sos \<Gamma>"
      by auto
    with \<open>\<sigma> i = \<xi>\<close> and \<open>\<sigma>' i = \<xi>\<close> show "\<exists>\<xi>'. \<sigma>' i = \<xi>'
             \<and> ((\<xi>, {l}broadcast(ms).p), broadcast (ms (\<sigma> i)), (\<xi>', p)) \<in> seqp_sos \<Gamma>"
       by clarsimp
  next
    fix fmsg :: "'m \<Rightarrow> 's \<Rightarrow> 's" and msg :: 'm and \<sigma>' \<sigma> l p
    assume "\<sigma>' i = fmsg msg (\<sigma> i)"
       and "\<sigma> i = \<xi>"
    have "((\<xi>, {l}receive(fmsg).p), receive msg, (fmsg msg \<xi>, p)) \<in> seqp_sos \<Gamma>"
      by auto
    with \<open>\<sigma>' i = fmsg msg (\<sigma> i)\<close> and \<open>\<sigma> i = \<xi>\<close>
      show "\<exists>\<xi>'. \<sigma>' i = \<xi>' \<and> ((\<xi>, {l}receive(fmsg).p), receive msg, (\<xi>', p)) \<in> seqp_sos \<Gamma>"
         by clarsimp
  qed (simp_all, (metis assignT choiceT1 choiceT2 groupcastT guardT
                        callT unicastT notunicastT sendT deliverT step_seq_tau)+)

lemma reachable_oseq_seqp_sos:
  assumes "(\<sigma>, p) \<in> reachable OA I"
      and "initiali i (init OA) (init A)"
      and spo: "trans OA = oseqp_sos \<Gamma> i"
      and sp: "trans A = seqp_sos \<Gamma>"
      shows "\<exists>\<xi>. \<sigma> i = \<xi> \<and> (\<xi>, p) \<in> reachable A I"
  using assms(1) proof (induction rule: reachable_pair_induct)
    fix \<sigma> p
    assume "(\<sigma>, p) \<in> init OA"
    with \<open>initiali i (init OA) (init A)\<close> obtain \<xi> where "\<sigma> i = \<xi>"
                                                    and "(\<xi>, p) \<in> init A"
      by auto
    from \<open>(\<xi>, p) \<in> init A\<close> have "(\<xi>, p) \<in> reachable A I" ..
    with \<open>\<sigma> i = \<xi>\<close> show "\<exists>\<xi>. \<sigma> i = \<xi> \<and> (\<xi>, p) \<in> reachable A I"
      by auto
  next
    fix \<sigma> p \<sigma>' p' a
    assume "(\<sigma>, p) \<in> reachable OA I"
       and IH: "\<exists>\<xi>. \<sigma> i = \<xi> \<and> (\<xi>, p) \<in> reachable A I"
       and otr: "((\<sigma>, p), a, (\<sigma>', p')) \<in> trans OA"
       and "I a"
    from IH obtain \<xi> where "\<sigma> i = \<xi>"
                       and cr: "(\<xi>, p) \<in> reachable A I"
      by clarsimp
    from otr and spo have "((\<sigma>, p), a, (\<sigma>', p')) \<in> oseqp_sos \<Gamma> i" by simp
    with \<open>\<sigma> i = \<xi>\<close> obtain \<xi>' where "\<sigma>' i = \<xi>'"
                               and "((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
        by (auto dest!: oseq_step_is_seq_step)
    from this(2) and sp have ctr: "((\<xi>, p), a, (\<xi>', p')) \<in> trans A" by simp
    from \<open>(\<xi>, p) \<in> reachable A I\<close> and ctr and \<open>I a\<close>
      have "(\<xi>', p') \<in> reachable A I" ..
    with \<open>\<sigma>' i = \<xi>'\<close> show "\<exists>\<xi>. \<sigma>' i = \<xi> \<and> (\<xi>, p') \<in> reachable A I"
      by blast
  qed

lemma reachable_oseq_seqp_sos':
  assumes "s \<in> reachable OA I"
      and "initiali i (init OA) (init A)"
      and "trans OA = oseqp_sos \<Gamma> i"
      and "trans A = seqp_sos \<Gamma>"
    shows "\<exists>\<xi>. (fst s) i = \<xi> \<and> (\<xi>, snd s) \<in> reachable A I"
  using assms
  by - (cases s, auto dest: reachable_oseq_seqp_sos)

text \<open>
  Any invariant shown in the (simpler) closed semantics can be transferred to an invariant in
  the open semantics.
\<close>

theorem open_seq_invariant [intro]:
  assumes "A \<TTurnstile> (I \<rightarrow>) P"
      and "initiali i (init OA) (init A)"
      and spo: "trans OA = oseqp_sos \<Gamma> i"
      and sp: "trans A = seqp_sos \<Gamma>"
    shows "OA \<Turnstile> (act I, other ANY {i} \<rightarrow>) (seql i P)"
  proof -
    have "OA \<TTurnstile> (I \<rightarrow>) (seql i P)"
      proof (rule invariant_arbitraryI)
        fix s
        assume "s \<in> reachable OA I"
        with \<open>initiali i (init OA) (init A)\<close> obtain \<xi> where "(fst s) i = \<xi>"
                                                        and "(\<xi>, snd s) \<in> reachable A I"
          by (auto dest: reachable_oseq_seqp_sos' [OF _ _ spo sp])
        with \<open>A \<TTurnstile> (I \<rightarrow>) P\<close> have "P (\<xi>, snd s)" by auto
        with \<open>(fst s) i = \<xi>\<close> show "seql i P s" by auto
      qed
    moreover from spo have "subreachable OA (other ANY {i}) {i}" ..
    ultimately show ?thesis
    proof (rule open_closed_invariant)
      fix \<sigma> \<sigma>' s
      assume "\<forall>j\<in>{i}. \<sigma>' j = \<sigma> j"
         and "seql i P (\<sigma>', s)"
      thus "seql i P (\<sigma>, s)" ..
    qed
  qed

definition
  seqll :: "'i \<Rightarrow> ((('s \<times> 'l) \<times> 'a \<times> ('s \<times> 'l)) \<Rightarrow> bool)
               \<Rightarrow> ((('i \<Rightarrow> 's) \<times> 'l) \<times> 'a \<times> (('i \<Rightarrow> 's) \<times> 'l)) \<Rightarrow> bool"
where
  "seqll i P \<equiv> (\<lambda>((\<sigma>, p), a, (\<sigma>', p')). P ((\<sigma> i, p), a, (\<sigma>' i, p')))"

lemma same_seqll [elim]:
  assumes "\<forall>j\<in>{i}. \<sigma>\<^sub>1' j = \<sigma>\<^sub>1 j"
      and "\<forall>j\<in>{i}. \<sigma>\<^sub>2' j = \<sigma>\<^sub>2 j"
      and "seqll i P ((\<sigma>\<^sub>1', s), a, (\<sigma>\<^sub>2', s'))"
    shows "seqll i P ((\<sigma>\<^sub>1,  s), a, (\<sigma>\<^sub>2,  s'))"
  using assms unfolding seqll_def by (clarsimp)

lemma seqllI [intro!]:
  assumes "P ((\<sigma> i, p), a, (\<sigma>' i, p'))"
    shows "seqll i P ((\<sigma>, p), a, (\<sigma>', p'))"
  using assms unfolding seqll_def by simp

lemma seqllD [dest]:
  assumes "seqll i P ((\<sigma>, p), a, (\<sigma>', p'))"
    shows "P ((\<sigma> i, p), a, (\<sigma>' i, p'))"
  using assms unfolding seqll_def by simp

lemma seqllsimp:
  "seqll i P ((\<sigma>, p), a, (\<sigma>', p')) = P ((\<sigma> i, p), a, (\<sigma>' i, p'))"
  unfolding seqll_def by simp

lemma seqll_onll_swap:
  "seqll i (onll \<Gamma> P) = onll \<Gamma> (seqll i P)"
  unfolding seqll_def onll_def by simp

theorem open_seq_step_invariant [intro]:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
      and "initiali i (init OA) (init A)"
      and spo: "trans OA = oseqp_sos \<Gamma> i"
      and sp: "trans A = seqp_sos \<Gamma>"
    shows "OA \<Turnstile>\<^sub>A (act I, other ANY {i} \<rightarrow>) (seqll i P)"
  proof -
    have "OA \<TTurnstile>\<^sub>A (I \<rightarrow>) (seqll i P)"
    proof (rule step_invariant_arbitraryI)
      fix \<sigma> p a \<sigma>' p'
      assume or: "(\<sigma>, p) \<in> reachable OA I"
         and otr: "((\<sigma>, p), a, (\<sigma>', p')) \<in> trans OA"
         and "I a"
      from or \<open>initiali i (init OA) (init A)\<close> spo sp obtain \<xi> where "\<sigma> i = \<xi>"
                                                             and cr: "(\<xi>, p) \<in> reachable A I"
        by - (drule(3) reachable_oseq_seqp_sos', auto)
      from otr and spo have "((\<sigma>, p), a, (\<sigma>', p')) \<in> oseqp_sos \<Gamma> i" by simp
      with \<open>\<sigma> i = \<xi>\<close> obtain \<xi>' where "\<sigma>' i = \<xi>'"
                                 and ctr: "((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
        by (auto dest!: oseq_step_is_seq_step)
      with sp have "((\<xi>, p), a, (\<xi>', p')) \<in> trans A" by simp
      with \<open>A \<TTurnstile>\<^sub>A (I \<rightarrow>) P\<close> cr have "P ((\<xi>, p), a, (\<xi>', p'))" using \<open>I a\<close> ..
      with \<open>\<sigma> i = \<xi>\<close> and \<open>\<sigma>' i = \<xi>'\<close> have "P ((\<sigma> i, p), a, (\<sigma>' i, p'))" by simp
      thus "seqll i P ((\<sigma>, p), a, (\<sigma>', p'))" ..
    qed
    moreover from spo have "local_steps (trans OA) {i}" by simp
    moreover have "other_steps (other ANY {i}) {i}" ..
    ultimately show ?thesis
    proof (rule open_closed_step_invariant)
      fix \<sigma> \<zeta> a \<sigma>' \<zeta>' s s'
      assume "\<forall>j\<in>{i}. \<sigma> j = \<zeta> j"
         and "\<forall>j\<in>{i}. \<sigma>' j = \<zeta>' j"
         and "seqll i P ((\<sigma>, s), a, (\<sigma>', s'))"
        thus "seqll i P ((\<zeta>, s), a, (\<zeta>', s'))" ..
    qed
  qed

end


(*  Title:      HOL/Auth/Guard/Proto.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section\<open>Other Protocol-Independent Results\<close>

theory Proto imports Guard_Public begin

subsection\<open>protocols\<close>

type_synonym rule = "event set * event"

abbreviation
  msg' :: "rule => msg" where
  "msg' R == msg (snd R)"

type_synonym proto = "rule set"

definition wdef :: "proto => bool" where
"wdef p \<equiv> \<forall>R k. R \<in> p \<longrightarrow> Number k \<in> parts {msg' R}
\<longrightarrow> Number k \<in> parts (msg`(fst R))"

subsection\<open>substitutions\<close>

record subs =
  agent   :: "agent => agent"
  nonce :: "nat => nat"
  nb    :: "nat => msg"
  key   :: "key => key"

primrec apm :: "subs => msg => msg" where
  "apm s (Agent A) = Agent (agent s A)"
| "apm s (Nonce n) = Nonce (nonce s n)"
| "apm s (Number n) = nb s n"
| "apm s (Key K) = Key (key s K)"
| "apm s (Hash X) = Hash (apm s X)"
| "apm s (Crypt K X) = (
if (\<exists>A. K = pubK A) then Crypt (pubK (agent s (agt K))) (apm s X)
else if (\<exists>A. K = priK A) then Crypt (priK (agent s (agt K))) (apm s X)
else Crypt (key s K) (apm s X))"
| "apm s \<lbrace>X,Y\<rbrace> = \<lbrace>apm s X, apm s Y\<rbrace>"

lemma apm_parts: "X \<in> parts {Y} \<Longrightarrow> apm s X \<in> parts {apm s Y}"
apply (erule parts.induct, simp_all, blast)
apply (erule parts.Fst)
apply (erule parts.Snd)
by (erule parts.Body)+

lemma Nonce_apm [rule_format]: "Nonce n \<in> parts {apm s X} \<Longrightarrow>
(\<forall>k. Number k \<in> parts {X} \<longrightarrow> Nonce n \<notin> parts {nb s k}) \<longrightarrow>
(\<exists>k. Nonce k \<in> parts {X} \<and> nonce s k = n)"
by (induct X, simp_all, blast)

lemma wdef_Nonce: "[| Nonce n \<in> parts {apm s X}; R \<in> p; msg' R = X; wdef p;
Nonce n \<notin> parts (apm s `(msg `(fst R))) |] ==>
(\<exists>k. Nonce k \<in> parts {X} \<and> nonce s k = n)"
apply (erule Nonce_apm, unfold wdef_def)
apply (drule_tac x=R in spec, drule_tac x=k in spec, clarsimp)
apply (drule_tac x=x in bspec, simp)
apply (drule_tac Y="msg x" and s=s in apm_parts, simp)
by (blast dest: parts_parts)

primrec ap :: "subs \<Rightarrow> event \<Rightarrow> event" where
  "ap s (Says A B X) = Says (agent s A) (agent s B) (apm s X)"
| "ap s (Gets A X) = Gets (agent s A) (apm s X)"
| "ap s (Notes A X) = Notes (agent s A) (apm s X)"

abbreviation
  ap' :: "subs \<Rightarrow> rule \<Rightarrow> event" where
  "ap' s R \<equiv> ap s (snd R)"

abbreviation
  apm' :: "subs \<Rightarrow> rule \<Rightarrow> msg" where
  "apm' s R \<equiv> apm s (msg' R)"

abbreviation
  priK' :: "subs \<Rightarrow> agent \<Rightarrow> key" where
  "priK' s A \<equiv> priK (agent s A)"

abbreviation
  pubK' :: "subs \<Rightarrow> agent \<Rightarrow> key" where
  "pubK' s A \<equiv> pubK (agent s A)"

subsection\<open>nonces generated by a rule\<close>

definition newn :: "rule \<Rightarrow> nat set" where
"newn R \<equiv> {n. Nonce n \<in> parts {msg (snd R)} \<and> Nonce n \<notin> parts (msg`(fst R))}"

lemma newn_parts: "n \<in> newn R \<Longrightarrow> Nonce (nonce s n) \<in> parts {apm' s R}"
by (auto simp: newn_def dest: apm_parts)

subsection\<open>traces generated by a protocol\<close>

definition ok :: "event list \<Rightarrow> rule \<Rightarrow> subs \<Rightarrow> bool" where
"ok evs R s \<equiv> ((\<forall>x. x \<in> fst R \<longrightarrow> ap s x \<in> set evs)
\<and> (\<forall>n. n \<in> newn R \<longrightarrow> Nonce (nonce s n) \<notin> used evs))"

inductive_set
  tr :: "proto => event list set"
  for p :: proto
where

  Nil [intro]: "[] \<in> tr p"

| Fake [intro]: "[| evsf \<in> tr p; X \<in> synth (analz (spies evsf)) |]
  ==> Says Spy B X # evsf \<in> tr p"

| Proto [intro]: "[| evs \<in> tr p; R \<in> p; ok evs R s |] ==> ap' s R # evs \<in> tr p"

subsection\<open>general properties\<close>

lemma one_step_tr [iff]: "one_step (tr p)"
apply (unfold one_step_def, clarify)
by (ind_cases "ev # evs \<in> tr p" for ev evs, auto)

definition has_only_Says' :: "proto => bool" where
"has_only_Says' p \<equiv> \<forall>R. R \<in> p \<longrightarrow> is_Says (snd R)"

lemma has_only_Says'D: "[| R \<in> p; has_only_Says' p |]
==> (\<exists>A B X. snd R = Says A B X)"
by (unfold has_only_Says'_def is_Says_def, blast)

lemma has_only_Says_tr [simp]: "has_only_Says' p ==> has_only_Says (tr p)"
apply (unfold has_only_Says_def)
apply (rule allI, rule allI, rule impI)
apply (erule tr.induct)
apply (auto simp: has_only_Says'_def ok_def)
by (drule_tac x=a in spec, auto simp: is_Says_def)

lemma has_only_Says'_in_trD: "[| has_only_Says' p; list @ ev # evs1 \<in> tr p |]
==> (\<exists>A B X. ev = Says A B X)"
by (drule has_only_Says_tr, auto)

lemma ok_not_used: "[| Nonce n \<notin> used evs; ok evs R s;
\<forall>x. x \<in> fst R \<longrightarrow> is_Says x |] ==> Nonce n \<notin> parts (apm s `(msg `(fst R)))"
apply (unfold ok_def, clarsimp)
apply (drule_tac x=x in spec, drule_tac x=x in spec)
by (auto simp: is_Says_def dest: Says_imp_spies not_used_not_spied parts_parts)

lemma ok_is_Says: "[| evs' @ ev # evs \<in> tr p; ok evs R s; has_only_Says' p;
R \<in> p; x \<in> fst R |] ==> is_Says x"
apply (unfold ok_def is_Says_def, clarify)
apply (drule_tac x=x in spec, simp)
apply (subgoal_tac "one_step (tr p)")
apply (drule trunc, simp, drule one_step_Cons, simp)
apply (drule has_only_SaysD, simp+)
by (clarify, case_tac x, auto)

subsection\<open>types\<close>

type_synonym keyfun = "rule \<Rightarrow> subs \<Rightarrow> nat \<Rightarrow> event list \<Rightarrow> key set"

type_synonym secfun = "rule \<Rightarrow> nat \<Rightarrow> subs \<Rightarrow> key set \<Rightarrow> msg"

subsection\<open>introduction of a fresh guarded nonce\<close>

definition fresh :: "proto \<Rightarrow> rule \<Rightarrow> subs \<Rightarrow> nat \<Rightarrow> key set \<Rightarrow> event list
\<Rightarrow> bool" where
"fresh p R s n Ks evs \<equiv> (\<exists>evs1 evs2. evs = evs2 @ ap' s R # evs1
\<and> Nonce n \<notin> used evs1 \<and> R \<in> p \<and> ok evs1 R s \<and> Nonce n \<in> parts {apm' s R}
\<and> apm' s R \<in> guard n Ks)"

lemma freshD: "fresh p R s n Ks evs \<Longrightarrow> (\<exists>evs1 evs2.
evs = evs2 @ ap' s R # evs1 \<and> Nonce n \<notin> used evs1 \<and> R \<in> p \<and> ok evs1 R s
\<and> Nonce n \<in> parts {apm' s R} \<and> apm' s R \<in> guard n Ks)"
by (unfold fresh_def, blast)

lemma freshI [intro]: "[| Nonce n \<notin> used evs1; R \<in> p; Nonce n \<in> parts {apm' s R};
ok evs1 R s; apm' s R \<in> guard n Ks |]
==> fresh p R s n Ks (list @ ap' s R # evs1)"
by (unfold fresh_def, blast)

lemma freshI': "[| Nonce n \<notin> used evs1; (l,r) \<in> p;
Nonce n \<in> parts {apm s (msg r)}; ok evs1 (l,r) s; apm s (msg r) \<in> guard n Ks |]
==> fresh p (l,r) s n Ks (evs2 @ ap s r # evs1)"
by (drule freshI, simp+)

lemma fresh_used: "[| fresh p R' s' n Ks evs; has_only_Says' p |]
==> Nonce n \<in> used evs"
apply (unfold fresh_def, clarify)
apply (drule has_only_Says'D)
by (auto intro: parts_used_app)

lemma fresh_newn: "[| evs' @ ap' s R # evs \<in> tr p; wdef p; has_only_Says' p;
Nonce n \<notin> used evs; R \<in> p; ok evs R s; Nonce n \<in> parts {apm' s R} |]
==> \<exists>k. k \<in> newn R \<and> nonce s k = n"
apply (drule wdef_Nonce, simp+)
apply (frule ok_not_used, simp+)
apply (clarify, erule ok_is_Says, simp+)
apply (clarify, rule_tac x=k in exI, simp add: newn_def)
apply (clarify, drule_tac Y="msg x" and s=s in apm_parts)
apply (drule ok_not_used, simp+)
by (clarify, erule ok_is_Says, simp_all)

lemma fresh_rule: "[| evs' @ ev # evs \<in> tr p; wdef p; Nonce n \<notin> used evs;
Nonce n \<in> parts {msg ev} |] ==> \<exists>R s. R \<in> p \<and> ap' s R = ev"
apply (drule trunc, simp, ind_cases "ev # evs \<in> tr p", simp)
by (drule_tac x=X in in_sub, drule parts_sub, simp, simp, blast+)

lemma fresh_ruleD: "[| fresh p R' s' n Ks evs; keys R' s' n evs \<subseteq> Ks; wdef p;
has_only_Says' p; evs \<in> tr p; \<forall>R k s. nonce s k = n \<longrightarrow> Nonce n \<in> used evs \<longrightarrow>
R \<in> p \<longrightarrow> k \<in> newn R \<longrightarrow> Nonce n \<in> parts {apm' s R} \<longrightarrow> apm' s R \<in> guard n Ks \<longrightarrow>
apm' s R \<in> parts (spies evs) \<longrightarrow> keys R s n evs \<subseteq> Ks \<longrightarrow> P |] ==> P"
apply (frule fresh_used, simp)
apply (unfold fresh_def, clarify)
apply (drule_tac x=R' in spec)
apply (drule fresh_newn, simp+, clarify)
apply (drule_tac x=k in spec)
apply (drule_tac x=s' in spec)
apply (subgoal_tac "apm' s' R' \<in> parts (spies (evs2 @ ap' s' R' # evs1))")
apply (case_tac R', drule has_only_Says'D, simp, clarsimp)
apply (case_tac R', drule has_only_Says'D, simp, clarsimp)
apply (rule_tac Y="apm s' X" in parts_parts, blast)
by (rule parts.Inj, rule Says_imp_spies, simp, blast)

subsection\<open>safe keys\<close>

definition safe :: "key set \<Rightarrow> msg set \<Rightarrow> bool" where
"safe Ks G \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G"

lemma safeD [dest]: "[| safe Ks G; K \<in> Ks |] ==> Key K \<notin> analz G"
by (unfold safe_def, blast)

lemma safe_insert: "safe Ks (insert X G) ==> safe Ks G"
by (unfold safe_def, blast)

lemma Guard_safe: "[| Guard n Ks G; safe Ks G |] ==> Nonce n \<notin> analz G"
by (blast dest: Guard_invKey)

subsection\<open>guardedness preservation\<close>

definition preserv :: "proto \<Rightarrow> keyfun \<Rightarrow> nat \<Rightarrow> key set \<Rightarrow> bool" where
"preserv p keys n Ks \<equiv> (\<forall>evs R' s' R s. evs \<in> tr p \<longrightarrow>
Guard n Ks (spies evs) \<longrightarrow> safe Ks (spies evs) \<longrightarrow> fresh p R' s' n Ks evs \<longrightarrow>
keys R' s' n evs \<subseteq> Ks \<longrightarrow> R \<in> p \<longrightarrow> ok evs R s \<longrightarrow> apm' s R \<in> guard n Ks)"

lemma preservD: "[| preserv p keys n Ks; evs \<in> tr p; Guard n Ks (spies evs);
safe Ks (spies evs); fresh p R' s' n Ks evs; R \<in> p; ok evs R s;
keys R' s' n evs \<subseteq> Ks |] ==> apm' s R \<in> guard n Ks"
by (unfold preserv_def, blast)

lemma preservD': "[| preserv p keys n Ks; evs \<in> tr p; Guard n Ks (spies evs);
safe Ks (spies evs); fresh p R' s' n Ks evs; (l,Says A B X) \<in> p;
ok evs (l,Says A B X) s; keys R' s' n evs \<subseteq> Ks |] ==> apm s X \<in> guard n Ks"
by (drule preservD, simp+)

subsection\<open>monotonic keyfun\<close>

definition monoton :: "proto => keyfun => bool" where
"monoton p keys \<equiv> \<forall>R' s' n ev evs. ev # evs \<in> tr p \<longrightarrow>
keys R' s' n evs \<subseteq> keys R' s' n (ev # evs)"

lemma monotonD [dest]: "[| keys R' s' n (ev # evs) \<subseteq> Ks; monoton p keys;
ev # evs \<in> tr p |] ==> keys R' s' n evs \<subseteq> Ks"
by (unfold monoton_def, blast)

subsection\<open>guardedness theorem\<close>

lemma Guard_tr [rule_format]: "[| evs \<in> tr p; has_only_Says' p;
preserv p keys n Ks; monoton p keys; Guard n Ks (initState Spy) |] ==>
safe Ks (spies evs) \<longrightarrow> fresh p R' s' n Ks evs \<longrightarrow> keys R' s' n evs \<subseteq> Ks \<longrightarrow>
Guard n Ks (spies evs)"
apply (erule tr.induct)
(* Nil *)
apply simp
(* Fake *)
apply (clarify, drule freshD, clarsimp)
apply (case_tac evs2)
(* evs2 = [] *)
apply (frule has_only_Says'D, simp)
apply (clarsimp, blast)
(* evs2 = aa # list *)
apply (clarsimp, rule conjI)
apply (blast dest: safe_insert)
(* X:guard n Ks *)
apply (rule in_synth_Guard, simp, rule Guard_analz)
apply (blast dest: safe_insert)
apply (drule safe_insert, simp add: safe_def)
(* Proto *)
apply (clarify, drule freshD, clarify)
apply (case_tac evs2)
(* evs2 = [] *)
apply (frule has_only_Says'D, simp)
apply (frule_tac R=R' in has_only_Says'D, simp)
apply (case_tac R', clarsimp, blast)
(* evs2 = ab # list *)
apply (frule has_only_Says'D, simp)
apply (clarsimp, rule conjI)
apply (drule Proto, simp+, blast dest: safe_insert)
(* apm s X:guard n Ks *)
apply (frule Proto, simp+)
apply (erule preservD', simp+)
apply (blast dest: safe_insert)
apply (blast dest: safe_insert)
by (blast, simp, simp, blast)

subsection\<open>useful properties for guardedness\<close>

lemma newn_neq_used: "[| Nonce n \<in> used evs; ok evs R s; k \<in> newn R |]
==> n \<noteq> nonce s k"
by (auto simp: ok_def)

lemma ok_Guard: "[| ok evs R s; Guard n Ks (spies evs); x \<in> fst R; is_Says x |]
==> apm s (msg x) \<in> parts (spies evs) \<and> apm s (msg x) \<in> guard n Ks"
apply (unfold ok_def is_Says_def, clarify)
apply (drule_tac x="Says A B X" in spec, simp)
by (drule Says_imp_spies, auto intro: parts_parts)

lemma ok_parts_not_new: "[| Y \<in> parts (spies evs); Nonce (nonce s n) \<in> parts {Y};
ok evs R s |] ==> n \<notin> newn R"
by (auto simp: ok_def dest: not_used_not_spied parts_parts)

subsection\<open>unicity\<close>

definition uniq :: "proto \<Rightarrow> secfun \<Rightarrow> bool" where
"uniq p secret \<equiv> \<forall>evs R R' n n' Ks s s'. R \<in> p \<longrightarrow> R' \<in> p \<longrightarrow>
n \<in> newn R \<longrightarrow> n' \<in> newn R' \<longrightarrow> nonce s n = nonce s' n' \<longrightarrow>
Nonce (nonce s n) \<in> parts {apm' s R} \<longrightarrow> Nonce (nonce s n) \<in> parts {apm' s' R'} \<longrightarrow>
apm' s R \<in> guard (nonce s n) Ks \<longrightarrow> apm' s' R' \<in> guard (nonce s n) Ks \<longrightarrow>
evs \<in> tr p \<longrightarrow> Nonce (nonce s n) \<notin> analz (spies evs) \<longrightarrow>
secret R n s Ks \<in> parts (spies evs) \<longrightarrow> secret R' n' s' Ks \<in> parts (spies evs) \<longrightarrow>
secret R n s Ks = secret R' n' s' Ks"

lemma uniqD: "[| uniq p secret; evs \<in> tr p; R \<in> p; R' \<in> p; n \<in> newn R; n' \<in> newn R';
nonce s n = nonce s' n'; Nonce (nonce s n) \<notin> analz (spies evs);
Nonce (nonce s n) \<in> parts {apm' s R}; Nonce (nonce s n) \<in> parts {apm' s' R'};
secret R n s Ks \<in> parts (spies evs); secret R' n' s' Ks \<in> parts (spies evs);
apm' s R \<in> guard (nonce s n) Ks; apm' s' R' \<in> guard (nonce s n) Ks |] ==>
secret R n s Ks = secret R' n' s' Ks"
by (unfold uniq_def, blast)

definition ord :: "proto \<Rightarrow> (rule \<Rightarrow> rule \<Rightarrow> bool) \<Rightarrow> bool" where
"ord p inff \<equiv> \<forall>R R'. R \<in> p \<longrightarrow> R' \<in> p \<longrightarrow> \<not> inff R R' \<longrightarrow> inff R' R"

lemma ordD: "[| ord p inff; \<not> inff R R'; R \<in> p; R' \<in> p |] ==> inff R' R"
by (unfold ord_def, blast)

definition uniq' :: "proto \<Rightarrow> (rule \<Rightarrow> rule \<Rightarrow> bool) \<Rightarrow> secfun \<Rightarrow> bool" where
"uniq' p inff secret \<equiv> \<forall>evs R R' n n' Ks s s'. R \<in> p \<longrightarrow> R' \<in> p \<longrightarrow>
inff R R' \<longrightarrow> n \<in> newn R \<longrightarrow> n' \<in> newn R' \<longrightarrow> nonce s n = nonce s' n' \<longrightarrow>
Nonce (nonce s n) \<in> parts {apm' s R} \<longrightarrow> Nonce (nonce s n) \<in> parts {apm' s' R'} \<longrightarrow>
apm' s R \<in> guard (nonce s n) Ks \<longrightarrow> apm' s' R' \<in> guard (nonce s n) Ks \<longrightarrow>
evs \<in> tr p \<longrightarrow> Nonce (nonce s n) \<notin> analz (spies evs) \<longrightarrow>
secret R n s Ks \<in> parts (spies evs) \<longrightarrow> secret R' n' s' Ks \<in> parts (spies evs) \<longrightarrow>
secret R n s Ks = secret R' n' s' Ks"

lemma uniq'D: "[| uniq' p inff secret; evs \<in> tr p; inff R R'; R \<in> p; R' \<in> p; n \<in> newn R;
n' \<in> newn R'; nonce s n = nonce s' n'; Nonce (nonce s n) \<notin> analz (spies evs);
Nonce (nonce s n) \<in> parts {apm' s R}; Nonce (nonce s n) \<in> parts {apm' s' R'};
secret R n s Ks \<in> parts (spies evs); secret R' n' s' Ks \<in> parts (spies evs);
apm' s R \<in> guard (nonce s n) Ks; apm' s' R' \<in> guard (nonce s n) Ks |] ==>
secret R n s Ks = secret R' n' s' Ks"
by (unfold uniq'_def, blast)

lemma uniq'_imp_uniq: "[| uniq' p inff secret; ord p inff |] ==> uniq p secret"
apply (unfold uniq_def)
apply (rule allI)+
apply (case_tac "inff R R'")
apply (blast dest: uniq'D)
by (auto dest: ordD uniq'D intro: sym)

subsection\<open>Needham-Schroeder-Lowe\<close>

definition a :: agent where "a == Friend 0"
definition b :: agent where "b == Friend 1"
definition a' :: agent where "a' == Friend 2"
definition b' :: agent where "b' == Friend 3"
definition Na :: nat where "Na == 0"
definition Nb :: nat where "Nb == 1"

abbreviation
  ns1 :: rule where
  "ns1 == ({}, Says a b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>))"

abbreviation
  ns2 :: rule where
  "ns2 == ({Says a' b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>)},
    Says b a (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>))"

abbreviation
  ns3 :: rule where
  "ns3 == ({Says a b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>),
    Says b' a (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>)},
    Says a b (Crypt (pubK b) (Nonce Nb)))"

inductive_set ns :: proto where
  [iff]: "ns1 \<in> ns"
| [iff]: "ns2 \<in> ns"
| [iff]: "ns3 \<in> ns"

abbreviation (input)
  ns3a :: event where
  "ns3a == Says a b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>)"

abbreviation (input)
  ns3b :: event where
  "ns3b == Says b' a (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>)"

definition keys :: "keyfun" where
"keys R' s' n evs == {priK' s' a, priK' s' b}"

lemma "monoton ns keys"
by (simp add: keys_def monoton_def)

definition secret :: "secfun" where
"secret R n s Ks ==
(if R=ns1 then apm s (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>)
else if R=ns2 then apm s (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>)
else Number 0)"

definition inf :: "rule => rule => bool" where
"inf R R' == (R=ns1 | (R=ns2 & R'~=ns1) | (R=ns3 & R'=ns3))"

lemma inf_is_ord [iff]: "ord ns inf"
apply (unfold ord_def inf_def)
apply (rule allI)+
apply (rule impI)
apply (simp add: split_paired_all)
by (rule impI, erule ns.cases, simp_all)+

subsection\<open>general properties\<close>

lemma ns_has_only_Says' [iff]: "has_only_Says' ns"
apply (unfold has_only_Says'_def)
apply (rule allI, rule impI)
apply (simp add: split_paired_all)
by (erule ns.cases, auto)

lemma newn_ns1 [iff]: "newn ns1 = {Na}"
by (simp add: newn_def)

lemma newn_ns2 [iff]: "newn ns2 = {Nb}"
by (auto simp: newn_def Na_def Nb_def)

lemma newn_ns3 [iff]: "newn ns3 = {}"
by (auto simp: newn_def)

lemma ns_wdef [iff]: "wdef ns"
by (auto simp: wdef_def elim: ns.cases)

subsection\<open>guardedness for NSL\<close>

lemma "uniq ns secret ==> preserv ns keys n Ks"
apply (unfold preserv_def)
apply (rule allI)+
apply (rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule fresh_ruleD, simp, simp, simp, simp)
apply (rule allI)+
apply (rule impI, rule impI, rule impI)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* fresh with NS1 *)
apply (rule impI, rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule ns.cases)
(* NS1 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (rule No_Nonce, simp)
(* NS2 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (case_tac "nonce sa Na = nonce s Na")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s b" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns1 and R'=ns1 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def keys_def, blast)
apply (rule No_Nonce, simp)
(* NS3 *)
apply clarsimp
apply (case_tac "nonce sa Na = nonce s Nb")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule_tac x=ns3b in ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s a" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns1 and R'=ns2 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def, rule No_Nonce, simp)
(* fresh with NS2 *)
apply (rule impI, rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule ns.cases)
(* NS1 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (rule No_Nonce, simp)
(* NS2 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (case_tac "nonce sa Nb = nonce s Na")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s b" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns2 and R'=ns1 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def, rule No_Nonce, simp)
(* NS3 *)
apply clarsimp
apply (case_tac "nonce sa Nb = nonce s Nb")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule_tac x=ns3b in ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s a" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns2 and R'=ns2 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def keys_def, blast)
apply (rule No_Nonce, simp)
(* fresh with NS3 *)
by simp

subsection\<open>unicity for NSL\<close>

lemma "uniq' ns inf secret"
apply (unfold uniq'_def)
apply (rule allI)+
apply (simp add: split_paired_all)
apply (rule impI, erule ns.cases)
(* R = ns1 *)
apply (rule impI, erule ns.cases)
(* R' = ns1 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule Crypt_insert_synth, simp, simp, simp)
apply (drule Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (clarify, simp add: secret_def)
apply (erule disjE, erule disjE, clarsimp)
apply (drule ok_parts_not_new, simp, simp, simp)
apply (clarify, drule ok_parts_not_new, simp, simp, simp)
(* ns2 *)
apply (simp add: secret_def)
(* ns3 *)
apply (simp add: secret_def)
(* R' = ns2 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule Crypt_insert_synth, simp, simp, simp)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (clarify, simp add: secret_def)
apply (drule_tac s=sa and n=Na in ok_parts_not_new, simp, simp, simp)
(* ns2 *)
apply (clarify, simp add: secret_def)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
(* ns3 *)
apply (simp add: secret_def)
(* R' = ns3 *)
apply simp
(* R = ns2 *)
apply (rule impI, erule ns.cases)
(* R' = ns1 *)
apply (simp only: inf_def, blast)
(* R' = ns2 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (simp add: secret_def)
(* ns2 *)
apply (clarify, simp add: secret_def)
apply (erule disjE, erule disjE, clarsimp, clarsimp)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
apply (erule disjE, clarsimp)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
by (simp_all add: secret_def)

end