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

section\<open>The Otway-Rees Protocol: The Faulty BAN Version\<close>

theory OtwayRees_Bad imports Public begin

text\<open>The FAULTY version omitting encryption of Nonce NB, as suggested on
page 247 of
  Burrows, Abadi and Needham (1988).  A Logic of Authentication.
  Proc. Royal Soc. 426

This file illustrates the consequences of such errors.  We can still prove
impressive-looking properties such as \<open>Spy_not_see_encrypted_key\<close>, yet
the protocol is open to a middleperson attack.  Attempting to prove some key
lemmas indicates the possibility of this attack.\<close>

inductive_set otway :: "event list set"
  where
   Nil: \<comment> \<open>The empty trace\<close>
        "[] \<in> otway"

 | Fake: \<comment> \<open>The Spy may say anything he can say.  The sender field is correct,
            but agents don't use that information.\<close>
         "[| evsf \<in> otway;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> otway"

 | Reception: \<comment> \<open>A message that has been sent can be received by the
                  intended recipient.\<close>
              "[| evsr \<in> otway;  Says A B X \<in>set evsr |]
               ==> Gets B X # evsr \<in> otway"

 | OR1:  \<comment> \<open>Alice initiates a protocol run\<close>
         "[| evs1 \<in> otway;  Nonce NA \<notin> used evs1 |]
          ==> 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"

 | OR2:  \<comment> \<open>Bob's response to Alice's message.
             This variant of the protocol does NOT encrypt NB.\<close>
         "[| evs2 \<in> otway;  Nonce NB \<notin> used evs2;
             Gets B \<lbrace>Nonce NA, Agent A, Agent B, X\<rbrace> \<in> set evs2 |]
          ==> Says B Server
                  \<lbrace>Nonce NA, Agent A, Agent B, X, Nonce NB,
                    Crypt (shrK B) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>\<rbrace>
                 # evs2 \<in> otway"

 | OR3:  \<comment> \<open>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.\<close>
         "[| 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>,
                    Nonce NB,
                    Crypt (shrK B) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>\<rbrace>
               \<in> set evs3 |]
          ==> 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"

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

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

declare Says_imp_knows_Spy [THEN analz.Inj, 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 "[| B \<noteq> Server; Key K \<notin> used [] |]
      ==> \<exists>NA. \<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!]:
     "[| Gets B X \<in> set evs; evs \<in> otway |] ==> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

subsection\<open>For reasoning about the encrypted portion of messages\<close>

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

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

lemma Oops_parts_knows_Spy:
     "Says Server B \<lbrace>NA, X, Crypt K' \<lbrace>NB,K\<rbrace>\<rbrace> \<in> set evs
      ==> K \<in> parts (knows Spy evs)"
by blast

text\<open>Forwarding lemma: see comments in OtwayRees.thy\<close>
lemmas OR2_parts_knows_Spy =
    OR2_analz_knows_Spy [THEN analz_into_parts]

text\<open>Theorems of the form \<^term>\<open>X \<notin> parts (spies evs)\<close> 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 ==> (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 ==> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

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

subsection\<open>Proofs involving analz\<close>

text\<open>Describes the form of K and NA when the Server sends this message.  Also
  for Oops case.\<close>
lemma Says_Server_message_form:
     "[| Says Server B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         evs \<in> otway |]
      ==> K \<notin> range shrK \<and> (\<exists>i. NA = Nonce i) \<and> (\<exists>j. NB = Nonce j)"
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
done

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

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
  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 ==>
   \<forall>K KK. KK \<subseteq> -(range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (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:
  "[| evs \<in> otway;  KAB \<notin> range shrK |] ==>
      (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:
     "[| 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 |] ==> X=X' \<and> B=B' \<and> NA=NA' \<and> 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

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>\<open>A=Spy\<close>\<close>
lemma secrecy_lemma:
 "[| A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
  ==> 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 \<longrightarrow>
      Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs \<longrightarrow>
      Key K \<notin> analz (knows Spy evs)"
apply (erule otway.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (drule_tac [6] OR4_analz_knows_Spy)
apply (drule_tac [4] OR2_analz_knows_Spy)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes)
apply spy_analz  \<comment> \<open>Fake\<close>
apply (blast dest: unique_session_keys)+  \<comment> \<open>OR3, OR4, Oops\<close>
done

lemma Spy_not_see_encrypted_key:
     "[| 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 |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: Says_Server_message_form secrecy_lemma)

subsection\<open>Attempting to prove stronger properties\<close>

text\<open>Only OR1 can have caused such a part of a message to appear. The premise
  \<^term>\<open>A \<noteq> B\<close> prevents OR2's similar-looking cryptogram from being picked
  up. Original Otway-Rees doesn't need it.\<close>
lemma Crypt_imp_OR1 [rule_format]:
     "[| A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs) \<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 (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

text\<open>Crucial property: If the encrypted message appears, and A has used NA
  to start a run, then it originated with the Server!
  The premise \<^term>\<open>A \<noteq> B\<close> allows use of \<open>Crypt_imp_OR1\<close>\<close>
text\<open>Only it is FALSE.  Somebody could make a fake message to Server
          substituting some other nonce NA' for NB.\<close>
lemma "[| A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
       ==> Crypt (shrK A) \<lbrace>NA, Key K\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
           Says A B \<lbrace>NA, Agent A, Agent B,
                      Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace>
            \<in> set evs \<longrightarrow>
           (\<exists>B 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)
apply blast  \<comment> \<open>Fake\<close>
apply blast  \<comment> \<open>OR1: it cannot be a new Nonce, contradiction.\<close>
txt\<open>OR3 and OR4\<close>
apply (simp_all add: ex_disj_distrib)
 prefer 2 apply (blast intro!: Crypt_imp_OR1)  \<comment> \<open>OR4\<close>
txt\<open>OR3\<close>
apply clarify
(*The hypotheses at this point suggest an attack in which nonce NB is used
  in two different roles:
          Gets Server
           \<lbrace>Nonce NA, Agent Aa, Agent A,
             Crypt (shrK Aa) \<lbrace>Nonce NA, Agent Aa, Agent A\<rbrace>, Nonce NB,
             Crypt (shrK A) \<lbrace>Nonce NA, Agent Aa, Agent A\<rbrace>\<rbrace>
          \<in> set evs3
          Says A B
           \<lbrace>Nonce NB, Agent A, Agent B,
             Crypt (shrK A) \<lbrace>Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
          \<in> set evs3;
*)

(*Thus the key property A_can_trust probably fails too.*)
oops

end


theory Unused
imports CValue  "HOLCF-Meet-Classes" "AList-Utils" Terms
begin

nominal_primrec isLam :: "exp \<Rightarrow> bool" where
  "isLam (Var x) = False" |
  "isLam (Lam [x]. e) = True" |
  "isLam (App e x) = False" |
  "isLam (Let as e) = False"
  unfolding isLam_graph_aux_def eqvt_def
  apply simp
  apply simp
  apply (metis exp_assn.exhaust(1))
  apply auto
  done
termination (eqvt) by lexicographic_order

lemma change_Lam_Variable:
  assumes "atom y' \<sharp> e'" and "atom y' \<sharp> y"
  shows   "Lam [y]. e' =  Lam [y']. ((y \<leftrightarrow> y') \<bullet> e')"
proof-
  from assms
  have "(y \<leftrightarrow> y') \<bullet> (Lam [y]. e') = Lam [y]. e'"
    by -(rule flip_fresh_fresh, (simp add: fresh_Pair)+)
  moreover
  have "(y \<leftrightarrow> y') \<bullet> (Lam [y]. e') = Lam [y']. ((y \<leftrightarrow> y') \<bullet> e')"
    by simp
  ultimately
  show "Lam [y]. e' =  Lam [y']. ((y \<leftrightarrow> y') \<bullet> e')" by (simp add: fresh_Pair)
qed

lemma isLam_subst[simp]: "isLam e[x::=y] = isLam e"
  by (nominal_induct e avoiding: x y rule:exp_assn.strong_induct(1))
     (auto simp add: fresh_star_Pair)

lemma the_map_of_snd:
  "x\<in> domA \<Gamma> \<Longrightarrow> the (map_of \<Gamma> x) \<in> snd ` set \<Gamma>"
  by (induct \<Gamma>, auto)

lemma delete_no_there:
  "x \<notin> domA \<Gamma> \<Longrightarrow> delete x \<Gamma> = \<Gamma>"
  by (induct \<Gamma>, auto)

fixrec CValue'_meet :: "CValue' \<rightarrow> CValue' \<rightarrow> CValue'"
  where "CValue'_meet\<cdot>(CFn\<cdot>f)\<cdot>(CFn\<cdot>g) = CFn \<cdot>(\<Lambda> x r. CValue'_meet \<cdot> (f\<cdot>x\<cdot>r) \<cdot> (g\<cdot>x\<cdot>r))"

lemma CValue'_meet_is_meet: "(z \<sqsubseteq> CValue'_meet\<cdot>x\<cdot>y) = (z \<sqsubseteq> x \<and> z \<sqsubseteq> y)"
proof (induct z rule:CValue'.take_induct)
  fix n
  show "(CValue'_take n\<cdot>z \<sqsubseteq> CValue'_meet\<cdot>x\<cdot>y) = (CValue'_take n\<cdot>z \<sqsubseteq> x \<and> CValue'_take n\<cdot>z \<sqsubseteq> y)"
  proof (induct n arbitrary: z x y rule:nat_induct)
    case 0 thus ?case by auto
    next
    case (Suc n z x y) thus ?case
      apply -
      apply (cases z, simp)
      apply (cases x, simp)
      apply (cases y, simp)
      apply (fastforce simp add: cfun_below_iff)
      done
  qed
qed auto

instance CValue' :: Finite_Meet_cpo
  apply default
  using CValue'_meet_is_meet
  apply blast
  done

instance CValue' :: cont_binary_meet
proof
  have [simp]:"\<And> x y. x \<sqinter> y = CValue'_meet\<cdot>x\<cdot>y"
    using CValue'_meet_is_meet
    by (blast intro: is_meetI)
  case goal1 thus ?case
    by (simp add: ch2ch_Rep_cfunR contlub_cfun_arg contlub_cfun_fun)
qed

subsubsection {* Instance for @{type u} *}

instantiation "u" :: (cont_pt) pt
begin
  definition "p \<bullet> (x :: 'a\<^sub>\<bottom>) = fup\<cdot>(\<Lambda> x. up\<cdot>(p \<bullet> x))\<cdot>x"

  instance
  apply(default)
  apply (simp add: permute_u_def eta_cfun)
  apply (case_tac x)
  apply (simp add: permute_u_def cfun_eqI minus_add)
  apply (simp add: permute_u_def cfun_eqI minus_add)
  done
end

lemma permute_u_eq: "permute p = (\<lambda> u. fup\<cdot>(\<Lambda> x. up\<cdot>(p \<bullet> x))\<cdot>u)"
  by (rule, auto simp add: permute_u_def)

instance "u" :: (cont_pt) cont_pt
  by default (subst permute_u_eq, simp)

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Late_Comp
  imports Weak_Early_Cong Weak_Late_Cong Strong_Early_Late_Comp
begin

(*************** Transitions *********************)

abbreviation earlyTauChain_judge ("_ \<Longrightarrow>\<^sub>\<tau>\<^sub>e _" [80, 80] 80) where "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e Q \<equiv> Early_Tau_Chain.tauChain P Q"
abbreviation lateTauChain_judge ("_ \<Longrightarrow>\<^sub>\<tau>\<^sub>l _" [80, 80] 80) where "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l Q \<equiv> Late_Tau_Chain.tauChain_judge P Q"

(************** Tau Chains *******************)

lemma lateEarlyTauChain:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l Q"

  shows "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e Q"
using assms
proof(induct rule: Late_Tau_Chain.tauChainInduct)
  case id
  show ?case by simp
next
  case(ih P' P'')
  have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'" by fact
  moreover have "P' \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P''"
  proof -
    have "P' \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P''" by fact
    thus ?thesis by(rule lateEarlyTau)
  qed
  ultimately show ?case by blast
qed

lemma earlyLateTauChain:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e Q"

  shows "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l Q"
using assms
proof(induct rule: Early_Tau_Chain.tauChainInduct)
  case id
  show ?case by simp
next
  case(ih P' P'')
  have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'" by fact
  moreover have "P' \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P''"
  proof -
    have "P' \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P''" by fact
    thus ?thesis by(rule earlyLateTau)
  qed
  ultimately show ?case by blast
qed

lemma tauChainEq:
  fixes P :: pi
  and   Q :: pi

  shows "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l Q = P \<Longrightarrow>\<^sub>\<tau>\<^sub>e Q"
by(blast intro: lateEarlyTauChain earlyLateTauChain)

(***************** Step semantics ****************)

lemma lateEarlyStepOutput:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>l(a[b] \<prec>\<^sub>l P')"

  shows "P \<Longrightarrow>\<^sub>e(a[b] \<prec>\<^sub>e P')"
proof -
  from assms obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''"
                               and P'''Trans: "P''' \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P''"
                               and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'"
    by(blast dest: Weak_Late_Step_Semantics.transitionE)

  from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''" by(rule lateEarlyTauChain)
  moreover from P'''Trans have "P''' \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P''" by(rule lateEarlyOutput)
  moreover from P''Chain have "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'" by(rule lateEarlyTauChain)
  ultimately show ?thesis by(rule Weak_Early_Step_Semantics.transitionI)
qed

lemma earlyLateStepOutput:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>e(a[b] \<prec>\<^sub>e P')"

  shows "P \<Longrightarrow>\<^sub>l(a[b] \<prec>\<^sub>l P')"
proof -
  from assms obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''"
                               and P'''Trans: "P''' \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e P''"
                               and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'"
    by(blast dest: Weak_Early_Step_Semantics.transitionE)

  from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''" by(rule earlyLateTauChain)
  moreover from P'''Trans have "P''' \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l P''" by(rule earlyLateOutput)
  moreover from P''Chain have "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'" by(rule earlyLateTauChain)
  ultimately show ?thesis by(rule Weak_Late_Step_Semantics.transitionI)
qed

lemma stepOutputEq:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  shows "P \<Longrightarrow>\<^sub>e(a[b] \<prec>\<^sub>e P') = P \<Longrightarrow>\<^sub>l(a[b] \<prec>\<^sub>l P')"
by(auto intro: lateEarlyStepOutput earlyLateStepOutput)

lemma lateEarlyStepBoundOutput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')"

  shows "P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P')"
proof -
  have Goal: "\<And>P a x P'. \<lbrakk>P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P'); x \<sharp> P\<rbrakk> \<Longrightarrow> P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P')"
  proof -
    fix P a x P'
    assume "P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')" and "x \<sharp> P"
    then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''"
                           and P'''Trans: "P''' \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P''"
                           and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'"
      by(blast dest: Weak_Late_Step_Semantics.transitionE)

    from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''" by(rule lateEarlyTauChain)
    moreover from P'''Trans have "P''' \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P''" by(rule lateEarlyBoundOutput)
    moreover from P''Chain have "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'" by(rule lateEarlyTauChain)
    ultimately show "P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P')" by(rule Weak_Early_Step_Semantics.transitionI)
  qed
  have "\<exists>c::name. c \<sharp> (P, P')" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshP': "c \<sharp> P'"
    by(force simp add: fresh_prod)
  from assms cFreshP' have "P \<Longrightarrow>\<^sub>la<\<nu>c> \<prec>\<^sub>l ([(x, c)] \<bullet> P')" by(simp add: alphaBoundResidual)
  hence "P \<Longrightarrow>\<^sub>ea<\<nu>c> \<prec>\<^sub>e ([(x, c)] \<bullet> P')" using cFreshP by(rule Goal)
  with cFreshP' show ?thesis by(simp add: alphaBoundOutput)
qed

lemma earlyLateStepBoundOutput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P')"

  shows "P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')"
proof -
  have Goal: "\<And>P a x P'. \<lbrakk>P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P'); x \<sharp> P\<rbrakk> \<Longrightarrow> P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')"
  proof -
    fix P a x P'
    assume "P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P')" and "x \<sharp> P"
    then obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''"
                           and P'''Trans: "P''' \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P''"
                           and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'"
      by(blast dest: Weak_Early_Step_Semantics.transitionE)

    from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''" by(rule earlyLateTauChain)
    moreover from P'''Trans have "P''' \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l P''" by(rule earlyLateBoundOutput)
    moreover from P''Chain have "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'" by(rule earlyLateTauChain)
    ultimately show "P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')" by(rule Weak_Late_Step_Semantics.transitionI)
  qed
  have "\<exists>c::name. c \<sharp> (P, P')" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshP': "c \<sharp> P'"
    by(force simp add: fresh_prod)
  from assms cFreshP' have "P \<Longrightarrow>\<^sub>ea<\<nu>c> \<prec>\<^sub>e ([(x, c)] \<bullet> P')" by(simp add: alphaBoundOutput)
  hence "P \<Longrightarrow>\<^sub>la<\<nu>c> \<prec>\<^sub>l ([(x, c)] \<bullet> P')" using cFreshP by(rule Goal)
  with cFreshP' show ?thesis by(simp add: alphaBoundResidual)
qed

lemma stepBoundOutputEq:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  shows "P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P') = P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')"
by(auto intro: lateEarlyStepBoundOutput earlyLateStepBoundOutput)

lemma earlyLateStepInput:
  fixes P  :: pi
  and   a  :: name
  and   u  :: name
  and   P' :: pi
  and   C  :: "'a::fs_name"

  assumes "P \<Longrightarrow>\<^sub>e(a<u> \<prec>\<^sub>e P')"

  shows "\<exists>P'' x. P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow>a<x> \<prec> P' \<and> x \<sharp> C"
proof -
  from assms obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''"
                              and P'''Trans: "P''' \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P''"
                              and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'"
    by(blast dest: Weak_Early_Step_Semantics.transitionE)

  from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''" by(rule earlyLateTauChain)
  moreover from P'''Trans obtain P'''' x where P'''Trans: "P''' \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l P''''"
                                           and P''eqP'''': "P'' = P''''[x::=u]"
                                           and xFreshC: "x \<sharp> C"
    by(blast dest: earlyLateInput)
  moreover from P''Chain have "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'" by(rule earlyLateTauChain)
  ultimately show "\<exists>P'' x. P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P' \<and> x \<sharp> C"
    by(blast intro: Weak_Late_Step_Semantics.transitionI)
qed

lemma lateEarlyStepInput:
  fixes P   :: pi
  and   u   :: name
  and   P'' :: pi
  and   a   :: name
  and   x   :: name
  and   P'  :: pi

  assumes "P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P'"

  shows "P \<Longrightarrow>\<^sub>e(a<u> \<prec>\<^sub>e P')"
proof -
  from assms obtain P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''"
                           and P'''Trans: "P''' \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l P''"
                           and P''Chain: "P''[x::=u] \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'"
    by(blast dest: Weak_Late_Step_Semantics.transitionE)

  from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''" by(rule lateEarlyTauChain)
  moreover from P'''Trans have "P''' \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e P''[x::=u]" by(rule lateEarlyInput)
  moreover from P''Chain have "P''[x::=u] \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'" by(rule lateEarlyTauChain)
  ultimately show "P \<Longrightarrow>\<^sub>e(a<u> \<prec>\<^sub>e P')" by(rule Weak_Early_Step_Semantics.transitionI)
qed

lemma lateEarlyStepTau:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>l(\<tau> \<prec>\<^sub>l P')"

  shows "P \<Longrightarrow>\<^sub>e(\<tau> \<prec>\<^sub>e P')"
proof -
  from assms obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''"
                               and P'''Trans: "P''' \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P''"
                               and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'"
    by(blast dest: Weak_Late_Step_Semantics.transitionE)

  from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''" by(rule lateEarlyTauChain)
  moreover from P'''Trans have "P''' \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P''" by(rule lateEarlyTau)
  moreover from P''Chain have "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'" by(rule lateEarlyTauChain)
  ultimately show ?thesis by(rule Weak_Early_Step_Semantics.transitionI)
qed

lemma earlyLateStepTau:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>e(\<tau> \<prec>\<^sub>e P')"

  shows "P \<Longrightarrow>\<^sub>l(\<tau> \<prec>\<^sub>l P')"
proof -
  from assms obtain P'' P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'''"
                               and P'''Trans: "P''' \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e P''"
                               and P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>e P'"
    by(blast dest: Weak_Early_Step_Semantics.transitionE)

  from PChain have "P \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'''" by(rule earlyLateTauChain)
  moreover from P'''Trans have "P''' \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l P''" by(rule earlyLateTau)
  moreover from P''Chain have "P'' \<Longrightarrow>\<^sub>\<tau>\<^sub>l P'" by(rule earlyLateTauChain)
  ultimately show ?thesis by(rule Weak_Late_Step_Semantics.transitionI)
qed

lemma stepTauEq:
  fixes P  :: pi
  and   P' :: pi

  shows "P \<Longrightarrow>\<^sub>e\<tau> \<prec>\<^sub>e P' = P \<Longrightarrow>\<^sub>l\<tau> \<prec>\<^sub>l P'"
by(blast intro: earlyLateStepTau lateEarlyStepTau)

(****************** Weak Semantics *************)

lemma lateEarlyOutput:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>l\<^sup>^(a[b] \<prec>\<^sub>l P')"

  shows "P \<Longrightarrow>\<^sub>e\<^sup>^(a[b] \<prec>\<^sub>e P')"
proof -
  from assms have "P \<Longrightarrow>\<^sub>l(a[b] \<prec>\<^sub>l P')"
    by(simp add: Weak_Late_Semantics.weakTransition_def Late_Semantics.residual.inject)
  hence "P \<Longrightarrow>\<^sub>e(a[b] \<prec>\<^sub>e P')" by(rule lateEarlyStepOutput)
  thus ?thesis
    by(simp add: Weak_Early_Semantics.weakTransition_def Early_Semantics.residual.inject)
qed

lemma earlyLateOutput:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>e\<^sup>^(a[b] \<prec>\<^sub>e P')"

  shows "P \<Longrightarrow>\<^sub>l\<^sup>^(a[b] \<prec>\<^sub>l P')"
proof -
  from assms have "P \<Longrightarrow>\<^sub>e(a[b] \<prec>\<^sub>e P')"
    by(simp add: Weak_Early_Semantics.weakTransition_def Early_Semantics.residual.inject)
  hence "P \<Longrightarrow>\<^sub>l(a[b] \<prec>\<^sub>l P')" by(rule earlyLateStepOutput)
  thus ?thesis
    by(simp add: Weak_Late_Semantics.weakTransition_def Late_Semantics.residual.inject)
qed

lemma outputEq:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  shows "P \<Longrightarrow>\<^sub>e\<^sup>^(a[b] \<prec>\<^sub>e P') = P \<Longrightarrow>\<^sub>l\<^sup>^(a[b] \<prec>\<^sub>l P')"
by(auto intro: lateEarlyOutput earlyLateOutput)

lemma lateEarlyBoundOutput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>l\<^sup>^(a<\<nu>x> \<prec>\<^sub>l P')"

  shows "P \<Longrightarrow>\<^sub>e\<^sup>^(a<\<nu>x> \<prec>\<^sub>e P')"
proof -
  from assms have "P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')"
    by(simp add: Weak_Late_Semantics.weakTransition_def Late_Semantics.residual.inject)
  hence "P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P')" by(rule lateEarlyStepBoundOutput)
  thus ?thesis
    by(simp add: Weak_Early_Semantics.weakTransition_def Early_Semantics.residual.inject)
qed

lemma earlyLateBoundOutput:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>e\<^sup>^(a<\<nu>x> \<prec>\<^sub>e P')"

  shows "P \<Longrightarrow>\<^sub>l\<^sup>^(a<\<nu>x> \<prec>\<^sub>l P')"
proof -
  from assms have "P \<Longrightarrow>\<^sub>e(a<\<nu>x> \<prec>\<^sub>e P')"
    by(simp add: Weak_Early_Semantics.weakTransition_def Early_Semantics.residual.inject)
  hence "P \<Longrightarrow>\<^sub>l(a<\<nu>x> \<prec>\<^sub>l P')" by(rule earlyLateStepBoundOutput)
  thus ?thesis
    by(simp add: Weak_Late_Semantics.weakTransition_def Late_Semantics.residual.inject)
qed

lemma boundOutputEq:
  fixes P  :: pi
  and   a  :: name
  and   b  :: name
  and   P' :: pi

  shows "P \<Longrightarrow>\<^sub>e\<^sup>^(a<\<nu>x> \<prec>\<^sub>e P') = P \<Longrightarrow>\<^sub>l\<^sup>^(a<\<nu>x> \<prec>\<^sub>l P')"
by(auto intro: lateEarlyBoundOutput earlyLateBoundOutput)

lemma earlyLateInput:
  fixes P  :: pi
  and   a  :: name
  and   u  :: name
  and   P' :: pi
  and   C  :: "'a::fs_name"

  assumes "P \<Longrightarrow>\<^sub>e\<^sup>^(a<u> \<prec>\<^sub>e P')"

  shows "\<exists>P'' x. P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow>a<x> \<prec> P' \<and> x \<sharp> C"
proof -
  from assms have "P \<Longrightarrow>\<^sub>e(a<u> \<prec>\<^sub>e P')"
    by(simp add: Weak_Early_Semantics.weakTransition_def Early_Semantics.residual.inject)
  thus ?thesis by(rule earlyLateStepInput)
qed

lemma lateEarlyInput:
  fixes P   :: pi
  and   u   :: name
  and   P'' :: pi
  and   a   :: name
  and   x   :: name
  and   P'  :: pi

  assumes "P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P'"

  shows "P \<Longrightarrow>\<^sub>e\<^sup>^(a<u> \<prec>\<^sub>e P')"
proof -
  from assms have "P \<Longrightarrow>\<^sub>e(a<u> \<prec>\<^sub>e P')" by(rule lateEarlyStepInput)
  thus ?thesis by(simp add: Weak_Early_Semantics.weakTransition_def Early_Semantics.residual.inject)
qed

lemma lateEarlyTau:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>l\<^sup>^(\<tau> \<prec>\<^sub>l P')"

  shows "P \<Longrightarrow>\<^sub>e\<^sup>^(\<tau> \<prec>\<^sub>e P')"
proof -
  from assms show ?thesis
  proof(induct rule: Weak_Late_Semantics.transitionCases)
    case Stay
    thus ?case
      by(auto simp add: Late_Semantics.residual.inject Weak_Early_Semantics.weakTransition_def)
  next
    case Step
    have "P \<Longrightarrow>\<^sub>l\<tau> \<prec>\<^sub>l P'" by fact
    hence "P \<Longrightarrow>\<^sub>e\<tau> \<prec>\<^sub>e P'" by(rule lateEarlyStepTau)
    thus ?case by(simp add: Weak_Early_Semantics.weakTransition_def)
  qed
qed

lemma earlyLateTau:
  fixes P  :: pi
  and   P' :: pi

  assumes "P \<Longrightarrow>\<^sub>e\<^sup>^(\<tau> \<prec>\<^sub>e P')"

  shows "P \<Longrightarrow>\<^sub>l\<^sup>^(\<tau> \<prec>\<^sub>l P')"
proof -
  from assms show ?thesis
  proof(induct rule: Weak_Early_Semantics.transitionCases)
    case Stay
    thus ?case
      by(auto simp add: Early_Semantics.residual.inject Weak_Late_Semantics.weakTransition_def)
  next
    case Step
    have "P \<Longrightarrow>\<^sub>e\<tau> \<prec>\<^sub>e P'" by fact
    hence "P \<Longrightarrow>\<^sub>l\<tau> \<prec>\<^sub>l P'" by(rule earlyLateStepTau)
    thus ?case by(simp add: Weak_Late_Semantics.weakTransition_def)
  qed
qed

lemma tauEq:
  fixes P  :: pi
  and   P' :: pi

  shows "P \<Longrightarrow>\<^sub>e\<^sup>^\<tau> \<prec>\<^sub>e P' = P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec>\<^sub>l P'"
by(blast intro: earlyLateTau lateEarlyTau)

(****************** Weak Simulation ******************)

abbreviation weakSimStepLate_judge ("_ \<leadsto>\<^sub>l<_> _" [80, 80, 80] 80) where "P \<leadsto>\<^sub>l<Rel> Q \<equiv> Weak_Late_Step_Sim.weakStepSim P Rel Q"
abbreviation weakSimStepEarly_judge ("_ \<leadsto>\<^sub>e<_> _" [80, 80, 80] 80) where "P \<leadsto>\<^sub>e<Rel> Q \<equiv> Weak_Early_Step_Sim.weakStepSimulation P Rel Q"
abbreviation weakSimLate_judge ("_ \<leadsto>\<^sub>l\<^sup>^<_> _" [80, 80, 80] 80) where "P \<leadsto>\<^sub>l\<^sup>^<Rel> Q \<equiv> Weak_Late_Sim.weakSimulation P Rel Q"
abbreviation weakSimEarly_judge ("_ \<leadsto>\<^sub>e\<^sup>^<_> _" [80, 80, 80] 80) where "P \<leadsto>\<^sub>e\<^sup>^<Rel> Q \<equiv> Weak_Early_Sim.weakSimulation P Rel Q"

lemma lateEarlyStepSim:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto>\<^sub>l<Rel> Q"

  shows "P \<leadsto>\<^sub>e<Rel> Q"
proof(induct rule: Weak_Early_Step_Sim.simCases)
  case(Bound Q' a x)
  have "Q \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e Q'" by fact
  hence "Q \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l Q'" by(rule Strong_Early_Late_Comp.earlyLateBoundOutput)
  moreover have "x \<sharp> P" by fact
  ultimately obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la<\<nu>x> \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel" using PSimQ
    by(blast dest: Weak_Late_Step_Sim.simE)
  from PTrans have "P \<Longrightarrow>\<^sub>ea<\<nu>x> \<prec>\<^sub>e P'" by(rule lateEarlyStepBoundOutput)
  with P'RelQ' show ?case by blast
next
  case(Free Q' \<alpha>)
  have "Q \<longmapsto>\<^sub>e Early_Semantics.residual.FreeR \<alpha> Q'" by fact
  thus ?case
  proof(cases \<alpha>, auto)
    fix a u
    assume "Q \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e Q'"
    then obtain Q'' x where QTrans: "Q \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l Q''" and Q'eqQ'': "Q' = Q''[x::=u]"
                        and xFreshP: "x \<sharp> P"
      by(blast dest: Strong_Early_Late_Comp.earlyLateInput[of _ _ _ _ P])
    from PSimQ QTrans xFreshP obtain P' P'' where PTrans: "P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P'"
                                              and P'RelQ': "(P', Q''[x::=u]) \<in> Rel"
      by(blast dest: Weak_Late_Step_Sim.simE)
    from PTrans have "P \<Longrightarrow>\<^sub>ea<u> \<prec>\<^sub>e P'" by(rule lateEarlyStepInput)
    with P'RelQ' Q'eqQ'' show "\<exists>P'. P \<Longrightarrow>\<^sub>ea<u> \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel" by blast
  next
    fix a b
    assume "Q \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e Q'"
    hence "Q \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l Q'" by(rule Strong_Early_Late_Comp.earlyLateOutput)
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>la[b] \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: Weak_Late_Step_Sim.simE)
    from PTrans have "P \<Longrightarrow>\<^sub>ea[b] \<prec>\<^sub>e P'" by(rule lateEarlyStepOutput)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>ea[b] \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel"  by blast
  next
    assume "Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e Q'"
    hence "Q \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l Q'" by(rule Strong_Early_Late_Comp.earlyLateTau)
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<tau> \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: Weak_Late_Step_Sim.simE)
    from PTrans have "P \<Longrightarrow>\<^sub>e\<tau> \<prec>\<^sub>e P'" by(rule lateEarlyStepTau)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>e\<tau> \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel"  by blast
  qed
qed

lemma lateEarlySim:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto>\<^sub>l\<^sup>^<Rel> Q"

  shows "P \<leadsto>\<^sub>e\<^sup>^<Rel> Q"
proof(induct rule: Weak_Early_Sim.simCases)
  case(Bound Q' a x)
  have "Q \<longmapsto>\<^sub>ea<\<nu>x> \<prec>\<^sub>e Q'" by fact
  hence "Q \<longmapsto>\<^sub>la<\<nu>x> \<prec>\<^sub>l Q'" by(rule Strong_Early_Late_Comp.earlyLateBoundOutput)
  moreover have "x \<sharp> P" by fact
  ultimately obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel" using PSimQ
    by(blast dest: Weak_Late_Sim.simE)
  from PTrans have "P \<Longrightarrow>\<^sub>e\<^sup>^a<\<nu>x> \<prec>\<^sub>e P'" by(rule lateEarlyBoundOutput)
  with P'RelQ' show ?case by blast
next
  case(Free Q' \<alpha>)
  have "Q \<longmapsto>\<^sub>e Early_Semantics.residual.FreeR \<alpha> Q'" by fact
  thus ?case
  proof(cases \<alpha>, auto)
    fix a u
    assume "Q \<longmapsto>\<^sub>ea<u> \<prec>\<^sub>e Q'"
    then obtain Q'' x where QTrans: "Q \<longmapsto>\<^sub>la<x> \<prec>\<^sub>l Q''" and Q'eqQ'': "Q' = Q''[x::=u]"
                        and xFreshP: "x \<sharp> P"
      by(blast dest: Strong_Early_Late_Comp.earlyLateInput[of _ _ _ _ P])
    from PSimQ QTrans xFreshP obtain P' P'' where PTrans: "P \<Longrightarrow>\<^sub>lu in P'' \<rightarrow> a<x> \<prec> P'"
                                              and P'RelQ': "(P', Q''[x::=u]) \<in> Rel"
      by(blast dest: Weak_Late_Sim.simE)
    from PTrans have "P \<Longrightarrow>\<^sub>e\<^sup>^a<u> \<prec>\<^sub>e P'" by(rule lateEarlyInput)
    with P'RelQ' Q'eqQ'' show "\<exists>P'. P \<Longrightarrow>\<^sub>e\<^sup>^a<u> \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel" by blast
  next
    fix a b
    assume "Q \<longmapsto>\<^sub>ea[b] \<prec>\<^sub>e Q'"
    hence "Q \<longmapsto>\<^sub>la[b] \<prec>\<^sub>l Q'" by(rule Strong_Early_Late_Comp.earlyLateOutput)
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a[b] \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: Weak_Late_Sim.simE)
    from PTrans have "P \<Longrightarrow>\<^sub>e\<^sup>^a[b] \<prec>\<^sub>e P'" by(rule lateEarlyOutput)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>e\<^sup>^a[b] \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel"  by blast
  next
    assume "Q \<longmapsto>\<^sub>e\<tau> \<prec>\<^sub>e Q'"
    hence "Q \<longmapsto>\<^sub>l\<tau> \<prec>\<^sub>l Q'" by(rule Strong_Early_Late_Comp.earlyLateTau)
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec>\<^sub>l P'" and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: Weak_Late_Sim.simE)
    from PTrans have "P \<Longrightarrow>\<^sub>e\<^sup>^\<tau> \<prec>\<^sub>e P'" by(rule lateEarlyTau)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>e\<^sup>^\<tau> \<prec>\<^sub>e P' \<and> (P', Q') \<in> Rel"  by blast
  qed
qed

(*************** Bisimulation ***************)

abbreviation weakBisimLate_judge (infixl "\<approx>\<^sub>l" 80) where "P \<approx>\<^sub>l Q \<equiv> (P, Q) \<in> Weak_Late_Bisim.weakBisim"
abbreviation weakBisimEarly_judge (infixl "\<approx>\<^sub>e" 80) where "P \<approx>\<^sub>e Q \<equiv> (P, Q) \<in> Weak_Early_Bisim.weakBisim"
abbreviation weakCongLate_judge (infixl "\<simeq>\<^sub>l" 80) where "P \<simeq>\<^sub>l Q \<equiv> (P, Q) \<in> Weak_Late_Cong.congruence"
abbreviation weakCongEarly_judge (infixl "\<simeq>\<^sub>e" 80) where "P \<simeq>\<^sub>e Q \<equiv> (P, Q) \<in> Weak_Early_Cong.congruence"

lemma lateEarlyBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sub>l Q"

  shows "P \<approx>\<^sub>e Q"
proof -
  from assms show ?thesis
  by(coinduct rule: Weak_Early_Bisim.weak_coinduct,
     auto dest: Weak_Late_Bisim.unfoldE intro: lateEarlySim)
qed

lemma lateEarlyCong:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sub>l Q"

  shows "P \<simeq>\<^sub>e Q"
proof -
  from lateEarlyBisim have "\<And>P Q. P \<leadsto>\<^sub>l<(Weak_Late_Bisim.weakBisim)> Q \<Longrightarrow> P \<leadsto>\<^sub>l<(Weak_Early_Bisim.weakBisim)> Q"
    by(auto intro: Weak_Late_Step_Sim.monotonic)
  with assms show ?thesis
    by(auto simp add: Weak_Late_Cong.congruence_def Weak_Early_Cong.congruence_def intro: lateEarlyStepSim)
qed

abbreviation weakLateBisimSubst_judge (infixl "\<approx>\<^sup>s\<^sub>l" 80) where "P \<approx>\<^sup>s\<^sub>l Q \<equiv> (P, Q) \<in> (substClosed Weak_Late_Bisim.weakBisim)"
abbreviation weakEarlyBisimSubst_judge (infixl "\<approx>\<^sup>s\<^sub>e" 80) where "P \<approx>\<^sup>s\<^sub>e Q \<equiv> (P, Q) \<in> (substClosed Weak_Early_Bisim.weakBisim)"

abbreviation weakLateCongSubst_judge (infixl "\<simeq>\<^sup>s\<^sub>l" 80) where "P \<simeq>\<^sup>s\<^sub>l Q \<equiv> (P, Q) \<in> (substClosed Weak_Late_Cong.congruence)"
abbreviation weakEarlyTongSubst_judge (infixl "\<simeq>\<^sup>s\<^sub>e" 80) where "P \<simeq>\<^sup>s\<^sub>e Q \<equiv> (P, Q) \<in> (substClosed Weak_Early_Cong.congruence)"

lemma lateEarlyBisimSubst:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx>\<^sup>s\<^sub>l Q"

  shows "P \<approx>\<^sup>s\<^sub>e Q"
using assms
by(auto simp add: substClosed_def intro: lateEarlyBisim)

lemma lateEarlyBisimSubst:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s\<^sub>l Q"

  shows "P \<simeq>\<^sup>s\<^sub>e Q"
using assms
by(auto simp add: substClosed_def intro: lateEarlyCong)

end


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

(* License: BSD, terms see file ./LICENSE *)

theory Addr_Type
imports "~~/src/HOL/Word/Word"
begin

type_synonym addr_bitsize = "64"
type_synonym addr = "addr_bitsize word"
definition addr_bitsize :: nat where "addr_bitsize \<equiv> 64"
definition addr_align :: nat where "addr_align \<equiv> 3"
declare addr_align_def[simp]

definition addr_card :: nat where
  "addr_card \<equiv> card (UNIV::addr set)"

declare addr_bitsize_def[simp]

lemma addr_card:
  "addr_card = 2^addr_bitsize"
  by (simp add: addr_card_def card_word)

lemma len_of_addr_card:
  "2 ^ len_of TYPE(addr_bitsize) = addr_card"
  by (simp add: addr_card)

lemma of_nat_addr_card [simp]:
  "of_nat addr_card = (0::addr)"
  by (simp add: addr_card)

end


(*  Title:      Native_Cast.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* Conversions between unsigned words and between char *}

theory Native_Cast imports
  "HOL-Library.Code_Char"
  Uint8
  Uint16
  Uint32
  Uint64
begin

text {* Auxiliary stuff *}

context includes lifting_syntax
begin

lemma char_of_integer_transfer [transfer_rule]:
  "(pcr_integer ===> op =) (\<lambda>n. char_of_nat (nat n)) char_of_integer"
by(simp add: integer.pcr_cr_eq cr_integer_def rel_fun_def char_of_integer_def nat_of_integer_def)

lemma integer_of_char_transfer [transfer_rule]:
  "(op = ===> pcr_integer) (\<lambda>n. int (nat_of_char n)) integer_of_char"
by(simp add: integer.pcr_cr_eq cr_integer_def rel_fun_def integer_of_char_def)

end

lemma integer_of_char_char_of_integer [simp]:
  "0 \<le> x \<Longrightarrow> integer_of_char (char_of_integer x) = x mod 256"
unfolding integer_of_char_def char_of_integer_def o_apply nat_of_char_of_nat
including integer.lifting by transfer(auto dest: nat_mod_distrib[of _ 256, symmetric])

lemma char_of_integer_integer_of_char [simp]:
  "char_of_integer (integer_of_char x) = x"
by(simp add: integer_of_char_def char_of_integer_def)

lemma int_lt_numeral [simp]: "int x < numeral n \<longleftrightarrow> x < numeral n"
by (metis nat_numeral zless_nat_eq_int_zless)

lemma int_of_integer_ge_0: "0 \<le> int_of_integer x \<longleftrightarrow> 0 \<le> x"
including integer.lifting by transfer simp

lemma integer_of_char_ge_0 [simp]: "0 \<le> integer_of_char x"
including integer.lifting by transfer simp

section {* Conversions between @{typ uint8} and @{typ char} *}

definition uint8_of_char :: "char \<Rightarrow> uint8"
where "uint8_of_char = Uint8 \<circ> integer_of_char"

definition char_of_uint8 :: "uint8 \<Rightarrow> char"
where "char_of_uint8 = char_of_integer \<circ> integer_of_int \<circ> uint \<circ> Rep_uint8'"

lemma uint8_of_char_char_of_uint8 [simp]:
  "uint8_of_char (char_of_uint8 x) = x"
apply(simp add: uint8_of_char_def char_of_uint8_def)
including integer.lifting apply transfer
apply(simp add: mod_pos_pos_trivial uint_bounded[where ?'a=8, simplified])
done

lemma char_of_uint8_uint8_of_char [simp]:
  "char_of_uint8 (uint8_of_char x) = x"
proof -
  have "char_of_uint8 (uint8_of_char x) =
    char_of_integer (of_int (int_of_integer (integer_of_char x) mod 256))"
    by(simp add: uint8_of_char_def char_of_uint8_def Uint8.rep_eq uint_word_of_int)
  also { have "int_of_integer (integer_of_char x) < 256"
      including integer.lifting by transfer(simp add: nat_of_char_less_256) }
  hence "\<dots> = x"
    by(simp add: semiring_numeral_div_class.mod_less int_of_integer_ge_0)
  finally show ?thesis .
qed

code_printing code_module Native_Casts \<rightharpoonup> (Haskell)
{*import qualified Data.Char;

ord :: Char -> Int;
ord = Data.Char.ord;

chr :: Int -> Char;
chr = Data.Char.chr;
*}
code_reserved Haskell Native_Casts

code_printing constant uint8_of_char \<rightharpoonup>
  (SML) "Word8.fromInt (Char.ord _)" and
  (Haskell) "(Prelude.fromIntegral (Native'_Casts.ord _) :: Uint8.Word8)" and
  (Scala) "_.toByte"
| constant char_of_uint8 \<rightharpoonup>
  (SML) "Char.chr (Word8.toInt _)" and
  (Haskell) "Native'_Casts.chr (Prelude.fromIntegral _)" and
  (Scala) "((_).toInt & 0xFF).toChar"

section {* Conversion between native words *}

lift_definition uint8_of_uint16 :: "uint16 \<Rightarrow> uint8" is ucast .
lift_definition uint8_of_uint32 :: "uint32 \<Rightarrow> uint8" is ucast .
lift_definition uint8_of_uint64 :: "uint64 \<Rightarrow> uint8" is ucast .

lift_definition uint16_of_uint8 :: "uint8 \<Rightarrow> uint16" is ucast .
lift_definition uint16_of_uint32 :: "uint32 \<Rightarrow> uint16" is ucast .
lift_definition uint16_of_uint64 :: "uint64 \<Rightarrow> uint16" is ucast .

lift_definition uint32_of_uint8 :: "uint8 \<Rightarrow> uint32" is ucast .
lift_definition uint32_of_uint16 :: "uint16 \<Rightarrow> uint32" is ucast .
lift_definition uint32_of_uint64 :: "uint64 \<Rightarrow> uint32" is ucast .

lift_definition uint64_of_uint8 :: "uint8 \<Rightarrow> uint64" is ucast .
lift_definition uint64_of_uint16 :: "uint16 \<Rightarrow> uint64" is ucast .
lift_definition uint64_of_uint32 :: "uint32 \<Rightarrow> uint64" is ucast .

definition mask where "mask = (0xFFFFFFFF :: integer)"
export_code mask in OCaml

code_printing
  constant uint8_of_uint16 \<rightharpoonup>
  (SML_word) "Word8.fromLarge (Word16.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint8.Word8)" and
  (Scala) "_.toByte"
| constant uint8_of_uint32 \<rightharpoonup>
  (SML) "Word8.fromLarge (Word32.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint8.Word8)" and
  (Scala) "_.toByte"
| constant uint8_of_uint64 \<rightharpoonup>
  (SML) "Word8.fromLarge (Uint64.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint8.Word8)" and
  (Scala) "_.toByte"
| constant uint16_of_uint8 \<rightharpoonup>
  (SML_word) "Word16.fromLarge (Word8.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint16.Word16)" and
  (Scala) "((_).toInt & 0xFF).toChar"
| constant uint16_of_uint32 \<rightharpoonup>
  (SML_word) "Word16.fromLarge (Word32.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint16.Word16)" and
  (Scala) "_.toChar"
| constant uint16_of_uint64 \<rightharpoonup>
  (SML_word) "Word16.fromLarge (Uint64.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint16.Word16)" and
  (Scala) "_.toChar"
| constant uint32_of_uint8 \<rightharpoonup>
  (SML) "Word32.fromLarge (Word8.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint32.Word32)" and
  (Scala) "((_).toInt & 0xFF)"
| constant uint32_of_uint16 \<rightharpoonup>
  (SML_word) "Word32.fromLarge (Word16.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint32.Word32)" and
  (Scala) "(_).toInt"
| constant uint32_of_uint64 \<rightharpoonup>
  (SML_word) "Word32.fromLarge (Uint64.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint32.Word32)" and
  (Scala) "(_).toInt" and
  (OCaml) "Int64.to'_int32"
| constant uint64_of_uint8 \<rightharpoonup>
  (SML_word) "Word64.fromLarge (Word8.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint64.Word64)" and
  (Scala) "((_).toLong & 0xFF)"
| constant uint64_of_uint16 \<rightharpoonup>
  (SML_word) "Word64.fromLarge (Word16.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint64.Word64)" and
  (Scala) "_.toLong"
| constant uint64_of_uint32 \<rightharpoonup>
  (SML_word) "Word64.fromLarge (Word32.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint64.Word64)" and
  (Scala) "((_).toLong & 0xFFFFFFFFL)" and
  (OCaml) "Int64.logand (Int64.of'_int32 _) (Int64.of'_string \"4294967295\")"

text {*
  Use @{const Abs_uint8'} etc. instead of @{const Rep_uint8} in code equations
  for conversion functions to avoid exceptions during code generation when the
  target language provides only some of the uint types.
*}

lemma uint8_of_uint16_code [code]:
  "uint8_of_uint16 x = Abs_uint8' (ucast (Rep_uint16' x))"
by transfer simp

lemma uint8_of_uint32_code [code]:
  "uint8_of_uint32 x = Abs_uint8' (ucast (Rep_uint32' x))"
by transfer simp

lemma uint8_of_uint64_code [code]:
  "uint8_of_uint64 x = Abs_uint8' (ucast (Rep_uint64' x))"
by transfer simp

lemma uint16_of_uint8_code [code]:
  "uint16_of_uint8 x = Abs_uint16' (ucast (Rep_uint8' x))"
by transfer simp

lemma uint16_of_uint32_code [code]:
  "uint16_of_uint32 x = Abs_uint16' (ucast (Rep_uint32' x))"
by transfer simp

lemma uint16_of_uint64_code [code]:
  "uint16_of_uint64 x = Abs_uint16' (ucast (Rep_uint64' x))"
by transfer simp

lemma uint32_of_uint8_code [code]:
  "uint32_of_uint8 x = Abs_uint32' (ucast (Rep_uint8' x))"
by transfer simp

lemma uint32_of_uint16_code [code]:
  "uint32_of_uint16 x = Abs_uint32' (ucast (Rep_uint16' x))"
by transfer simp

lemma uint32_of_uint64_code [code]:
  "uint32_of_uint64 x = Abs_uint32' (ucast (Rep_uint64' x))"
by transfer simp

lemma uint64_of_uint8_code [code]:
  "uint64_of_uint8 x = Abs_uint64' (ucast (Rep_uint8' x))"
by transfer simp

lemma uint64_of_uint16_code [code]:
  "uint64_of_uint16 x = Abs_uint64' (ucast (Rep_uint16' x))"
by transfer simp

lemma uint64_of_uint32_code [code]:
  "uint64_of_uint32 x = Abs_uint64' (ucast (Rep_uint32' x))"
by transfer simp

end


(* Author: Peter Lammich *)
chapter \<open>Parsing\<close>
section \<open>Parser Combinators\<close>

theory Parser_Combinator
imports
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Char_ord"
  "HOL-Library.Code_Target_Nat"
  "Certification_Monads.Error_Monad"
  Error_Monad_Add
  "Show.Show"
  "HOL-Library.Rewrite"
begin

  (**
    Parser Combinators, based on Sternagel et Thiemann's Parser_Monad, with the following additional features/differences:

    * Setup for the function package, to handle recursion
      parser uses fuel to ensure termination.
    * Uses (unit \<Rightarrow> shows) for error messages instead of String (lazy computation of messages, more comfortable due to shows)
    * Everything defined over generic token type
    * Some fancy combinators
        a \<parallel> b    choice, type a = type b
        --[f]    sequential composition, combine results with f
        --       = --[Pair]
        --*      seq, ignore right result
        *--      seq, ignore left result

    TODO/FIXME

    * Currently, the bind and repeat operation dynamically check whether input is consumed and then fail.
      At least for bind (no input is generated), we could try to encode this information into the parser's type.
      However, interplay with function package is not clear at this point :(
      Possible solution: Fixed-point based recursion combinator and partial_function. We could then do totality proof afterwards.

  *)

subsection \<open>Type Definitions\<close>

datatype 'a len_list = LL (ll_fuel: nat) (ll_list: "'a list")
definition "ll_from_list l \<equiv> LL (length l) l"

lemma [measure_function]: "is_measure ll_fuel" by rule

text \<open>
  A parser takes a list of tokes and returns either an error message or
  a result together with the remaining tokens.
\<close>

type_synonym
  ('t, 'a) parser = "'t len_list \<Rightarrow> (unit \<Rightarrow> shows) + ('a \<times> 't len_list)"

text \<open>A \emph{consuming parser} (cparser for short) consumes at least one token of input.\<close>
definition is_cparser :: "('t,'a) parser \<Rightarrow> bool"
where
  "is_cparser p \<longleftrightarrow> (\<forall>l l' x. p l = Inr (x,l') \<longrightarrow> ll_fuel l' < ll_fuel l)"

lemma is_cparserI:
  assumes "\<And>l l' x. p l = Inr (x, l') \<Longrightarrow> ll_fuel l' < ll_fuel l"
  shows "is_cparser p"
  using assms unfolding is_cparser_def by blast

lemma is_cparserE:
  assumes "is_cparser p"
    and "(\<And>l l' x. p l = Inr (x, l') \<Longrightarrow> ll_fuel l' < ll_fuel l) \<Longrightarrow> P"
  shows "P"
  using assms by (auto simp: is_cparser_def; blast)

lemma is_cparser_length[simp, dest]:
  assumes "p l = Inr (x, l')" and "is_cparser p"
  shows "ll_fuel l' < ll_fuel l"
  using assms by (blast elim: is_cparserE)

text \<open>Used by fundef congruence rules\<close>
definition "PCONG_INR x ts' \<equiv> Inr (x,ts')"

lemma PCONG_EQ_D[dest!]:
  assumes "p l = PCONG_INR x l'"
  assumes "is_cparser p"
  shows "ll_fuel l' < ll_fuel l"
  using assms unfolding PCONG_INR_def by auto

named_theorems parser_rules

lemmas parser0_rules = disjI1 disjI2 allI impI conjI

thm disjI2 asm_rl

ML \<open>
  structure Parser_Combinator = struct

    val cfg_simproc = Attrib.setup_config_bool @{binding parser_simproc} (K true)

    val cfg_debug = Attrib.setup_config_bool @{binding parser_debug} (K false)

    fun trace_tac ctxt msg = if Config.get ctxt cfg_debug then print_tac ctxt msg else all_tac
    fun trace_tac' ctxt msg i =
      if Config.get ctxt cfg_debug then
        print_tac ctxt (msg ^ " on subgoal " ^ Int.toString i)
      else all_tac

    fun prove_cparser_step_tac ctxt =
      let
        val p_rls = Named_Theorems.get ctxt @{named_theorems parser_rules}
      in
        trace_tac' ctxt "prove_cparser_step" THEN'
        (
          resolve_tac ctxt (@{thms parser0_rules} @ p_rls)
          ORELSE' SOLVED' (asm_simp_tac ctxt)
        )
      end

    fun prove_cparser_tac ctxt =
      trace_tac ctxt "prove_cparser" THEN
      DEPTH_SOLVE (FIRSTGOAL (prove_cparser_step_tac ctxt))

    fun add_cparser_def def_thm context = let
      val ctxt = Context.proof_of context
      val orig_ctxt = ctxt

      val ctxt = Config.put cfg_simproc false ctxt

      val (def_thm, ctxt) = yield_singleton (apfst snd oo Variable.import true) def_thm ctxt

      val lhs = def_thm
        |> Local_Defs.meta_rewrite_rule ctxt
        |> (fst o Logic.dest_equals o Thm.prop_of)

      val T = fastype_of lhs
      val cp_stmt =
           Const (@{const_name is_cparser}, T --> HOLogic.boolT)$lhs
        |> HOLogic.mk_Trueprop

      fun is_cparser_free (@{const Trueprop} $ (Const (@{const_name is_cparser},_) $ Free _)) = true
        | is_cparser_free _ = false

      fun is_goal_ok st =
        Thm.prop_of st |> Logic.strip_imp_prems
        |> map (Logic.strip_assums_concl)
        |> forall is_cparser_free

      val cp_thm =
        cp_stmt |> Thm.cterm_of ctxt
        |> Goal.init
        |> SINGLE (
            unfold_tac ctxt [def_thm] THEN
            trace_tac ctxt "cparser def proof" THEN
            DEPTH_FIRST is_goal_ok (
              FIRSTGOAL (prove_cparser_step_tac ctxt)
            )
          )

      val cp_thm = case cp_thm of
        NONE => error "Could not prove any is_cparser theorem: Empty result sequence"
      | SOME thm =>
          Goal.conclude thm

      val cp_thm =
           singleton (Variable.export ctxt orig_ctxt) cp_thm
        |> Drule.zero_var_indexes

      (*
      val cp_thm =
        Goal.prove ctxt [] [] cp_stmt (fn {context, ...} => tac context)
      |> singleton (Variable.export ctxt orig_ctxt)
      *)

      val context = Named_Theorems.add_thm @{named_theorems parser_rules} cp_thm context
    in
      context
    end
  end
\<close>

attribute_setup consuming = \<open>
  Scan.succeed (Thm.declaration_attribute (Parser_Combinator.add_cparser_def))
\<close>

simproc_setup is_cparser_prover ("is_cparser p") = \<open>fn _ => fn ctxt => fn ct =>
  if Config.get ctxt Parser_Combinator.cfg_simproc then
    let
      open Parser_Combinator
      val t = Thm.term_of ct
      val stmt = Logic.mk_equals (t,@{term True})

      val _ = if Config.get ctxt cfg_debug then
          (Pretty.block [Pretty.str "is_cparser simproc invoked on: ", Syntax.pretty_term ctxt t, Pretty.fbrk, Syntax.pretty_term ctxt stmt]) |> Pretty.string_of |> tracing
        else ()

      val ctxt = Config.put Parser_Combinator.cfg_simproc false ctxt

      val othm = try (Goal.prove ctxt [] [] stmt) (fn {context=ctxt, ...} =>
        FIRSTGOAL (resolve_tac ctxt @{thms HOL.Eq_TrueI})
        THEN TRY (Parser_Combinator.prove_cparser_tac ctxt)
      )

      val _ =
        if Config.get ctxt cfg_debug andalso is_none othm then
          (Pretty.block [Pretty.str "is_cparser simproc failed on: ", Syntax.pretty_term ctxt t, Pretty.fbrk, Syntax.pretty_term ctxt stmt]) |> Pretty.string_of |> tracing
        else ()

      (*
      val _ = case othm of
        NONE => (Pretty.block [Pretty.str "is_cparser simproc failed on: ", Syntax.pretty_term ctxt t, Pretty.fbrk, Syntax.pretty_term ctxt stmt]) |> Pretty.string_of |> warning
     | SOME _ => ();
      *)
    in
      othm
    end
  else
    NONE
\<close>

text \<open>Wrapping a parser to dynamically assert that it consumes tokens.\<close>
definition ensure_cparser :: "('t,'a) parser \<Rightarrow> ('t,'a) parser" where
  "ensure_cparser p \<equiv> \<lambda>ts. do {
    (x, ts') \<leftarrow> p ts;
    if (ll_fuel ts' < ll_fuel ts) then Error_Monad.return (x,ts')
    else Error_Monad.error (\<lambda>_. shows ''Dynamic parser check failed'')
  }"

lemma ensure_cparser_cparser[parser_rules]: "is_cparser (ensure_cparser p)"
  apply (rule is_cparserI)
  unfolding ensure_cparser_def
  by (auto simp: Error_Monad.bind_def split: sum.splits if_splits)

lemma ensure_cparser_cong[fundef_cong]:
  assumes "l=l'"
  assumes "p l = p' l'"
  shows "ensure_cparser p l = ensure_cparser p' l'"
  using assms by (auto simp: ensure_cparser_def)

abbreviation bnf_eq :: "('t,'a) parser \<Rightarrow> ('t,'a) parser \<Rightarrow> prop" (infix "::=" 2) where
  "bnf_eq p1 p2 \<equiv> (\<And>l. p1 l = p2 l)"

subsection \<open>Monad-Setup for Parsers\<close>

definition return :: "'a \<Rightarrow> ('t, 'a) parser"
where
  "return x = (\<lambda>ts. Error_Monad.return (x, ts))"

definition error_aux :: "(unit \<Rightarrow> shows) \<Rightarrow> ('t, 'a) parser"
where
  "error_aux e = (\<lambda>_. Error_Monad.error e)"

abbreviation error where "error s \<equiv> error_aux (ERR s)"
abbreviation "error_str s \<equiv> error_aux (ERRS s)"

definition update_error :: "('t,'a) parser \<Rightarrow> (shows \<Rightarrow> shows) \<Rightarrow> ('t,'a) parser"
  where "update_error m f l \<equiv> m l <+? (\<lambda>e _. f (e ()))"

definition ensure_parser :: "('t,'a) parser \<Rightarrow> ('t,'a) parser" where
  "ensure_parser p \<equiv> \<lambda>ts. do {
    (x, ts') \<leftarrow> p ts;
    if (ll_fuel ts' \<le> ll_fuel ts) then Error_Monad.return (x,ts')
    else Error_Monad.error (ERRS ''Dynamic parser check failed'')
  }"

definition bind :: "('t, 'a) parser \<Rightarrow> ('a \<Rightarrow> ('t, 'b) parser) \<Rightarrow> ('t, 'b) parser"
where
  "bind m f \<equiv> \<lambda>ts. do {
    (x, ts) \<leftarrow> ensure_parser m ts;
    ensure_parser (f x) ts
  }"

definition get :: "('t,'t) parser" where
  "get ll \<equiv> case ll of LL (Suc n) (x#xs) \<Rightarrow> Error_Monad.return (x,LL n xs) | _ \<Rightarrow> (Error_Monad.error (\<lambda>_. shows_string ''Expecting more input''))"

definition get_tokens :: "('t,'t list) parser" where
  "get_tokens \<equiv> \<lambda>ll. Error_Monad.return (ll_list ll,ll)"

adhoc_overloading
      Monad_Syntax.bind bind
  and Error_Syntax.update_error update_error

(* TODO: Specialize to parser type? *)
lemma let_cong' [fundef_cong]:
  "M = N \<Longrightarrow> l=l' \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x l' = g x l') \<Longrightarrow> Let M f l = Let N g l'"
  unfolding Let_def by blast

lemma if_cong' [fundef_cong]:
  assumes "b = c"
    and "l=l'"
    and "c \<Longrightarrow> x l' = u l'"
    and "\<not> c \<Longrightarrow> y l' = v l'"
  shows "(if b then x else y) l = (if c then u else v) l'"
  using assms by simp

lemma split_cong' [fundef_cong]:
  "l=l' \<Longrightarrow> (\<And>x y. (x, y) = q \<Longrightarrow> f x y l' = g x y l' ) \<Longrightarrow> p = q \<Longrightarrow> case_prod f p l = case_prod g q l'"
  by (auto simp: split_def)

lemma is_cparser_bind[parser_rules]:
  assumes "is_cparser p \<or> (\<forall>x. is_cparser (q x))"
  shows "is_cparser (p \<bind> q)"
  apply (rule is_cparserI)
  using assms unfolding is_cparser_def bind_def Error_Monad.bind_def ensure_parser_def
  by (fastforce split: sum.splits if_splits)

lemma return_eq[simp]: "return x l = Inr y \<longleftrightarrow> y=(x,l)"
  unfolding return_def by auto

lemma is_cparser_error[parser_rules]: "is_cparser (error_aux e)"
  by (auto simp: error_aux_def intro: is_cparserI)

lemma is_cparser_get[parser_rules]:
  "is_cparser get"
  apply (rule is_cparserI)
  apply (auto simp: get_def split: len_list.splits nat.splits list.splits)
  done

lemma monad_laws[simp]:
  "bind m return = ensure_parser m"
  "bind (return x) f = ensure_parser (f x)"
  "bind (bind m f) g = bind m (\<lambda>x. bind (f x) g)"
  "ensure_parser (ensure_parser m) = ensure_parser m"
  "bind (ensure_parser m) f = bind m f"
  "bind m (\<lambda>x. ensure_parser (f x)) = bind m f"
  unfolding bind_def return_def ensure_parser_def Error_Monad.bind_def
  by (auto split: if_splits sum.splits prod.splits intro!: ext)

subsection \<open>More Combinators\<close>

term "shows"

definition err_expecting_aux :: "(unit \<Rightarrow> shows) \<Rightarrow> ('t::show, 'a) parser"
where
  "err_expecting_aux msg = do { ts \<leftarrow> get_tokens; error
    (shows_string ''expecting '' o msg () o shows_string '', but found: '' o shows_quote (shows (take 100 ts)))}"

abbreviation err_expecting :: "shows \<Rightarrow> ('t::show, 'a) parser"
where
  "err_expecting msg \<equiv> err_expecting_aux (\<lambda>_. msg)"

abbreviation "err_expecting_str msg \<equiv> err_expecting (shows_string msg)"

definition "eoi \<equiv> do {
  tks \<leftarrow> get_tokens; if tks=[] then return () else err_expecting_str ''end of input'' }"

definition alt :: "(_,'a) parser \<Rightarrow> (_,'b) parser \<Rightarrow> (_,'a+'b) parser" where
  "alt p1 p2 l \<equiv> try   do { (r,l) \<leftarrow> p1 l; Error_Monad.return (Inl r, l) }
                 catch (\<lambda>e1. (try do { (r,l) \<leftarrow> p2 l; Error_Monad.return (Inr r, l) }
                 catch (\<lambda>e2. Error_Monad.error (\<lambda>_. e1 () o shows ''\<newline>  | '' o e2 ()))))"

fun sum_join where
  "sum_join (Inl x) = x" | "sum_join (Inr x) = x"

abbreviation alt' :: "(_,'a) parser \<Rightarrow> (_,'a) parser \<Rightarrow> (_,'a) parser" (infixr "\<parallel>" 53)
  where "alt' p q \<equiv> alt p q \<bind> return o sum_join"

abbreviation gseq :: "('t,'a) parser \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('t,'b) parser \<Rightarrow> ('t,'c) parser" ("_--[_]_" [61,0,60] 60)
  where "gseq p f q \<equiv> p \<bind> (\<lambda>a. q \<bind> (\<lambda>b. return (f a b)))" (* TODO/FIXME: Do-notation and abbreviation generate additional type vars here *)

abbreviation seq :: "('t,'a) parser \<Rightarrow> ('t,'b) parser \<Rightarrow> ('t,'a\<times>'b) parser" (infixr "--" 60)
  where "seq p q \<equiv> p --[Pair] q"

abbreviation seq_ignore_left :: "('t,'a) parser \<Rightarrow> ('t,'b) parser \<Rightarrow> ('t,'b) parser" (infixr "*--" 60)
  where "p *-- q \<equiv> p --[\<lambda>_ x. x] q"

abbreviation seq_ignore_right :: "('t,'a) parser \<Rightarrow> ('t,'b) parser \<Rightarrow> ('t,'a) parser" (infixr "--*" 60)
  where "p --* q \<equiv> p --[\<lambda>x _. x] q"

abbreviation map_result :: "('t,'a) parser \<Rightarrow> ('a\<Rightarrow>'b) \<Rightarrow> ('t,'b) parser" (infixr "with" 54)
  where "p with f \<equiv> p \<bind> return o f"

definition "exactly ts \<equiv> foldr (\<lambda>t p. do { x\<leftarrow>get; if x=t then p \<bind> return o (#) x else error id}) ts (return [])
    \<parallel> err_expecting (shows_string ''Exactly '' o shows ts)"

declare err_expecting_aux_def[consuming]

lemma alt_is_cparser[parser_rules]:
  "is_cparser p \<Longrightarrow> is_cparser q \<Longrightarrow> is_cparser (alt p q)"
  apply (rule is_cparserI)
  unfolding alt_def
  by (auto simp: Error_Monad.bind_def split: sum.splits)

lemma alt_cong[fundef_cong]:
  "\<lbrakk> l=l'; p1 l = p1' l'; \<And>e. p1' l' = Inl e \<Longrightarrow> p2 l = p2' l' \<rbrakk> \<Longrightarrow> alt p1 p2 l = alt p1' p2' l'"
  unfolding alt_def by (auto split: sum.splits simp: Error_Monad.bind_def)

lemma [parser_rules]: "ts\<noteq>[] \<Longrightarrow> is_cparser (exactly ts)"
  by (cases ts) (auto simp: exactly_def intro: parser_rules)

abbreviation optional :: "'a \<Rightarrow> ('t,'a) parser \<Rightarrow> ('t,'a) parser" where
  "optional dflt p \<equiv> p \<parallel> return dflt"

term "a\<^sup>*"

abbreviation maybe :: "('t,'a) parser \<Rightarrow> ('t,'a option) parser" ("(_?)" [1000] 999)
  where "p? \<equiv> p with Some \<parallel> return None"

subsubsection \<open>Repeat\<close>

fun repeat :: "('t,'a) parser \<Rightarrow> ('t,'a list) parser" where
  "repeat p ::= optional [] (ensure_cparser p --[(#)] repeat p)"

abbreviation "repeat1 p \<equiv> p --[(#)] repeat p"

declare repeat.simps[simp del]

lemma repeat_cong[fundef_cong]:
  assumes "\<And>nts. \<lbrakk> ll_fuel nts \<le> ll_fuel l' \<rbrakk> \<Longrightarrow> p (nts) = p' (nts)"
  assumes "l=l'"
  shows "repeat p l = repeat p' l'"
  using assms(1)
  unfolding \<open>l=l'\<close>
  apply (induction p l' rule: repeat.induct)
  apply (rewrite in "_=\<hole>" repeat.simps)
  apply (rewrite in "\<hole>=_" repeat.simps)
  apply (intro alt_cong bind_cong)
  apply (auto simp: ensure_cparser_def PCONG_INR_def)
  done

subsubsection \<open>Left and Right Associative Chaining\<close>
text \<open>Parse a sequence of \<open>A\<close> separated by \<open>F\<close>,
  and then fold the sequence with the results of \<open>F\<close>,
  either left or right associative.

  Example: Assume we have the input \<open>x\<^sub>1 o\<^sub>1 \<dots> o\<^sub>n\<^sub>-\<^sub>1 x\<^sub>n\<close>,
    and the result of parsing the \<open>x\<close> with \<open>A\<close> and the \<open>o\<close> with \<open>F\<close>
    are \<open>a\<^sub>i\<close> and \<open>+\<^sub>i\<close>.
    Then, \<open>chainL1\<close> returns \<open>(\<dots>((a\<^sub>1 +\<^sub>1 a\<^sub>2) +\<^sub>2 a\<^sub>3) +\<^sub>3 \<dots>) \<close>
    and \<open>chainR1\<close> returns \<open>a\<^sub>1 +\<^sub>1 (a\<^sub>2 +\<^sub>2 (a\<^sub>3 +\<^sub>3 \<dots>)\<dots>) \<close>
\<close>
context
  fixes A :: "('t,'a) parser"
  fixes F :: "('t,'a\<Rightarrow>'a\<Rightarrow>'a) parser"
begin
  definition chainL1 :: "('t,'a) parser" where
    "chainL1 \<equiv> do {
      x \<leftarrow> A;
      xs \<leftarrow> repeat (F --[\<lambda>f b a. f a b] A);
      return (foldl (\<lambda>a f. f a) x xs)
    }"

  qualified fun fold_shiftr :: "('a \<Rightarrow> (('a\<Rightarrow>'a\<Rightarrow>'a)\<times>'a) list \<Rightarrow> 'a)" where
    "fold_shiftr a [] = a"
  | "fold_shiftr a ((f,b)#xs) = f a (fold_shiftr b xs)"

  definition chainR1 :: "('t,'a) parser" where
    "chainR1 \<equiv> do {
      x \<leftarrow> A;
      xs \<leftarrow> repeat (F -- A);
      return (fold_shiftr x xs)
    } "

end

lemma chainL1_cong[fundef_cong]:
  assumes "\<And>l2. ll_fuel l2 \<le> ll_fuel l' \<Longrightarrow> A l2 = A' l2"
  assumes "\<And>l2. ll_fuel l2 \<le> ll_fuel l' \<Longrightarrow> F l2 = F' l2"
  assumes "l=l'"
  shows "chainL1 A F l = chainL1 A' F' l'"
  unfolding chainL1_def
  apply (intro bind_cong repeat_cong assms order_refl)
  by auto

lemma chainR1_cong[fundef_cong]:
  assumes "\<And>l2. ll_fuel l2 \<le> ll_fuel l' \<Longrightarrow> A l2 = A' l2"
  assumes "\<And>l2. ll_fuel l2 \<le> ll_fuel l' \<Longrightarrow> F l2 = F' l2"
  assumes "l=l'"
  shows "chainR1 A F l = chainR1 A' F' l'"
  unfolding chainR1_def
  apply (intro bind_cong repeat_cong assms order_refl)
  by auto

subsection \<open>Lexing Utilities\<close>

definition tk_with_prop' :: "shows \<Rightarrow> ('t::show \<Rightarrow> bool) \<Rightarrow> ('t,'t) parser" where
  [consuming]: "tk_with_prop' errmsg \<Phi> \<equiv> do {
    x\<leftarrow>get;
    if \<Phi> x then return x
    else err_expecting errmsg
  }"

abbreviation tk_with_prop :: "('t::show \<Rightarrow> bool) \<Rightarrow> ('t,'t) parser" where
  "tk_with_prop \<equiv> tk_with_prop' id"

definition range :: "'t::{linorder,show} \<Rightarrow> 't \<Rightarrow> ('t,'t) parser" where
  [consuming]: "range a b \<equiv> do {
    x\<leftarrow>get;
    if a\<le>x \<and> x\<le>b then return x
    else err_expecting (shows_string ''Token in range '' o shows a o shows_string '' - '' o shows b) }"

definition any :: "'t::show list \<Rightarrow> ('t,'t) parser" where
  [consuming]: "any ts \<equiv> do { t\<leftarrow>get; if t\<in>set ts then return t else err_expecting (shows_string ''One of '' o shows ts) }"

definition "gen_token ws p \<equiv> ws *-- p"

lemma [parser_rules]: "is_cparser p \<Longrightarrow> is_cparser (gen_token ws p)"
  unfolding gen_token_def by simp

subsubsection \<open>Characters\<close>
abbreviation (input) "char_tab \<equiv> CHR 0x09"
abbreviation (input) "char_carriage_return \<equiv> CHR 0x0D"
abbreviation (input) "char_wspace \<equiv> [CHR '' '', CHR ''\<newline>'', char_tab, char_carriage_return]"

text \<open>Some standard idioms\<close>
definition [consuming]: "lx_lowercase \<equiv> (range CHR ''a'' CHR ''z'' )"
definition [consuming]: "lx_uppercase \<equiv> (range CHR ''A'' CHR ''Z'' )"
definition [consuming]: "lx_alpha \<equiv> (lx_lowercase \<parallel> lx_uppercase)"
definition [consuming]: "lx_digit \<equiv> (range CHR ''0'' CHR ''9'' )"
abbreviation "lx_alphanum \<equiv> lx_alpha \<parallel> lx_digit"

subsection \<open>Code Generator Setup\<close>
declare monad_laws[code_unfold]
lemma bind_return_o_unfold[code_unfold]: "(m \<bind> return o f) = do { x\<leftarrow>m; return (f x)}" by (auto simp: o_def)
declare split[code_unfold] (* TODO: Should this be code_unfold by default? *)

subsection \<open>Utilities for Parsing\<close>

text \<open>Project out remainder token sequence\<close>
fun show_pres where
  "show_pres (Inr (ll,_)) = Inr ll"
| "show_pres (Inl e) = Inl e"

text \<open>Parse complete input, parameterized by parser for trailing whitespace\<close>
definition "parse_all ws p \<equiv> show_pres o (p --* ws --* eoi) o ll_from_list o String.explode"

definition "parse_all_implode ws p s \<equiv> parse_all ws p s <+? (\<lambda>msg. String.implode (msg () ''''))"

definition "parse_all_implode_nows p s \<equiv> parse_all_implode (return ()) p s"

ML \<open>
  (* Read file to string *)
  fun file_to_string name = let
    val f = TextIO.openIn name
    val s = TextIO.inputAll f
    val _ = TextIO.closeIn f
  in s end
\<close>

end


header {* Additions to Imperative/HOL *}
theory Imperative_HOL_Add
imports "~~/src/HOL/Imperative_HOL/Imperative_HOL"
begin

text {* This theory loads the Imperative HOL framework and provides
        some additional lemmas needed for the separation logic framework. *}

text {* Arrays and references can also be stored on the heap *}
instance array :: (type) heap ..
instance ref :: (type) heap ..

text {* Characters can be stored on the heap *}
instantiation char :: heap begin
  instance ..
end

text {* A stronger elimination rule for @{text ref} *}

lemma effect_ref[effect_elims]:
  assumes "effect (ref (x::('a::heap))) h h' r"
  obtains "r = fst (Ref.alloc x h)"
  and "h' = snd (Ref.alloc x h)"
  using assms
  unfolding effect_def
proof -
  case goal1
  from goal1(2) have "r = fst (Ref.alloc x h)" "h' = snd (Ref.alloc x h)"
    by (auto simp add: execute_simps)
  from goal1(1)[OF this] show ?thesis by simp
qed

text {* Some lemmas about the evaluation of the limit for modifications on
  a heap *}

lemma lim_Ref_alloc[simp]: "lim (snd (Ref.alloc x h)) = Suc (lim h)"
  unfolding Ref.alloc_def
  by (simp add: Let_def)

lemma lim_Array_alloc[simp]: "lim (snd (Array.alloc x h)) = Suc (lim h)"
  unfolding Array.alloc_def Array.set_def
  by (simp add: Let_def)

lemma lim_Array_set[simp]: "lim (Array.set a xs h) = lim h"
  unfolding Array.set_def
  by (simp add: Let_def)

thm Array.update_def
lemma lim_Array_update[simp]: "lim (Array.update a i x h) = lim h"
  unfolding Array.update_def
  by (simp add: Let_def)

text {* Simplification rules for the addresses of new allocated arrays and
  references *}

lemma addr_of_ref_alloc[simp]:
  "addr_of_ref (fst (Ref.alloc x h)) = lim h"
  unfolding Ref.alloc_def
  by (simp add: Let_def)

lemma addr_of_array_alloc[simp]:
  "addr_of_array (fst (Array.alloc x h)) = lim h"
  unfolding Array.alloc_def
  by (simp add: Let_def)

end


text \<open>
There is a bug.
In detail, see the comment of fun pr_term_from.
\<close>

theory Subgoal
  imports Kernel
begin

section \<open>type_synonyms\<close>
(*todo*)
(*make be more modular*)

type_synonym "prop" = type

type_synonym "subgoal" = "prop list \<times> prop"
definition assms_of :: "subgoal \<Rightarrow> prop list" where "assms_of = fst"
definition thesis_of :: "subgoal \<Rightarrow> prop" where "thesis_of = snd"

datatype inf_rule =
  Assume type |
  Imp_I type |
  Imp_E

\<comment> \<open>derivation tree as inf_rule list\<close>
(*fixme*)
type_synonym deriv_tree = "inf_rule list"

type_synonym pr_state = "subgoal list \<times> deriv_tree"
definition subgoals_of :: "pr_state \<Rightarrow> subgoal list" where "subgoals_of = fst"
definition deriv_tree_of :: "pr_state \<Rightarrow> deriv_tree" where "deriv_tree_of = snd"

section \<open>proof term constructor\<close>
definition fresh_var :: "(type \<Rightarrow> name list) \<Rightarrow> name" where
  "fresh_var e = (SOME n. \<forall>T. n \<notin> set (e T))"

\<comment> \<open>construct proof term from derivation tree\<close>
\<comment> \<open>pr_term_from accumulator_term type_env_as_type_to_nat_list_fun deriv_tree \<Rightarrow> pr_term\<close>
(*fixme*)
text \<open>
There is a bug.
If a variable occurs some times,
then this fun can't create the proof term correctly.
e.g., I can't prove S = \<lambda>x y z. x z (y z): (a \<rightarrow> b \<rightarrow> c) \<rightarrow> (a \<rightarrow> b) \<rightarrow> a \<rightarrow> c,
while I can prove \<lambda>x y z w. x z (y w): (a \<rightarrow> b \<rightarrow> c) \<rightarrow> (a \<rightarrow> b) \<rightarrow> a \<rightarrow> a \<rightarrow> c.
\<close>
fun pr_term_from :: "Kernel.term option list \<Rightarrow> (type \<Rightarrow> name list) \<Rightarrow> deriv_tree \<Rightarrow> Kernel.term option list" where
  "pr_term_from ts _ [] = ts" |
  "pr_term_from ts e (r # rs) = (case r of
    Assume T \<Rightarrow> let v = fresh_var e in
      pr_term_from (assume v T # ts) (e(T := v # e T)) rs |
    Imp_I T \<Rightarrow> (case e T of
      [] \<Rightarrow> pr_term_from (imp_i (fresh_var e) T (hd ts) # tl ts) e rs |
      n # ns \<Rightarrow> pr_term_from (imp_i n T (hd ts) # tl ts) (e(T := ns)) rs) |
    Imp_E \<Rightarrow> (case ts of
      t2 # t1 # ts \<Rightarrow> pr_term_from (imp_e t1 t2 # ts) e rs))"
(*printable version*)
(*
fun pr_term_from :: "term option list \<Rightarrow> (type \<Rightarrow> name list) \<Rightarrow> deriv_tree \<Rightarrow> name \<Rightarrow> term option list" where
  "pr_term_from ts _ [] _ = ts" |
  "pr_term_from ts e (r # rs) i = (case r of
    Assume T \<Rightarrow> let v = i in
      pr_term_from (mk_var v T # ts) (e(T := v # e T)) rs (next i) |
    Imp_I T \<Rightarrow> (case e T of
      [] \<Rightarrow> pr_term_from (mk_abs i T (hd ts) # tl ts) e rs (next i) |
      n # ns \<Rightarrow> pr_term_from (mk_abs n T (hd ts) # tl ts) (e(T := ns)) rs i) |
    Imp_E \<Rightarrow> (case ts of
      t2 # t1 # ts \<Rightarrow> pr_term_from (mk_app t1 t2 # ts) e rs i))"
*)

section \<open>method\<close>
datatype method =
  Assumption |
  Rule_Imp_I |
  Rule_Imp_E "prop"
(*future work*)
(*
creating a new rule from theorem
type_synonym method = "subgoal \<Rightarrow> subgoal list"
definition "rule" :: "prop \<Rightarrow> method" where
definition inf_rule_from :: "method \<Rightarrow> inf_rule" where
  "inf_rule_from m = (if m = rule_impI then
    )"
*)

section \<open>interaction\<close>
definition "lemma" :: "prop \<Rightarrow> pr_state" where
  "lemma T = ([([], T)], [])"
definition "apply" :: "pr_state \<Rightarrow> method \<Rightarrow> pr_state" (infixl "apply" 500) where
  "ps apply m = (case subgoals_of ps of sg # sgs \<Rightarrow> (case m of
    Assumption \<Rightarrow> if thesis_of sg \<in> set (assms_of sg) then (sgs, (Assume (thesis_of sg)) # deriv_tree_of ps) else undefined |
    Rule_Imp_I \<Rightarrow> (case thesis_of sg of Fun T1 T2 \<Rightarrow> ((T1 # assms_of sg, T2) # sgs, Imp_I T1 # deriv_tree_of ps)) |
    Rule_Imp_E P \<Rightarrow> ((assms_of sg, Fun P (thesis_of sg)) # (assms_of sg, P) # sgs, Imp_E # deriv_tree_of ps)))"
definition "done" :: "pr_state \<Rightarrow> prop \<times> Kernel.term" ("_ done" 400) where
  "ps done = (case pr_term_from [] (\<lambda>T. []) (deriv_tree_of ps) of [t] \<Rightarrow> print t)"
(*printable version*)
(*
definition "done" :: "pr_state \<Rightarrow> prop \<times> term" ("_ done" 400) where
  "ps done = (case pr_term_from [] (\<lambda>T. []) (deriv_tree_of ps) X of [t] \<Rightarrow> print t)"
*)

section \<open>test\<close>
(*test*)
(*printable version*)
(*
value "
lemma (''a'':* \<rightarrow>> ''a'':* )
  apply Rule_Imp_I
  apply Assumption
  done
"
value "
lemma ((''a'':* \<rightarrow>> ''b'':* \<rightarrow>> ''c'':* ) \<rightarrow>> (''a'':* \<rightarrow>> ''b'':* ) \<rightarrow>> ''a'':* \<rightarrow>> ''c'':* )
  apply Rule_Imp_I
  apply Rule_Imp_I
  apply Rule_Imp_I
  apply (Rule_Imp_E (''b'':* ))
  apply (Rule_Imp_E (''a'':* ))
  apply Assumption
  apply Assumption
  apply (Rule_Imp_E (''a'':* ))
  apply Assumption
  apply Assumption
  done
"
*)

(*future work*)
(*
theorem soundness: "\<exists>ms. ((foldl (apply) (lemma l) ms) done) = (T, t) \<Longrightarrow> l = T \<and> T = type_of t \<and> well_typed t"
  sorry
(*inductive provable*)
theorem completeness: "True" ..
*)

end