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

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

Copyright (C) 2004-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 \<open>State Space Template\<close>
theory StateSpace imports Hoare
begin

record 'g state = "globals"::'g

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> ('g,'z) state_scheme \<Rightarrow> ('g,'z) state_scheme"
where
  "upd_globals upd s = s\<lparr>globals := upd (globals s)\<rparr>"

record ('g, 'n, 'val) stateSP = "'g state" +
  locals :: "'n \<Rightarrow> 'val"

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. s\<lparr>globals := f (globals s)\<rparr>)"
  by (rule ext) (simp add: upd_globals_def)

end


(*
 * Copyright (C) 2014, National ICT Australia Limited. All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *  * Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 *
 *  * Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 *  * The name of National ICT Australia Limited nor the names of its
 *    contributors may be used to endorse or promote products derived from
 *    this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
 * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
 * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

theory MoreDivides
imports "~~/src/HOL/Main"
begin

(* FIXME: to Isabelle lib *)
lemma div_mult_le:
  "(a::nat) div b * b \<le> a"
apply(subgoal_tac "a = a div b * b + a mod b")
 apply arith
apply simp
done

(* FIXME: to Isabelle lib *)
lemma mod_le_dividend:
  "m mod n \<le> (m::nat)"
  by (induct m) (auto simp: mod_Suc)

(* diff_mod_le now also in Num_lemmas.ML *)
(* FIXME: to Isabelle lib? *)
lemma diff_mod_le:
  "\<lbrakk> (a::nat) < d; b dvd d \<rbrakk> \<Longrightarrow> a - a mod b \<le> d - b"
apply(subst mult_div_cancel [symmetric])
apply(clarsimp simp: dvd_def)
apply(case_tac "b = 0")
 apply simp
apply(subgoal_tac "a div b \<le> k - 1")
 prefer 2
 apply(subgoal_tac "a div b < k")
  apply(simp add: less_Suc_eq_le [symmetric])
 apply(subgoal_tac "b * (a div b) < b * ((b * k) div b)")
  apply clarsimp
 apply(subst div_mult_self1_is_m)
  apply arith
 apply(rule le_less_trans)
  apply simp
  apply(subst mult.commute)
  apply(rule div_mult_le)
 apply assumption
apply clarsimp
apply(subgoal_tac "b * (a div b) \<le> b * (k - 1)")
 apply(erule le_trans)
 apply(simp add: diff_mult_distrib2)
apply simp
done

lemma int_div_same_is_1 [simp]:
    "0 < a \<Longrightarrow> ((a :: int) div b = a) = (b = 1)"
  by (metis div_by_1 abs_ge_zero abs_of_pos int_div_less_self neq_iff nonneg1_imp_zdiv_pos_iff zabs_less_one_iff)

lemma nat_div_same_is_1 [simp]:
    "a \<noteq> 0 \<Longrightarrow> ((a :: nat) div b = a) = (b = 1)"
  by (metis div_by_0 div_by_1 div_le_dividend div_less_dividend div_self nat_less_le)

lemma int_div_minus_is_minus1 [simp]:
    "a < 0 \<Longrightarrow> ((a :: int) div b = -a) = (b = -1)"
  by (metis div_minus_right equation_minus_iff int_div_same_is_1 neg_0_less_iff_less)

end


(*  Title:      HOL/Auth/OtwayRees.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Original Otway-Rees Protocol\<close>

theory OtwayRees imports Public begin

text\<open>From page 244 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

This is the original version, which encrypts Nonce NB.\<close>

inductive_set otway :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> otway"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "\<lbrakk>evsf \<in> otway;  X \<in> synth (analz (knows Spy evsf)) \<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> otway"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "\<lbrakk>evsr \<in> otway;  Says A B X \<in>set evsr\<rbrakk>
               \<Longrightarrow> Gets B X # evsr \<in> otway"

         (*Alice initiates a protocol run*)
 | OR1:  "\<lbrakk>evs1 \<in> otway;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Nonce NA, Agent A, Agent B,
                         Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace> \<rbrace>
                 # evs1 \<in> otway"

         (*Bob's response to Alice's message.  Note that NB is encrypted.*)
 | OR2:  "\<lbrakk>evs2 \<in> otway;  Nonce NB \<notin> used evs2;
             Gets B \<lbrace>Nonce NA, Agent A, Agent B, X\<rbrace> : set evs2\<rbrakk>
          \<Longrightarrow> Says B Server
                  \<lbrace>Nonce NA, Agent A, Agent B, X,
                    Crypt (shrK B)
                      \<lbrace>Nonce NA, Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
                 # evs2 \<in> otway"

         (*The Server receives Bob's message and checks that the three NAs
           match.  Then he sends a new session key to Bob with a packet for
           forwarding to Alice.*)
 | OR3:  "\<lbrakk>evs3 \<in> otway;  Key KAB \<notin> used evs3;
             Gets Server
                  \<lbrace>Nonce NA, Agent A, Agent B,
                    Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>,
                    Crypt (shrK B) \<lbrace>Nonce NA, Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
               : set evs3\<rbrakk>
          \<Longrightarrow> Says Server B
                  \<lbrace>Nonce NA,
                    Crypt (shrK A) \<lbrace>Nonce NA, Key KAB\<rbrace>,
                    Crypt (shrK B) \<lbrace>Nonce NB, Key KAB\<rbrace>\<rbrace>
                 # evs3 \<in> otway"

         (*Bob receives the Server's (?) message and compares the Nonces with
           those in the message he previously sent the Server.
           Need B \<noteq> Server because we allow messages to self.*)
 | OR4:  "\<lbrakk>evs4 \<in> otway;  B \<noteq> Server;
             Says B Server \<lbrace>Nonce NA, Agent A, Agent B, X',
                             Crypt (shrK B)
                                   \<lbrace>Nonce NA, Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
               : set evs4;
             Gets B \<lbrace>Nonce NA, X, Crypt (shrK B) \<lbrace>Nonce NB, Key K\<rbrace>\<rbrace>
               : set evs4\<rbrakk>
          \<Longrightarrow> Says B A \<lbrace>Nonce NA, X\<rbrace> # evs4 \<in> otway"

         (*This message models possible leaks of session keys.  The nonces
           identify the protocol run.*)
 | Oops: "\<lbrakk>evso \<in> otway;
             Says Server B \<lbrace>Nonce NA, X, Crypt (shrK B) \<lbrace>Nonce NB, Key K\<rbrace>\<rbrace>
               : set evso\<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> otway"

declare Says_imp_analz_Spy [dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "\<lbrakk>B \<noteq> Server; Key K \<notin> used []\<rbrakk>
      \<Longrightarrow> \<exists>evs \<in> otway.
             Says B A \<lbrace>Nonce NA, Crypt (shrK A) \<lbrace>Nonce NA, Key K\<rbrace>\<rbrace>
               \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] otway.Nil
                    [THEN otway.OR1, THEN otway.Reception,
                     THEN otway.OR2, THEN otway.Reception,
                     THEN otway.OR3, THEN otway.Reception, THEN otway.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says [dest!]:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> otway\<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

(** For reasoning about the encrypted portion of messages **)

lemma OR2_analz_knows_Spy:
     "\<lbrakk>Gets B \<lbrace>N, Agent A, Agent B, X\<rbrace> \<in> set evs;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by blast

lemma OR4_analz_knows_Spy:
     "\<lbrakk>Gets B \<lbrace>N, X, Crypt (shrK B) X'\<rbrace> \<in> set evs;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by blast

(*These lemmas assist simplification by removing forwarded X-variables.
  We can replace them by rewriting with parts_insert2 and proving using
  dest: parts_cut, but the proofs become more difficult.*)
lemmas OR2_parts_knows_Spy =
    OR2_analz_knows_Spy [THEN analz_into_parts]

(*There could be OR4_parts_knows_Spy and Oops_parts_knows_Spy, but for
  some reason proofs work without them!*)

text\<open>Theorems of the form @{term "X \<notin> parts (spies evs)"} imply that
NOBODY sends messages containing X!\<close>

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> otway \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> otway \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk>Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> otway\<rbrakk> \<Longrightarrow> A \<in> bad"
by (blast dest: Spy_see_shrK)

subsection\<open>Towards Secrecy: Proofs Involving @{term analz}\<close>

(*Describes the form of K and NA when the Server sends this message.  Also
  for Oops case.*)
lemma Says_Server_message_form:
     "\<lbrakk>Says Server B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         evs \<in> otway\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK & (\<exists>i. NA = Nonce i) & (\<exists>j. NB = Nonce j)"
by (erule rev_mp, erule otway.induct, simp_all)

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) \<Longrightarrow>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

text\<open>Session keys are not used to encrypt other session keys\<close>

text\<open>The equality makes the induction hypothesis easier to apply\<close>
lemma analz_image_freshK [rule_format]:
 "evs \<in> otway \<Longrightarrow>
   \<forall>K KK. KK <= -(range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule otway.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] OR4_analz_knows_Spy)
apply (drule_tac [5] OR2_analz_knows_Spy, analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
  "\<lbrakk>evs \<in> otway;  KAB \<notin> range shrK\<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's  message.\<close>
lemma unique_session_keys:
     "\<lbrakk>Says Server B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, K\<rbrace>\<rbrace>   \<in> set evs;
         Says Server B' \<lbrace>NA',X',Crypt (shrK B') \<lbrace>NB',K\<rbrace>\<rbrace> \<in> set evs;
         evs \<in> otway\<rbrakk> \<Longrightarrow> X=X' & B=B' & NA=NA' & NB=NB'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
apply blast+  \<comment>\<open>OR3 and OR4\<close>
done

subsection\<open>Authenticity properties relating to NA\<close>

text\<open>Only OR1 can have caused such a part of a message to appear.\<close>
lemma Crypt_imp_OR1 [rule_format]:
 "\<lbrakk>A \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs) -->
      Says A B \<lbrace>NA, Agent A, Agent B,
                 Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace>
        \<in> set evs"
by (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

lemma Crypt_imp_OR1_Gets:
     "\<lbrakk>Gets B \<lbrace>NA, Agent A, Agent B,
                  Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         A \<notin> bad; evs \<in> otway\<rbrakk>
       \<Longrightarrow> Says A B \<lbrace>NA, Agent A, Agent B,
                      Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace>
             \<in> set evs"
by (blast dest: Crypt_imp_OR1)

text\<open>The Nonce NA uniquely identifies A's message\<close>
lemma unique_NA:
     "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs);
         Crypt (shrK A) \<lbrace>NA, Agent A, Agent C\<rbrace> \<in> parts (knows Spy evs);
         evs \<in> otway;  A \<notin> bad\<rbrakk>
      \<Longrightarrow> B = C"
apply (erule rev_mp, erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)
done

text\<open>It is impossible to re-use a nonce in both OR1 and OR2.  This holds because
  OR2 encrypts Nonce NB.  It prevents the attack that can occur in the
  over-simplified version of this protocol: see \<open>OtwayRees_Bad\<close>.\<close>
lemma no_nonce_OR1_OR2:
   "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs);
       A \<notin> bad;  evs \<in> otway\<rbrakk>
    \<Longrightarrow> Crypt (shrK A) \<lbrace>NA', NA, Agent A', Agent A\<rbrace> \<notin> parts (knows Spy evs)"
apply (erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)
done

text\<open>Crucial property: If the encrypted message appears, and A has used NA
  to start a run, then it originated with the Server!\<close>
lemma NA_Crypt_imp_Server_msg [rule_format]:
     "\<lbrakk>A \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs -->
          Crypt (shrK A) \<lbrace>NA, Key K\<rbrace> \<in> parts (knows Spy evs)
          --> (\<exists>NB. Says Server B
                         \<lbrace>NA,
                           Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                           Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs)"
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast)
  subgoal \<comment>\<open>OR1: by freshness\<close>
    by blast
  subgoal \<comment>\<open>OR3\<close>
    by (blast dest!: no_nonce_OR1_OR2 intro: unique_NA)
  subgoal \<comment>\<open>OR4\<close>
    by (blast intro!: Crypt_imp_OR1)
done

text\<open>Corollary: if A receives B's OR4 message and the nonce NA agrees
  then the key really did come from the Server!  CANNOT prove this of the
  bad form of this protocol, even though we can prove
  \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma A_trusts_OR4:
     "\<lbrakk>Says A  B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         Says B' A \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>\<rbrace> \<in> set evs;
     A \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> \<exists>NB. Says Server B
               \<lbrace>NA,
                 Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                 Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast intro!: NA_Crypt_imp_Server_msg)

text\<open>Crucial secrecy property: Spy does not see the keys sent in msg OR3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having @{term "A=Spy"}\<close>
lemma secrecy_lemma:
 "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> Says Server B
        \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
          Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs -->
      Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs -->
      Key K \<notin> analz (knows Spy evs)"
  apply (erule otway.induct, force, simp_all)
  subgoal \<comment>\<open>Fake\<close>
    by spy_analz
  subgoal \<comment>\<open>OR2\<close>
    by (drule OR2_analz_knows_Spy) (auto simp: analz_insert_eq)
  subgoal \<comment>\<open>OR3\<close>
    by (auto simp add: analz_insert_freshK pushes)
  subgoal \<comment>\<open>OR4\<close>
    by (drule OR4_analz_knows_Spy) (auto simp: analz_insert_eq)
  subgoal \<comment>\<open>Oops\<close>
    by (auto simp add: Says_Server_message_form analz_insert_freshK unique_session_keys)
  done

theorem Spy_not_see_encrypted_key:
     "\<lbrakk>Says Server B
          \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest: Says_Server_message_form secrecy_lemma)

text\<open>This form is an immediate consequence of the previous result.  It is
similar to the assertions established by other methods.  It is equivalent
to the previous result in that the Spy already has @{term analz} and
@{term synth} at his disposal.  However, the conclusion
@{term "Key K \<notin> knows Spy evs"} appears not to be inductive: all the cases
other than Fake are trivial, while Fake requires
@{term "Key K \<notin> analz (knows Spy evs)"}.\<close>
lemma Spy_not_know_encrypted_key:
     "\<lbrakk>Says Server B
          \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> knows Spy evs"
by (blast dest: Spy_not_see_encrypted_key)

text\<open>A's guarantee.  The Oops premise quantifies over NB because A cannot know
  what it is.\<close>
lemma A_gets_good_key:
     "\<lbrakk>Says A  B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         Says B' A \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>\<rbrace> \<in> set evs;
         \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: A_trusts_OR4 Spy_not_see_encrypted_key)

subsection\<open>Authenticity properties relating to NB\<close>

text\<open>Only OR2 can have caused such a part of a message to appear.  We do not
  know anything about X: it does NOT have to have the right form.\<close>
lemma Crypt_imp_OR2:
     "\<lbrakk>Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> \<exists>X. Says B Server
                 \<lbrace>NA, Agent A, Agent B, X,
                   Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
                 \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)
done

text\<open>The Nonce NB uniquely identifies B's  message\<close>
lemma unique_NB:
     "\<lbrakk>Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace> \<in> parts(knows Spy evs);
         Crypt (shrK B) \<lbrace>NC, NB, Agent C, Agent B\<rbrace> \<in> parts(knows Spy evs);
           evs \<in> otway;  B \<notin> bad\<rbrakk>
         \<Longrightarrow> NC = NA & C = A"
apply (erule rev_mp, erule rev_mp)
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all)
apply blast+  \<comment>\<open>Fake, OR2\<close>
done

text\<open>If the encrypted message appears, and B has used Nonce NB,
  then it originated with the Server!  Quite messy proof.\<close>
lemma NB_Crypt_imp_Server_msg [rule_format]:
 "\<lbrakk>B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> Crypt (shrK B) \<lbrace>NB, Key K\<rbrace> \<in> parts (knows Spy evs)
      --> (\<forall>X'. Says B Server
                     \<lbrace>NA, Agent A, Agent B, X',
                       Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
           \<in> set evs
           --> Says Server B
                \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                      Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace>
                    \<in> set evs)"
apply simp
apply (erule otway.induct, force, simp_all)
  subgoal \<comment>\<open>Fake\<close>
    by blast
  subgoal \<comment>\<open>OR2\<close>
    by (force dest!: OR2_parts_knows_Spy)
  subgoal \<comment>\<open>OR3\<close>
    by (blast dest: unique_NB dest!: no_nonce_OR1_OR2)  \<comment>\<open>OR3\<close>
  subgoal \<comment>\<open>OR4\<close>
    by (blast dest!: Crypt_imp_OR2)
done

text\<open>Guarantee for B: if it gets a message with matching NB then the Server
  has sent the correct message.\<close>
theorem B_trusts_OR3:
     "\<lbrakk>Says B Server \<lbrace>NA, Agent A, Agent B, X',
                         Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
           \<in> set evs;
         Gets B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Says Server B
               \<lbrace>NA,
                 Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                 Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast intro!: NB_Crypt_imp_Server_msg)

text\<open>The obvious combination of \<open>B_trusts_OR3\<close> with
      \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma B_gets_good_key:
     "\<lbrakk>Says B Server \<lbrace>NA, Agent A, Agent B, X',
                         Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
           \<in> set evs;
         Gets B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: B_trusts_OR3 Spy_not_see_encrypted_key)

lemma OR3_imp_OR2:
     "\<lbrakk>Says Server B
              \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> \<exists>X. Says B Server \<lbrace>NA, Agent A, Agent B, X,
                            Crypt (shrK B) \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
              \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
apply (blast dest!: Crypt_imp_OR2)+
done

text\<open>After getting and checking OR4, agent A can trust that B has been active.
  We could probably prove that X has the expected form, but that is not
  strictly necessary for authentication.\<close>
theorem A_auths_B:
     "\<lbrakk>Says B' A \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>\<rbrace> \<in> set evs;
         Says A  B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace> \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> \<exists>NB X. Says B Server \<lbrace>NA, Agent A, Agent B, X,
                               Crypt (shrK B)  \<lbrace>NA, NB, Agent A, Agent B\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast dest!: A_trusts_OR4 OR3_imp_OR2)

end


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

theory Extract_Conjunct
imports
  "Main"
  "Eisbach_Methods"
begin

section \<open>Extracting conjuncts in the conclusion\<close>

text \<open>
Methods for extracting a conjunct from a nest of conjuncts in the conclusion
of a goal, typically by pattern matching.

When faced with a conclusion which is a big conjunction, it is often the case
that a small number of conjuncts require special attention, while the rest can
be solved easily by @{method clarsimp}, @{method auto} or similar. However,
sometimes the method that would solve the bulk of the conjuncts would put some
of the conjuncts into a more difficult or unsolvable state.

The higher-order methods defined here provide an efficient way to select a
conjunct requiring special treatment, so that it can be dealt with first. Once
all such conjuncts have been removed, the remaining conjuncts can all be solved
together by some automated method.

Each method takes an inner method as an argument, and selects the leftmost
conjunct for which that inner method succeeds. The methods differ according to
what they do with the selected conjunct. See below for more information and
some simple examples.
\<close>

context begin

subsection \<open>Focused conjunct with context\<close>

text \<open>
We define a predicate which allows us to identify a particular sub-tree and its
context within a nest of conjunctions. We express this sub-tree-with-context using
a function which reconstructs the original nest of conjunctions. The context
consists of a list of parent contexts, where each parent context consists of a
sibling sub-tree, and a tag indicating whether the focused sub-tree is on the left
or right. Rebuilding the original tree works from the focused sub-tree up towards
the root of the original structure. This sub-tree-with-context is sometimes known
as a zipper.
\<close>

private fun focus_conj :: "bool \<Rightarrow> bool list \<Rightarrow> bool" where
  "focus_conj current [] = current"
| "focus_conj current (sibling # parents) = focus_conj (current \<and> sibling) parents"

private definition "focus \<equiv> focus_conj"

private definition "tag t P \<equiv> P"
private lemmas focus_defs = focus_def tag_def

private abbreviation "left \<equiv> tag Left"
private abbreviation "right \<equiv> tag Right"

private lemma focus_example:
  "focus C [right B, left D, left E, right A] \<longleftrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  unfolding focus_defs by auto

subsection \<open>Moving the focus\<close>

text \<open>
We now prove some rules which allow us to switch between focused and unfocused
structures, and to move the focus around. Some versions of these rules carry an
extra conjunct @{term E} outside the structure. Once we find the conjunct we want,
this @{term E} allows to keep track of it while we reassemble the rest of the
original structure.

First, we have rules for going between focused and unfocused structures.
\<close>

private lemma focus_top_iff: "E \<and> focus P [] \<longleftrightarrow> E \<and> P"
  unfolding focus_def by simp

private lemmas to_focus = focus_top_iff[where E=True, simplified, THEN iffD1]
private lemmas from_focusE = focus_top_iff[THEN iffD2]
private lemmas from_focus = from_focusE[where E=True, simplified]

text \<open>
Next, we have rules for moving the focus to and from the left conjunct.
\<close>

private lemma focus_left_iff: "E \<and> focus L (left R # P) \<longleftrightarrow> E \<and> focus (L \<and> R) P"
  unfolding focus_defs by simp

private lemmas focus_left = focus_left_iff[where E=True, simplified, THEN iffD1]
private lemmas unfocusE_left = focus_left_iff[THEN iffD2]
private lemmas unfocus_left = unfocusE_left[where E=True, simplified]

text \<open>
Next, we have rules for moving the focus to and from the right conjunct.
\<close>

private lemma focus_right_iff: "E \<and> focus R (right L # P) \<longleftrightarrow> E \<and> focus (L \<and> R) P"
  unfolding focus_defs using conj_commute by simp

private lemmas focus_right = focus_right_iff[where E=True, simplified, THEN iffD1]
private lemmas unfocusE_right = focus_right_iff[THEN iffD2]
private lemmas unfocus_right = unfocusE_right[where E=True, simplified]

text \<open>
Finally, we have rules for extracting the current focus. The sibling of the
extracted focus becomes the new focus of the remaining structure.
\<close>

private lemma extract_focus_iff: "focus C (tag t S # P) \<longleftrightarrow> (C \<and> focus S P)"
  unfolding focus_defs by (induct P arbitrary: S) auto

private lemmas extract_focus = extract_focus_iff[THEN iffD2]

subsection \<open>Primitive methods for navigating a conjunction\<close>

text \<open>
Using these rules as transitions, we implement a machine which navigates a tree
of conjunctions, searching from left to right for a conjunct for which a given
method will succeed. Once a matching conjunct is found, it is extracted, and the
remaining conjuncts are reassembled.
\<close>

text \<open>From the current focus, move to the leftmost sub-conjunct.\<close>
private method focus_leftmost = (intro focus_left)?

text \<open>Find the furthest ancestor for which the current focus is still on the right.\<close>
private method unfocus_rightmost = (intro unfocus_right)?

text \<open>Move to the immediate-right sibling.\<close>
private method focus_right_sibling = (rule unfocus_left, rule focus_right)

text \<open>Move to the next conjunct in right-to-left ordering.\<close>
private method focus_next_conjunct = (unfocus_rightmost, focus_right_sibling, focus_leftmost)

text \<open>Search from current focus toward the right until we find a matching conjunct.\<close>
private method find_match methods m = (rule extract_focus, m | focus_next_conjunct, find_match m)

text \<open>Search within nest of conjuncts, leaving remaining structure focused.\<close>
private method extract_match methods m = (rule to_focus, focus_leftmost, find_match m)

text \<open>Move all the way out of focus, keeping track of any extracted conjunct.\<close>
private method unfocusE = ((intro unfocusE_right unfocusE_left)?, rule from_focusE)
private method unfocus = ((intro unfocus_right unfocus_left)?, rule from_focus)

subsection \<open>Methods for selecting the leftmost matching conjunct\<close>

text \<open>
See the introduction at the top of this theory for motivation, and below for
some simple examples.
\<close>

text \<open>
Assuming the conclusion of the goal is a nest of conjunctions, method
@{text lift_conjunct} finds the leftmost conjunct for which the given method
succeeds, and moves it to the front of the conjunction in the goal.
\<close>
method lift_conjunct methods m = (extract_match \<open>succeeds \<open>rule conjI, m\<close>\<close>, unfocusE)

text \<open>
Method @{text extract_conjunct} finds the leftmost conjunct for which the
given method succeeds, and splits it into a fresh subgoal, leaving the remaining
conjuncts untouched in the second subgoal. It is equivalent to @{method lift_conjunct}
followed by @{method rule} @{thm conjI}.
\<close>
method extract_conjunct methods m = (extract_match \<open>rule conjI, succeeds m\<close>; unfocus?)

text \<open>
Method @{text apply_conjunct} finds the leftmost conjunct for which the given
method succeeds, leaving any subgoals created by the application of that method,
and a subgoal containing the remaining conjuncts untouched. It is equivalent to
@{method extract_conjunct} followed by the given method, but more efficient.
\<close>
method apply_conjunct methods m = (extract_match \<open>rule conjI, m\<close>; unfocus?)

subsection \<open>Examples\<close>

text \<open>
Given an inner method based on @{method match}, which only succeeds on the desired
conjunct @{term C}, @{method lift_conjunct} moves the conjunct @{term C} to the
front. The body of the @{method match} here is irrelevant, since @{method lift_conjunct}
always discards the effect of the method it is given.
\<close>
lemma "\<lbrakk> A; B; \<lbrakk> A; B; D; E \<rbrakk> \<Longrightarrow> C; D; E \<rbrakk> \<Longrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  apply (lift_conjunct \<open>match conclusion in C \<Rightarrow> \<open>-\<close>\<close>)
  \<comment> \<open>@{term C} as been moved to the front of the conclusion.\<close>
  apply (match conclusion in \<open>C \<and> A \<and> (B \<and> D) \<and> E\<close> \<Rightarrow> \<open>-\<close>)
  oops

text \<open>
Method @{method extract_conjunct} works similarly, but peels of the matched conjunct
as a separate subgoal. As for @{method lift_conjunct}, the effect of the given method
is discarded, so the body of the @{method match} is irrelevant.
\<close>
lemma "\<lbrakk> A; B; \<lbrakk> A; B; D; E \<rbrakk> \<Longrightarrow> C; D; E \<rbrakk> \<Longrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  apply (extract_conjunct \<open>match conclusion in C \<Rightarrow> \<open>-\<close>\<close>)
  \<comment> \<open>@{method extract_conjunct} gives us the matched conjunct @{term C} as a separate subgoal.\<close>
   apply (match conclusion in C \<Rightarrow> \<open>-\<close>)
   apply blast
  \<comment> \<open>The other subgoal contains the remaining conjuncts untouched.\<close>
  apply (match conclusion in \<open>A \<and> (B \<and> D) \<and> E\<close> \<Rightarrow> \<open>-\<close>)
  oops

text \<open>
Method @{method apply_conjunct} goes one step further, and applies the given method
to the extracted subgoal.
\<close>
lemma "\<lbrakk> A; B; \<lbrakk> A; B; D; E \<rbrakk> \<Longrightarrow> C; D; E \<rbrakk> \<Longrightarrow> A \<and> ((B \<and> C) \<and> D) \<and> E"
  apply (apply_conjunct \<open>match conclusion in C \<Rightarrow> \<open>match premises in H: _ \<Rightarrow> \<open>rule H\<close>\<close>\<close>)
  \<comment> \<open>We get four subgoals from applying the given method to the matched conjunct @{term C}.\<close>
      apply (match premises in H: A \<Rightarrow> \<open>rule H\<close>)
     apply (match premises in H: B \<Rightarrow> \<open>rule H\<close>)
    apply (match premises in H: D \<Rightarrow> \<open>rule H\<close>)
   apply (match premises in H: E \<Rightarrow> \<open>rule H\<close>)
  \<comment> \<open>The last subgoal contains the remaining conjuncts untouched.\<close>
  apply (match conclusion in \<open>A \<and> (B \<and> D) \<and> E\<close> \<Rightarrow> \<open>-\<close>)
  oops

end

end


section {*I\_kparser\_base*}
theory
  I_kparser_base

imports
  PRJ_08__ENTRY

begin

record ('stack, 'event) parser_step_label =
  rule_lpop :: "'stack list"
  rule_rpop :: "'event list"
  rule_lpush :: "'stack list"
  rule_rpush :: "'event list"

record ('stack, 'event, 'marker) parser =
  parser_nonterms :: "'stack set"
  parser_events :: "'event set"
  parser_initial :: "'stack"
  parser_marking :: "'stack set"
  parser_rules :: "('stack, 'event) parser_step_label set"
  parser_marker :: "('stack, 'event) parser_step_label \<Rightarrow> 'marker"
  parser_bottom :: "'event"

definition valid_parser_step_label :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> ('stack, 'event) parser_step_label
  \<Rightarrow> bool"
  where
    "valid_parser_step_label G e \<equiv>
  (\<exists>k. rule_rpop e \<in> (kPrefix k) `
    {w @ [parser_bottom G] | w.
      set w \<subseteq> parser_events G - {parser_bottom G}})
  \<and> set (rule_rpush e) \<subseteq> parser_events G
  \<and> set (rule_lpop e) \<subseteq> parser_nonterms G
  \<and> set (rule_lpush e) \<subseteq> parser_nonterms G
  \<and> rule_lpop e \<noteq> []
  \<and> rule_lpush e \<noteq> []
  \<and> (\<exists>x. x @ rule_rpush e = rule_rpop e)
  \<and> ((\<exists>x. x @ [parser_bottom G] = rule_rpop e)
      \<longrightarrow> (\<exists>x. x @ [parser_bottom G] = rule_rpush e))"

lemma kPrefix_vs_take: "
  kPrefix k w = take k w"
  apply(simp add: kPrefix_def)
  done

definition valid_parser :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "valid_parser G \<equiv>
  finite (parser_events G)
  \<and> finite (parser_nonterms G)
  \<and> parser_initial G \<in> parser_nonterms G
  \<and> parser_marking G \<subseteq> parser_nonterms G
  \<and> finite (parser_rules G)
  \<and> (\<forall>e \<in> parser_rules G.
      valid_parser_step_label G e)
  \<and> parser_bottom G \<in> parser_events G"

definition parser_step_labels :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> ('stack, 'event) parser_step_label set"
  where
    "parser_step_labels G \<equiv>
  parser_rules G"

datatype ('stack, 'event) parser_destinations =
  state "'stack"
  | rule "('stack, 'event) parser_step_label"

definition parser_destinations :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> ('stack, 'event) parser_destinations set"
  where
    "parser_destinations G \<equiv>
  state ` (parser_nonterms G)
  \<union> rule ` (parser_rules G)"

definition parser_markers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_markers G \<equiv>
  {w. set w \<subseteq> parser_events G}"

definition parser_schedulers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_schedulers G \<equiv>
  {w. \<exists>v.
    set v \<subseteq> parser_events G
    \<and> parser_bottom G \<notin> set v
    \<and> w = v @ [parser_bottom G]}"

definition parser_fixed_schedulers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_fixed_schedulers G \<equiv>
  prefix_closure (parser_schedulers G)"

definition parser_unfixed_schedulers :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_unfixed_schedulers G \<equiv>
  suffix_closure (parser_schedulers G)"

definition parser_scheduler_fragments :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list set"
  where
    "parser_scheduler_fragments G \<equiv>
  {w. set w \<subseteq> parser_events G \<and> parser_bottom G \<notin> set w}"

definition parser_no_top_rules :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_no_top_rules G \<equiv>
  \<forall>e \<in> parser_rules G. rule_rpush e = []"

definition parser_observes_input_terminator :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_observes_input_terminator G \<equiv>
  \<exists>e \<in> parser_rules G. parser_bottom G \<in> set (rule_rpop e)"

definition parser_not_observes_input_terminator :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_not_observes_input_terminator G \<equiv>
  \<forall>e \<in> parser_rules G. parser_bottom G \<notin> set (rule_rpush e)"

definition parser_no_access_final_with_read :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_no_access_final_with_read G \<equiv>
  \<forall>e \<in> parser_rules G. \<forall>a.
  rule_rpop e = [a]
  \<and> rule_rpush e = []
  \<and> last (rule_lpush e) \<in> parser_marking G
  \<longrightarrow> False"

definition parser_no_leave_final_with_empty_step :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> bool"
  where
    "parser_no_leave_final_with_empty_step G \<equiv>
  \<forall>q \<in> parser_marking G.
  \<forall>e \<in> parser_rules G.
  last (rule_lpop e) = q
  \<and> rule_rpop e \<in> {[parser_bottom G], []}
  \<longrightarrow> last (rule_lpush e) \<in> parser_marking G"

primrec tau :: "
  ('a \<Rightarrow> 'b option option)
  \<Rightarrow> 'a option list
  \<Rightarrow> 'b option list"
  where
    "tau f [] = []"
  | "tau f (a # w) =
  (case a
  of None \<Rightarrow> []
  | Some a' \<Rightarrow> (case (f a')
                of None \<Rightarrow> []
                | Some a'' \<Rightarrow> (case a''
                              of None \<Rightarrow> []
                              | Some a''' \<Rightarrow> [Some a'''])))
  @ tau f w"

lemma tau_select: "
  x \<in> set (tau f w)
  \<Longrightarrow> (\<exists>y. x \<in> set (tau f [y]) \<and> y \<in> set w)"
  apply(induct w)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  apply(erule disjE)
   apply(rename_tac a w)(*strict*)
   apply(clarsimp)
   apply(rename_tac w uu_ uua_)(*strict*)
   apply(rename_tac x1 x2)
   apply(rename_tac w x1 x2)(*strict*)
   apply(rule_tac
      x="Some x2"
      in exI)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  apply(rename_tac a w uu_ uua_)(*strict*)
  apply(rename_tac x1 x2)
  apply(rename_tac a w x1 x2)(*strict*)
  apply(rule_tac
      x="Some x2"
      in exI)
  apply(clarsimp)
  done

definition valid_bounded_parser :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> nat
  \<Rightarrow> bool"
  where
    "valid_bounded_parser G k \<equiv>
  valid_parser G
  \<and> (\<forall>e \<in> parser_rules G. length (rule_rpop e) \<le> k)"

lemma valid_parser_initial_in_nonterms: "
  valid_parser P
  \<Longrightarrow> parser_initial P \<in> parser_nonterms P"
  apply(simp add: valid_parser_def)
  done

lemma valid_parser_bottom_in_parser_events: "
  valid_parser P
  \<Longrightarrow> parser_bottom P \<in> parser_events P"
  apply(simp add: valid_parser_def)
  done

lemma valid_parser_step_label_not_parser_bottom_random_insertion: "
  valid_parser_step_label G e
  \<Longrightarrow> (\<exists>x. x@[parser_bottom G]=rule_rpush e) \<longrightarrow> (\<exists>x. x@[parser_bottom G]=rule_rpop e)"
  apply(simp add: valid_parser_step_label_def)
  apply(erule conjE)+
  apply(rule impI)
  apply(erule exE)+
  apply(rename_tac k x xa)(*strict*)
  apply(rule_tac
      x="x@xa"
      in exI)
  apply(force)
  done

lemma valid_parser_step_label_also_req_for_rpush: "
  valid_parser_step_label G e
  \<Longrightarrow> (\<exists>k. rule_rpush e \<in> ((kPrefix k) ` ({w@[parser_bottom G]|w. set w\<subseteq> (parser_events G)-{parser_bottom G}})))"
  apply(simp add: valid_parser_step_label_def)
  apply(clarsimp)
  apply(rename_tac k w xa)(*strict*)
  apply(case_tac e)
  apply(rename_tac k w xa rule_lpopa rule_rpopa rule_lpusha rule_rpusha)(*strict*)
  apply(clarsimp)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
  apply(simp add: kPrefix_def)
  apply(case_tac "k-length w>0")
   apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
   apply(clarsimp)
   apply(rename_tac k xa rule_lpop rule_lpush x)(*strict*)
   apply(rule_tac
      x="Suc (length x)"
      in exI)
   apply(rule inMap)
   apply(clarsimp)
   apply(rule_tac
      x="x@[parser_bottom G]"
      in exI)
   apply(clarsimp)
   apply(simp add: kPrefix_def)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
  apply(clarsimp)
  apply(case_tac "rule_rpush")
   apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush)(*strict*)
   apply(clarsimp)
   apply(rename_tac k w rule_lpop rule_lpush)(*strict*)
   apply(rule_tac
      x="0"
      in exI)
   apply(rule inMap)
   apply(rule_tac
      x="[parser_bottom G]"
      in bexI)
    apply(rename_tac k w rule_lpop rule_lpush)(*strict*)
    apply(simp add: kPrefix_def)
   apply(rename_tac k w rule_lpop rule_lpush)(*strict*)
   apply(clarsimp)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. rule_rpush = w' @ [x']")
   apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac k w xa rule_lpop rule_lpush rule_rpush a list)(*strict*)
  apply(thin_tac "rule_rpush = a # list")
  apply(clarsimp)
  apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
  apply(case_tac "x'=parser_bottom G")
   apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
   apply(clarsimp)
   apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
   apply(rule_tac
      x="Suc(length w')"
      in exI)
   apply(rule inMap)
   apply(clarsimp)
   apply(rule_tac
      x="w' @ [parser_bottom G]"
      in exI)
   apply(clarsimp)
   apply(simp add: kPrefix_def)
   apply(rule_tac
      B="set w"
      in subset_trans)
    apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
    apply(rule_tac
      B="set (take k w)"
      in subset_trans)
     apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
     apply(rule_tac
      B="set (xa @ w' @ [parser_bottom G])"
      in subset_trans)
      apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
      apply(rule set_bi_append)
     apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
     apply(force)
    apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
    apply(rule set_take_subset)
   apply(rename_tac k w xa rule_lpop rule_lpush w')(*strict*)
   apply(force)
  apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
  apply(clarsimp)
  apply(rule_tac
      x="Suc(length w')"
      in exI)
  apply(rule inMap)
  apply(clarsimp)
  apply(rule_tac
      x="w' @ [x'] @ [parser_bottom G]"
      in exI)
  apply(clarsimp)
  apply(simp add: kPrefix_def)
  apply(rule_tac
      B="set w"
      in subset_trans)
   apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
   apply(rule_tac
      B="set (take k w)"
      in subset_trans)
    apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
    apply(rule_tac
      B="set (xa @ w' @ [x'])"
      in subset_trans)
     apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
     apply(rule set_bi_append)
    apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
    apply(force)
   apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
   apply(rule set_take_subset)
  apply(rename_tac k w xa rule_lpop rule_lpush w' x')(*strict*)
  apply(force)
  done

lemma tau_append_commutes: "
  tau f (w@v) = tau f w @ (tau f v)"
  apply(induct w)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  done

primrec parser_fixed_input_length_recN :: "
  (('stack, 'event) parser_step_label, 'abstr_parser_conf)derivation
  \<Rightarrow> nat
  \<Rightarrow> nat"
  where
    "parser_fixed_input_length_recN d 0 = 0"
  | "parser_fixed_input_length_recN d (Suc n) =
    (case d (Suc n) of
      Some (pair (Some e) c) \<Rightarrow>
          max
            (parser_fixed_input_length_recN d n)
            (length (rule_rpop e))
          - (length (rule_rpop e) - length (rule_rpush e))
    | _ \<Rightarrow> parser_fixed_input_length_recN d n)"

definition parser_fixed_input_length_foldl :: "
  (('stack, 'event) parser_step_label, 'abstr_parser_conf)derivation
  \<Rightarrow> nat
  \<Rightarrow> nat"
  where
    "parser_fixed_input_length_foldl d n \<equiv>
  foldl
    (\<lambda>x s. (case s of [a, b] \<Rightarrow> (max x a) - (a - b)))
    0
    (map
      (\<lambda>n.
        case d n of
          Some (pair (Some e) c) \<Rightarrow>
            [length (rule_rpop e), length (rule_rpush e)])
      (nat_seq (Suc 0) n))"

primrec parser_fixed_input_length_rec1 :: "
  (('stack, 'event) parser_step_label, 'abstr_parser_conf)derivation
  \<Rightarrow> nat
  \<Rightarrow> nat"
  where
    "parser_fixed_input_length_rec1 d 0 = 0"
  | "(parser_fixed_input_length_rec1 d (Suc n)) =
    (case d (Suc n) of
      Some (pair (Some e) c) \<Rightarrow>
        (case rule_rpop e of
            [] \<Rightarrow> parser_fixed_input_length_rec1 d n
            | _ \<Rightarrow> length (rule_rpush e))
      | _ \<Rightarrow> parser_fixed_input_length_rec1 d n)"

(*
  The unmarked language should be contained in the prefixclosure of the set of words which (if the parser is started with one of them) can touch every every DT_symbol.
  Furthermore, an element of this prefixclosure is only contained, if

  r·s in unmarked_language
  \<longleftrightarrow> \<exists>d t. d start with r·s·t·$ and ends with s·t·$ where s (and (if t=\<lambda>) possibly $) has been seen and t has not been seen
  \<longleftrightarrow> \<exists>d. d start with r·s·$ and ends with s·$ where s (and possibly $) has been seen

  Note, the translation of a parser into a topfree parser should preserve marked and unmarked language.
  Therefore the interpretation is reasonable.

  Example:
  derivation: q0 | ab$ \<Rightarrow> (q0, ab$, q1, $) \<Rightarrow> q1|$
  unmarked_language_element: i=0: \<lambda>
  unmarked_language_element: i=1: ab
  derivation: q0 | ab$ \<Rightarrow> (q0, ab, q1, b) \<Rightarrow> q1|b$
  unmarked_language_element: i=0: \<lambda>
  unmarked_language_element: i=1: ab
  derivation: q0 | ab$ \<Rightarrow> (q0, a, q1, \<lambda>) \<Rightarrow> q1|b$
  unmarked_language_element: i=0: \<lambda>
  unmarked_language_element: i=1: a
*)

lemma parser_inst_AX_empty_fixed_scheduler_in_fixed_schedulers: "
  \<forall>G. valid_parser G \<longrightarrow> [] \<in> parser_fixed_schedulers G"
  apply(simp add: parser_fixed_schedulers_def prefix_closure_def prefix_def parser_schedulers_def)
  apply(clarsimp)
  apply(rename_tac G)(*strict*)
  apply(rule_tac
      x="[]"
      in exI)
  apply(force)
  done

lemma parser_inst_AX_empty_scheduler_fragment_in_scheduler_fragments: "
  \<forall>G. valid_parser G \<longrightarrow> [] \<in> parser_scheduler_fragments G"
  apply(simp add: parser_scheduler_fragments_def)
  done

lemma parser_inst_AX_join_scheduler_fragments_closed : "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE1. sE1 \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>sE2. sE2 \<in> parser_scheduler_fragments G \<longrightarrow> sE1 @ sE2 \<in> parser_scheduler_fragments G)))"
  apply(simp add: parser_scheduler_fragments_def)
  done

lemma parser_inst_AX_join_scheduler_fragments_foldl_split: "
  (\<forall>w v. foldl (@) (foldl (@) [] w) v = foldl (@) [] w @ foldl (@) [] v)"
  apply (metis concat_conv_foldl foldl_conv_concat)
  done

lemma parser_inst_AX_foldl_join_scheduler_fragments : "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE. sE \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>w. set w \<subseteq> parser_scheduler_fragments G \<longrightarrow> foldl (@) sE w = sE @ foldl (@) [] w)))"
  apply(clarsimp)
  apply(rename_tac G sE w)(*strict*)
  apply (metis concat_conv_foldl foldl_conv_concat)
  done

lemma parser_inst_AX_extend_unfixed_scheduler_unfixed_scheduler_right_quotient_empty: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> the (right_quotient_word sUF []) = sUF))"
  apply(simp add: right_quotient_word_def)
  done

lemma parser_inst_AX_unfixed_scheduler_right_quotient_all: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> right_quotient_word sUF sUF = Some []))"
  apply(clarsimp)
  apply(rename_tac G sUF)(*strict*)
  apply(simp add: right_quotient_word_def)
  done

lemma parser_inst_AX_empty_unfixed_scheduler_in_unfixed_schedulers: "
  (\<forall>G. valid_parser G \<longrightarrow> [] \<in> parser_unfixed_schedulers G)"
  apply(simp add: parser_unfixed_schedulers_def suffix_closure_def suffix_def parser_schedulers_def)
  apply(clarsimp)
  apply(rename_tac G)(*strict*)
  apply(rule_tac
      x="[]"
      in exI)
  apply(force)
  done

lemma parser_inst_AX_extend_unfixed_scheduler_closed: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE. sE \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> sUF \<sqsupseteq> [parser_bottom G] \<longrightarrow> sE @ sUF \<in> parser_unfixed_schedulers G)))"
  apply(simp add: suffix_def parser_unfixed_schedulers_def parser_scheduler_fragments_def parser_schedulers_def suffix_closure_def)
  apply(clarsimp)
  apply(rename_tac G sE c ca)(*strict*)
  apply(rule_tac
      x="sE@ca@[parser_bottom G]"
      in exI)
  apply(clarsimp)
  done

lemma parser_inst_AX_extend_scheduler_closed: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sE. sE \<in> parser_scheduler_fragments G \<longrightarrow> (\<forall>s. s \<in> parser_schedulers G \<longrightarrow> sE @ s \<in> parser_schedulers G)))"
  apply(clarsimp)
  apply(rename_tac G sE s)(*strict*)
  apply(simp add: parser_schedulers_def parser_scheduler_fragments_def)
  apply(clarsimp)
  done

lemma parser_inst_AX_extend_unfixed_scheduler_preserves_unfixed_scheduler_extendable: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sUF. sUF \<sqsupseteq> [parser_bottom G] \<longrightarrow> (\<forall>sE. (sE @ sUF) \<sqsupseteq> [parser_bottom G])))"
  apply(clarsimp)
  apply(rename_tac G sUF sE)(*strict*)
  apply(simp add: suffix_def)
  apply(force)
  done

lemma parser_inst_AX_empty_scheduler_in_schedulers: "
  (\<forall>G. valid_parser G \<longrightarrow> [parser_bottom G] \<in> parser_schedulers G)"
  apply(simp add: parser_schedulers_def)
  done

lemma parser_inst_AX_join_fixed_scheduler_unfixed_scheduler_closed: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sF. sF \<in> parser_fixed_schedulers G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> (\<not> sF \<sqsupseteq> [parser_bottom G]) = sUF \<sqsupseteq> [parser_bottom G] \<longrightarrow> sF @ sUF \<in> parser_schedulers G)))"
  apply(clarsimp)
  apply(rename_tac G sF sUF)(*strict*)
  apply(simp add: suffix_def)
  apply(simp add: parser_schedulers_def parser_fixed_schedulers_def parser_unfixed_schedulers_def prefix_closure_def prefix_def suffix_closure_def suffix_def)
  apply(clarsimp)
  apply(rename_tac G sF sUF vb c vc ca)(*strict*)
  apply(case_tac sUF)
   apply(rename_tac G sF sUF vb c vc ca)(*strict*)
   apply(clarsimp)
   apply(rename_tac G vb c vc cb)(*strict*)
   apply(case_tac c)
    apply(rename_tac G vb c vc cb)(*strict*)
    apply(clarsimp)
   apply(rename_tac G vb c vc cb a list)(*strict*)
   apply(subgoal_tac "\<exists>w' x'. c = w' @ [x']")
    apply(rename_tac G vb c vc cb a list)(*strict*)
    prefer 2
    apply(rule NonEmptyListHasTailElem)
    apply(force)
   apply(rename_tac G vb c vc cb a list)(*strict*)
   apply(thin_tac "c = a # list")
   apply(clarsimp)
  apply(rename_tac G sF sUF vb c vc ca a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. sUF = w' @ [x']")
   apply(rename_tac G sF sUF vb c vc ca a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sF sUF vb c vc ca a list)(*strict*)
  apply(thin_tac "sUF = a # list")
  apply(clarsimp)
  apply(rename_tac G sF vb c ca w')(*strict*)
  apply(case_tac c)
   apply(rename_tac G sF vb c ca w')(*strict*)
   apply(clarsimp)
  apply(rename_tac G sF vb c ca w' a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. c = w' @ [x']")
   apply(rename_tac G sF vb c ca w' a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sF vb c ca w' a list)(*strict*)
  apply(thin_tac "c = a # list")
  apply(clarsimp)
  done

lemma valid_bounded_parser_vs_valid_parser: "
  valid_bounded_parser G k
  \<Longrightarrow> valid_parser G"
  apply(simp add: valid_bounded_parser_def)
  done

lemma parser1X_inst_AX_empty_fixed_scheduler_in_fixed_schedulers: "
  \<forall>G. valid_bounded_parser G (Suc 0) \<longrightarrow> [] \<in> parser_fixed_schedulers G"
  apply(metis valid_bounded_parser_vs_valid_parser parser_inst_AX_empty_fixed_scheduler_in_fixed_schedulers)
  done

lemma parser_inst_AX_fixed_scheduler_extendable_vs_unfixed_scheduler_extendable: "
  (\<forall>G. valid_parser G \<longrightarrow> (\<forall>sF. sF \<in> parser_fixed_schedulers G \<longrightarrow> (\<forall>sUF. sUF \<in> parser_unfixed_schedulers G \<longrightarrow> sF @ sUF \<in> parser_schedulers G \<longrightarrow> (\<not> sF \<sqsupseteq> [parser_bottom G]) = sUF \<sqsupseteq> [parser_bottom G])))"
  apply(clarsimp)
  apply(rename_tac G sF sUF)(*strict*)
  apply(simp add: suffix_closure_def prefix_closure_def prefix_def suffix_def parser_schedulers_def parser_fixed_schedulers_def parser_unfixed_schedulers_def)
  apply(clarsimp)
  apply(rename_tac G sF sUF vb vc c vd ca)(*strict*)
  apply(case_tac sF)
   apply(rename_tac G sF sUF vb vc c vd ca)(*strict*)
   apply(clarsimp)
  apply(rename_tac G sF sUF vb vc c vd ca a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. sF = w' @ [x']")
   apply(rename_tac G sF sUF vb vc c vd ca a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sF sUF vb vc c vd ca a list)(*strict*)
  apply(thin_tac "sF = a # list")
  apply(clarsimp)
  apply(rename_tac G sUF vb vc c vd ca w' x')(*strict*)
  apply(case_tac c)
   apply(rename_tac G sUF vb vc c vd ca w' x')(*strict*)
   apply(clarsimp)
  apply(rename_tac G sUF vb vc c vd ca w' x' a list)(*strict*)
  apply(subgoal_tac "\<exists>w' x'. c = w' @ [x']")
   apply(rename_tac G sUF vb vc c vd ca w' x' a list)(*strict*)
   prefer 2
   apply(rule NonEmptyListHasTailElem)
   apply(force)
  apply(rename_tac G sUF vb vc c vd ca w' x' a list)(*strict*)
  apply(thin_tac "c = a # list")
  apply(clarsimp)
  apply(rename_tac G sUF vb vd ca w' x' w'a)(*strict*)
  apply(metis last_append last_snoc snoc_eq_iff_butlast)
  done

lemma valid_parser_rules_rhs_gets_shorter: "
  valid_parser P
  \<Longrightarrow> e \<in> parser_rules P
  \<Longrightarrow> length (rule_rpush e) \<le> length (rule_rpop e)"
  apply(simp add: valid_parser_def)
  apply(clarsimp)
  apply(erule_tac
      x="e"
      in ballE)
   apply(auto)
  apply(simp add: valid_parser_step_label_def)
  apply(clarsimp)
  apply(rename_tac k w xa)(*strict*)
  apply(rule_tac
      t="kPrefix k (w @ [parser_bottom P])"
      and s="xa @ rule_rpush e"
      in ssubst)
   apply(rename_tac k w xa)(*strict*)
   apply(force)
  apply(rename_tac k w xa)(*strict*)
  apply(simp (no_asm_use))
  done

definition parser_empty_fixed_scheduler :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_fixed_scheduler G \<equiv>
  []"
declare parser_empty_fixed_scheduler_def [simp add]

definition parser_empty_unfixed_scheduler :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_unfixed_scheduler G \<equiv>
  []"
declare parser_empty_unfixed_scheduler_def [simp add]

definition parser_fixed_scheduler_extendable :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list
  \<Rightarrow> bool"
  where
    "parser_fixed_scheduler_extendable G w \<equiv>
  \<not> suffix w [parser_bottom G]"
declare parser_fixed_scheduler_extendable_def [simp add]

definition parser_unfixed_scheduler_extendable :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list
  \<Rightarrow> bool"
  where
    "parser_unfixed_scheduler_extendable G w \<equiv>
  suffix w [parser_bottom G]"
declare parser_unfixed_scheduler_extendable_def [simp add]

definition parser_empty_history :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_history G \<equiv>
  []"
declare parser_empty_history_def [simp add]

definition parser_empty_history_fragment :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_history_fragment G \<equiv>
  []"
declare parser_empty_history_fragment_def [simp add]

definition parser_empty_scheduler :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_scheduler G \<equiv>
  [parser_bottom G]"
declare parser_empty_scheduler_def [simp add]

definition parser_empty_scheduler_fragment :: "
  ('stack, 'event, 'marker) parser
  \<Rightarrow> 'event list"
  where
    "parser_empty_scheduler_fragment G \<equiv>
  []"
declare parser_empty_scheduler_fragment_def [simp add]

lemma parser_inst_ATS_SchedF_Basic_axioms: "
  ATS_SchedF_Basic_axioms valid_parser parser_fixed_schedulers
     parser_empty_fixed_scheduler"
  apply(simp add: ATS_SchedF_Basic_axioms_def)
  apply(simp add: parser_inst_AX_empty_fixed_scheduler_in_fixed_schedulers )
  done

lemma parser_inst_ATS_Scheduler_Fragment_axioms: "
  ATS_Scheduler_Fragment_axioms valid_parser parser_scheduler_fragments
     parser_empty_scheduler_fragment (@)"
  apply(simp add: ATS_Scheduler_Fragment_axioms_def)
  apply(simp add: parser_inst_AX_join_scheduler_fragments_closed parser_inst_AX_join_scheduler_fragments_foldl_split parser_inst_AX_empty_scheduler_fragment_in_scheduler_fragments )
  apply(simp add: parser_inst_AX_foldl_join_scheduler_fragments)
  done

lemma parser_inst_ATS_SchedUF_Basic_axioms: "
  ATS_SchedUF_Basic_axioms valid_parser parser_scheduler_fragments
     parser_empty_scheduler_fragment parser_unfixed_schedulers
     parser_empty_unfixed_scheduler right_quotient_word (@)
     parser_unfixed_scheduler_extendable"
  apply(simp add: ATS_SchedUF_Basic_axioms_def)
  apply(simp add: parser_inst_AX_extend_unfixed_scheduler_preserves_unfixed_scheduler_extendable parser_inst_AX_extend_unfixed_scheduler_unfixed_scheduler_right_quotient_empty parser_inst_AX_unfixed_scheduler_right_quotient_all parser_inst_AX_empty_unfixed_scheduler_in_unfixed_schedulers parser_inst_AX_extend_unfixed_scheduler_closed )
  done

lemma parser_inst_ATS_Sched_Basic_axioms: "
  ATS_Sched_Basic_axioms valid_parser parser_fixed_schedulers
     parser_fixed_scheduler_extendable parser_unfixed_schedulers
     parser_unfixed_scheduler_extendable parser_schedulers (@)"
  apply(simp add: ATS_Sched_Basic_axioms_def)
  apply(simp add: parser_inst_AX_join_fixed_scheduler_unfixed_scheduler_closed )
  done

lemmas parser_interpretations =
  parser_inst_ATS_SchedF_Basic_axioms
  parser_inst_ATS_Sched_Basic_axioms
  parser_inst_ATS_Scheduler_Fragment_axioms
  parser_inst_ATS_SchedUF_Basic_axioms

lemma PARSER_rule_rpop_in_parser_events: "
  valid_parser G
  \<Longrightarrow> e \<in> parser_rules G
  \<Longrightarrow> set (rule_rpop e) \<subseteq> parser_events G"
  apply(simp add: valid_parser_def valid_parser_step_label_def kPrefix_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(erule_tac
      x="e"
      in ballE)
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rename_tac x k w xb)(*strict*)
  apply(simp add: valid_parser_def valid_parser_step_label_def kPrefix_def)
  apply(erule disjE)
   apply(rename_tac x k w xb)(*strict*)
   apply(rule_tac
      A="set w"
      in set_mp)
    apply(rename_tac x k w xb)(*strict*)
    apply(force)
   apply(rename_tac x k w xb)(*strict*)
   apply (metis in_set_takeD)
  apply(rename_tac x k w xb)(*strict*)
  apply(case_tac "k-length w")
   apply(rename_tac x k w xb)(*strict*)
   apply(clarsimp)
  apply(rename_tac x k w xb nat)(*strict*)
  apply(clarsimp)
  done

end