theory UnpairedLogic
imports
  NewLogic
begin

fun unpairMsg :: "execmsg \<Rightarrow> kntrace"
where
  "unpairMsg (Tup x y) =
    [\<Delta> MkFst x y, \<star> x, \<Delta> MkSnd x y, \<star> y] @ unpairMsg x @ unpairMsg y"
| "unpairMsg m = []"

fun unpairTrace_raw :: "kntrace \<Rightarrow> kntrace"
where
  "unpairTrace_raw [] = []"
| "unpairTrace_raw (\<Delta> e # t) = \<Delta> e # unpairTrace_raw t"
| "unpairTrace_raw (\<star> m # t) = \<star> m # unpairMsg m @ unpairTrace_raw t"

definition unpairTrace :: "kntrace \<Rightarrow> kntrace"
where "unpairTrace t = rev (remdups (rev (unpairTrace_raw t)))"

lemma distinct_unpairTrace [simp]: "distinct (unpairTrace t)"
  by(simp add: unpairTrace_def)

lemma unpairTrace_raw_append [simp]:
  "unpairTrace_raw (t@t') = unpairTrace_raw t @ unpairTrace_raw t'"
  by(induct t rule: unpairTrace_raw.induct, auto)

lemma set_unpairTrace_raw_mono: "set t \<subseteq> set (unpairTrace_raw t)"
  by(induct t rule: unpairTrace_raw.induct, auto)

lemmas set_unpairTrace_raw_monoD =
  subsetD[OF set_unpairTrace_raw_mono, rule_format]

lemma set_unpairTrace_mono: "set t \<subseteq> set (unpairTrace t)"
  by(simp add: unpairTrace_def set_unpairTrace_raw_mono)

lemmas set_unpairTrace_monoD =
  subsetD[OF set_unpairTrace_mono, rule_format]

lemma listOrd_unpairTrace_raw:
  "listOrd t x y \<Longrightarrow> listOrd (unpairTrace_raw t) x y"
  apply(induct t rule: unpairTrace_raw.induct)
  by(auto dest: set_unpairTrace_raw_monoD)

lemma in_unpair_conv_unpairMsg:
  "x' \<in> unpair x \<Longrightarrow> \<star> x' \<in> set (\<star> x # unpairMsg x)"
  by(induct x rule: unpairMsg.induct, auto)

lemma listOrd_unpairTrace_raw_unpair:
  "listOrd t (\<star> x) y \<Longrightarrow>
   \<forall> x' \<in> unpair x. listOrd (unpairTrace_raw t) (\<star> x') y"
  apply(induct t rule: unpairTrace_raw.induct)
  by(auto dest: set_unpairTrace_raw_monoD in_unpair_conv_unpairMsg)

lemma listOrd_rev [simp]: "listOrd (rev xs) x y = listOrd xs y x"
  by(induct xs, auto)

lemma unpairTrace_Nil [iff]: "unpairTrace [] = []"
  by(simp add: unpairTrace_def)

lemma remdups_Snoc:
  "remdups (xs @ [x]) = [x' \<leftarrow> remdups xs. x' \<noteq> x]  @ [x] "
  by(induct xs rule: remdups.induct, auto)

lemma Event_in_set_unpairTrace_raw [simp]:
  "(\<Delta> e \<in> set (unpairTrace_raw t)) = (\<Delta> e \<in> set t)"
  apply(induct t rule: unpairTrace_raw.induct, auto)
  oops

lemma unpairTrace_Cons_Event:
  "unpairTrace (\<Delta> e # t) = \<Delta> e # [x\<leftarrow>unpairTrace t . x \<noteq> \<Delta> e]"
  by(simp add: unpairTrace_def remdups_Snoc rev_filter)

lemma unpairTrace_idem [iff]:
  "unpairTrace (unpairTrace t) = unpairTrace t"
  apply(induct t rule: unpairTrace_raw.induct)
  apply(simp)
  apply(simp add: unpairTrace_Cons_Event)
  oops

fun inp' :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "inp' s (MkStep tid (Send l msg)) = {}"
| "inp' s (MkStep tid (Recv l msg)) = {subst s (s2e msg tid)}"
| "inp' s (FromIK0 m)               = {}"
| "inp' s (MkHash m)                = {m}"
| "inp' s (MkTup x y)               = {x, y}"
| "inp' s (MkFst x y)               = {}"
| "inp' s (MkSnd x y)               = {}"
| "inp' s (MkEncr m k)              = {m, k}"
| "inp' s (MkDecr m k)              = {Enc m k, inv k}"

fun fromMsg :: "wt_subst \<Rightarrow> kntrace \<Rightarrow> specmsg \<Rightarrow> tid \<Rightarrow> execmsg \<Rightarrow> bool"
where
  "fromMsg s t (Enc msg key) tid m =
   (
     (subst s (s2e (Enc msg key) tid) = m) \<or>
     (listOrd t (\<star> Enc (subst s (s2e msg tid)) (subst s (s2e key tid)))
                (\<star> subst s (s2e msg tid))
      \<and>
      listOrd t (\<star> subst s (s2e (inv key) tid))
                (\<star> subst s (s2e msg tid))
      \<and>
      fromMsg s t msg tid m
     )
   )"
| "fromMsg s t (Tup x y) tid m =
   (
     (subst s (s2e (Tup x y) tid) = m) \<or>
     (listOrd t (\<star> Tup (subst s (s2e x tid)) (subst s (s2e y tid)))
                (\<star> subst s (s2e x tid))
      \<and>
      fromMsg s t x tid m
     ) \<or>
     (listOrd t (\<star> Tup (subst s (s2e x tid)) (subst s (s2e y tid)))
                (\<star> subst s (s2e y tid))
      \<and>
      fromMsg s t y tid m
     )
   )"
| "fromMsg s t msg tid m = (subst s (s2e msg tid) = m)"

lemma Knows_before_inp'_unpaired:
  "\<lbrakk>\<Delta> e \<in> set (unpairTrace t); m \<in> inp' s e\<rbrakk>
   \<Longrightarrow> \<forall> m' \<in> unpair m. listOrd (unpairTrace t) (\<star> m')  (\<Delta> e)"
  oops

thm remdups_C

  apply(auto)

lemma unpairTrace_reachable: "(unpairTrace t, r, s) \<in> reachable P"
  apply(simp add: unpairTrace_def)
  apply(insert reachable)
  proof(induct rule: reachable.induct)
    case init thus ?case
      by(auto intro: reachable.intros)
  next
    case (create t r s tid R \<alpha>) thus ?case
      apply(simp)
      apply(drule reachable.create)
      apply(simp+)
    apply(simp_all)
    case Nil thus ?case by simp next
    case (Cons knev t) thus ?case
      apply(case_tac knev)
      apply(simp_all)

lemma listOrd_unpairTrace:
  "listOrd t x y \<Longrightarrow> listOrd (unpairTrace t) x y"
  apply(simp add: unpairTrace_def)

  apply(induct t rule: unpairTrace_raw.induct)
  by(auto dest: set_unpairTrace_raw_monoD)

lemma listOrd_unpairTrace_unpair:
  "listOrd t (\<star> x) y \<Longrightarrow>
   \<forall> x' \<in> unpair x. listOrd (unpairTrace_raw t) (\<star> x') y"
  apply(induct t rule: unpairTrace_raw.induct)
  by(auto dest: set_unpairTrace_raw_monoD in_unpair_conv_unpairMsg)

fun

fun appendNew :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "appendNew as []     = as"
| "appendNew as (x#xs) =
     appendNew (as @ (if x \<in> set as then [] else [x])) xs"

function (sequential) unpairTrace :: "kntrace \<Rightarrow> kntrace \<Rightarrow> kntrace"
where
  "unpairTrace pre [] = pre"
| "unpairTrace pre (\<star> Tup x y # t) =
     unpairTrace (appendNew pre [\<star> Tup x y])
                 (\<Delta> MkFst x y # \<star> x # \<Delta> MkSnd x y # \<star> y # t)"
| "unpairTrace pre (knev # t) = unpairTrace (appendNew pre [knev]) t"
by pat_completeness auto
termination
  sorry

lemma set_unpairTrace_monoD_raw:
  "x \<in> set pre \<Longrightarrow> x \<in> set (unpairTrace pre t)"
  "x \<in> set t \<Longrightarrow> x \<in> set (unpairTrace pre t)"
  apply(induct t arbitrary: x pre rule: unpairTrace.induct)
    apply(simp_all)
    apply(auto)
    case 1 thus ?case by simp next
    case (2 pre x y t x' pre') thus ?case
      apply(auto)
thm prems      apply(drule prems)

lemma set_unpairTrace_monoD:
  "x \<in> set t \<Longrightarrow> x \<in> set (unpairTrace pre t)"
  apply(induct t rule: unpairTrace.induct)
  apply(simp_all)
  apply(auto)

lemma listOrd_unpairTraceI:
  "listOrd t x y \<Longrightarrow> listOrd (unpairTrace pre t) x y"
  apply(induct t arbitrary: pre rule: unpairTrace.induct)

lemma unpairTrace_distinctI [intro!]:
  "distinct pre \<Longrightarrow> distinct (unpairTrace pre t)"
  apply(induct t arbitrary: pre rule: unpairTrace.induct)
  apply(simp_all)
  apply(safe)
  apply(simp_all)
  apply(auto)

lemma unpairMsg_distinct [intro!]:
  "distinct t \<Longrightarrow> distinct (unpairMsg m t)"
  a

lemma unpairMsg_Cons_Event [simp]:
  "unpairMsg m (\<Delta> e # pre) = \<Delta> e # unpairMsg m pre"
  by(induct m arbitrary: pre, auto)

lemma unpairTrace_Cons_Event [simp]:
  "unpairTrace (\<Delta> e # pre) t = \<Delta> e # unpairTrace pre t"
  by(induct t arbitrary: pre, simp, case_tac a, auto)

context reachable_state begin

lemma unpairTrace_distinct:

lemma unpairTrace_reachable: "(unpairTrace [] t, r, s) \<in> reachable P"
  apply(insert reachable)
  apply(induct rule: reachable.induct)
    apply(simp_all)
    case Nil thus ?case by simp next
    case (Cons knev t) thus ?case
      apply(case_tac knev)
      apply(simp_all)

lemma

fun unpairMsg :: "execmsg \<Rightarrow> kntrace \<Rightarrow> kntrace"
where
  "unpairMsg (Tup x y) t =
     unpairMsg y (unpairMsg x (
       t @
       (if (\<star> x \<notin> set t \<and> \<Delta> MkFst x y \<notin> set t)
        then [\<Delta> MkFst x y, \<star> x]
        else []
       ) @
       (if (\<star> y \<notin> set t \<and> \<Delta> MkSnd x y \<notin> set t)
        then [\<Delta> MkSnd x y, \<star> y]
        else []
       )
     ))"
| "unpairMsg m t = t"

where
  "unpairTrace [] = []"
  "unpairTrace s [] = []"
| "unpairTrace s (MkStep tid (Send l msg) # es) =
     MkStep tid (Send l msg) #
     unpairMsg (subst s (spec2exec msg tid)) @
     unpairTrace s es"
| "unpairTrace s (MkDecr m k # es) =
     MkDecr m k #
     unpairMsg m @
     unpairTrace s es"
| "unpairTrace s (e # es) = e # unpairTrace s es"

thm reachable_eout_extend_wts

lemma unpairTrace_append [simp]:
  "unpairTrace s (t@t') = unpairTrace s t @ unpairTrace s t'"
  by(induct t rule: unpairTrace.induct, auto)

lemma extend_wts_assoc:
  "extend_wts (extend_wts s s') s'' = extend_wts s (extend_wts s' s'')"
  sorry

lemma reachable_unpairTrace_extend_wts [simp]:
  "(t, r, s) \<in> reachable P
   \<Longrightarrow> unpairTrace (extend_wts s s') t = unpairTrace s t"
  apply(induct arbitrary: s' rule: reachable.induct)
  apply(simp_all add: extend_wts_assoc extend_wts_conv_subst
                      reachable_Send_ground)
  done

lemma knows_unpairTrace_subset:
  "knows s t \<subseteq> knows s (unpairTrace s t)"
  by(induct t rule: unpairTrace.induct, auto)

lemma reachable_append_unpairMsg:
  "\<lbrakk> (t,r,s) \<in> reachable P; m \<in> knows s t \<rbrakk>
   \<Longrightarrow> (t@unpairMsg m, r, s) \<in> reachable P"
proof(induct m arbitrary: t)
  case (Tup x y) show ?case using prems(3-4)
    apply(simp)
    apply(subgoal_tac "t @ MkUnt x y # unpairMsg x @ unpairMsg y =
                       (t @ MkUnt x y # unpairMsg x) @ unpairMsg y")
    apply(simp only:)
    apply(rule prems(2))
    apply(subgoal_tac "t @ MkUnt x y # unpairMsg x =
                       (t @ [MkUnt x y]) @ unpairMsg x")
    apply(simp only:)
    apply(rule prems(1))
    apply(erule reachable.intros)
    apply(simp_all (no_asm))
    done
next
  case Lit thus ?case by simp next
  case Enc thus ?case by simp next
  case Hash thus ?case by simp next
  case SK thus ?case by simp next
  case PK thus ?case by simp next
  case K thus ?case by simp next
qed

lemma reachable_unpairTrace_reachable:
  "(t,r,s) \<in> reachable P \<Longrightarrow>
   (unpairTrace s t, r, s) \<in> reachable P"
proof(induct rule: reachable.induct)
  case init thus ?case by(simp add: reachable.init)
  case (create t r s tid R \<alpha>) thus ?case
    apply(simp)
    apply(rotate_tac 1)
    apply(drule reachable.create)
    apply(simp+)
    apply(subgoal_tac
     "(\<lambda>a. if a = tid then Some (newThread R) else r a) =
      r(tid \<mapsto> newThread R)")
    apply(simp)
    apply(rule ext, simp)
    done
next
  case (recv t r s l msg tid \<alpha>) thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case hash thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case encr thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case tuple thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case untup thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case (decr t r s m k) thus ?case
    apply(simp add: reachable_append_unpairMsg)
    apply(subgoal_tac "unpairTrace s t @ MkDecr m k # unpairMsg m =
                       (unpairTrace s t @ [MkDecr m k]) @ unpairMsg m")
    apply(simp only:)
    apply(rule reachable_append_unpairMsg)
    apply(erule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case (send t r s l msg tid) thus ?case
    apply(simp add: reachable_append_unpairMsg)
    apply(subgoal_tac "unpairTrace s t @ MkStep tid (Send l msg) # unpairMsg (subst s (spec2exec msg tid)) =
                       (unpairTrace s t @ [MkStep tid (Send l msg)]) @ unpairMsg (subst s (spec2exec msg tid))")
    apply(simp only:)
    apply(rule reachable_append_unpairMsg)
    apply(erule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
qed

lemma unpairTrace_charn:
  "\<lbrakk> m \<in> knows s t; m' \<in> unpair m \<rbrakk> \<Longrightarrow>
   m' \<in> knows s (unpairTrace s t)"
  apply(induct m)
  apply(auto elim!: subsetD[OF knows_unpairTrace_subset])
  apply(simp add: knows_conv_eout)
  apply(erule disjE)
  apply(force simp: IK0_def)
  apply(clarsimp)
  apply(case_tac x)
  apply(case_tac rolestep)
  apply(simp_all)
  sorry

fun out :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "out s (MkStep tid (Send lbl msg)) =
     unpair (subst s (spec2exec msg tid))"
| "out s (MkStep tid (Recv lbl msg)) = {}"
| "out s (MkTup  x y)       = unpair x \<union> unpair y"
| "out s (MkUnt  x y)       = unpair x \<union> unpair y"
| "out s (MkHash m)         = {Hash m}"
| "out s (MkEncr m k)       = {Enc m k}"
| "out s (MkDecr m k)       = unpair m"

definition kn' :: "state \<Rightarrow> execmsg \<Rightarrow> bool"
where "kn' q m' = (case q of (t,r,s) \<Rightarrow>
                   \<forall> m \<in> unpair (subst s m').
                     m \<in> IK0 \<or> (\<exists> e \<in> set t. m \<in> out s e))"

lemma out_conv_eout:
  "out s e = (\<Union> m \<in> eout s e. unpair m)"
  by(induct e rule: out.induct, auto)

lemma kn'_conv_knows:
  "kn' (t,r,s) m' =
  (\<forall> m \<in> unpair m'. subst s m \<in> knows s (unpairTrace s t))"
  apply(simp add: kn'_def)
  apply(rule iffI)
  apply(clarify)
  apply(frule unpair_subst_distr)
  apply(drule bspec)
  apply(assumption)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(subgoal_tac "subst s m \<in> knows s t")

section{* Secrecy and Authentication Logic *}

subsection{* Abstract Events *}

datatype logicevent =
   DoStep tid rolestep
 | DoHash execmsg
 | DoEncr execmsg execmsg
 | DoDecr execmsg execmsg

fun substEv :: "wt_subst \<Rightarrow> logicevent \<Rightarrow> logicevent"
where
  "substEv s (DoStep tid step) = DoStep tid step"
| "substEv s (DoHash m)        = DoHash (subst s m)"
| "substEv s (DoEncr m k)      = DoEncr (subst s m) (subst s k)"
| "substEv s (DoDecr m k)      = DoDecr (subst s m) (subst s k)"

fun instEv :: "logicevent \<Rightarrow> execevent"
where
  "instEv (DoStep tid step) = MkStep tid step"
| "instEv (DoHash m)        = MkHash m"
| "instEv (DoEncr m k)      = MkEncr m k"
| "instEv (DoDecr m k)      = MkDecr m k"

fun out :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "out s (MkStep tid (Send lbl msg)) =
     unpair (subst s (spec2exec msg tid))"
| "out s (MkStep tid (Recv lbl msg)) = {}"
| "out s (MkTup  x y)       = unpair x \<union> unpair y"
| "out s (MkUnt  x y)       = unpair x \<union> unpair y"
| "out s (MkHash m)         = {Hash m}"
| "out s (MkEncr m k)       = {Enc m k}"
| "out s (MkDecr m k)       = unpair m"

subsection{* Predicates *}

definition kn :: "state \<Rightarrow> execmsg \<Rightarrow> bool"
where "kn q m' = (case q of (t,r,s) \<Rightarrow>
                   \<forall> m \<in> unpair (subst s m').
                     m \<in> IK0 \<or> (\<exists> e \<in> set t. m \<in> out s e))"

definition ev :: "state \<Rightarrow> logicevent \<Rightarrow> bool"
where "ev q e \<equiv> (case q of (t,r,s) \<Rightarrow>
                  instEv (substEv s e) \<in> set t)"

definition learn :: "state \<Rightarrow> logicevent \<Rightarrow> execmsg \<Rightarrow> bool"
where "learn q e m' \<equiv> (case q of (t,r,s) \<Rightarrow>
                        instEv (substEv s e) \<in> set t \<and>
                        (\<forall> m \<in> unpair (subst s m').
                            m \<in> IK0 \<or>
                            m \<in> out s (instEv (substEv s e)) \<or>
                           (\<exists> e'. (e',(instEv (substEv s e))) \<in> firstOccOrd t \<and>
                                   m \<in> out s e')
                        ) \<and>
                        (\<exists> m \<in> unpair (subst s m').
                           m \<notin> IK0 \<and>
                           m \<in> out s (instEv (substEv s e)) \<and>
                          (\<forall> e'. (e',instEv (substEv s e)) \<in> firstOccOrd t \<longrightarrow>
                                  m \<notin> out s e'
                          )
                        )
                      )"

definition evbefore :: "state \<Rightarrow> logicevent \<Rightarrow> logicevent \<Rightarrow> bool"
where "evbefore q e1 e2 \<equiv> (case q of (t,r,s) \<Rightarrow>
                            (instEv (substEv s e1), instEv (substEv s e2))
                            \<in> firstOccOrd t)"

definition knbefore :: "state \<Rightarrow> execmsg \<Rightarrow> logicevent \<Rightarrow> bool"
where "knbefore q m' e \<equiv> (case q of (t,r,s) \<Rightarrow>
                           instEv (substEv s e) \<in> set t \<and>
                           (\<forall> m \<in> unpair (subst s m').
                              m \<in> IK0 \<or>
                              (\<exists> e'. (e',instEv (substEv s e)) \<in> firstOccOrd t \<and>
                                     m \<in> out s e'
                              )
                            )
                          )"

definition runs :: "state \<Rightarrow> tid \<Rightarrow> role \<Rightarrow> bool"
where "runs q tid R \<equiv> (case q of (t,r,s) \<Rightarrow>
                        (case r tid of
                          Some (todo,done) \<Rightarrow> Rep_role R = rev done @ todo
                        | None             \<Rightarrow> False))"

subsection{* Properties of Conversion Operators *}

lemma out_conv_eout:
  "out s e = (\<Union> m \<in> eout s e. unpair m)"
  by(induct e rule: out.induct, auto)

lemma reachable_instEv_substEv_extend_wts [simp]:
  "\<lbrakk> (t,r,s) \<in> reachable P; instEv (substEv s e) \<in> set t \<rbrakk>
    \<Longrightarrow> instEv (substEv (extend_wts s s') e) = instEv (substEv s e)"
  apply(induct e rule: substEv.induct)
  apply(auto simp: extend_wts_conv_subst
             dest!: reachable_eventMsg_ground)
  done

subsection{* Rules *}

subsubsection{* Simplification *}

lemma kn_simps [simp]:
  "kn q (Tup x y) = (kn q x \<and> kn q y)"
  "kn q (Lit (EConst c))"
  "kn q (Lit (EHonest a))"
  "kn q (Lit (EveNonce n))"
  "kn q (SK (Lit Eve))"
  "kn q (PK (Lit (EHonest a)))"
  "kn q (K (Lit (EHonest a)) (Lit Eve))"
  "kn q (K (Lit Eve) (Lit (EHonest a)))"
  apply(cases q, simp add: add kn_def ball_Un)
  by(cases q, simp add: IK0_def kn_def image_def)+

lemma knbefore_simps:
  "knbefore q (Tup x y) e = (knbefore q x e \<and> knbefore q y e)"
  "ev q e \<Longrightarrow> knbefore q (Lit (EConst c)) e"
  "ev q e \<Longrightarrow> knbefore q (Lit (EHonest a)) e"
  "ev q e \<Longrightarrow> knbefore q (Lit (EveNonce n)) e"
  "ev q e \<Longrightarrow> knbefore q (SK (Lit Eve)) e"
  "ev q e \<Longrightarrow> knbefore q (PK (Lit (EHonest a))) e"
  "ev q e \<Longrightarrow> knbefore q (K (Lit (EHonest a)) (Lit Eve)) e"
  "ev q e \<Longrightarrow> knbefore q (K (Lit Eve) (Lit (EHonest a))) e"
  apply(cases q, simp add: knbefore_def, force)
  by(cases q, simp add: IK0_def knbefore_def image_def ev_def)+

subsubsection{* Purely Logical *}

lemma evbeforeD1: "evbefore q e1 e2 \<Longrightarrow> ev q e1"
  by(auto dest: in_set_firstOccOrd1 simp: evbefore_def ev_def)

lemma evbeforeD2: "evbefore q e1 e2 \<Longrightarrow> ev q e2"
  by(auto dest: in_set_firstOccOrd2 simp: evbefore_def ev_def)

lemma knbeforeD1: "knbefore q m e \<Longrightarrow> kn q m"
  by(auto dest!: in_set_firstOccOrd1 simp: knbefore_def kn_def)

lemma knbeforeD2: "knbefore q m e \<Longrightarrow> ev q e"
  by(auto dest!: in_set_firstOccOrd2 simp: knbefore_def ev_def)

lemma learnD1: "learn q e m \<Longrightarrow> ev q e"
  by(auto simp: learn_def ev_def)

lemma learnD2: "learn q e m \<Longrightarrow> kn q m"
  by(auto dest!: in_set_firstOccOrd1 simp add: learn_def kn_def)

lemma ebefore_irr: "\<not>evbefore q e e"
  by(auto simp: evbefore_def)

lemma ebefore_trans: "\<lbrakk> evbefore q e1 e2; evbefore q e2 e3 \<rbrakk> \<Longrightarrow> evbefore q e1 e3"
  by(auto simp: evbefore_def intro: firstOccOrd_trans)

lemma learn_fun:
  "\<lbrakk> learn q e1 m; learn q e2 m \<rbrakk>
  \<Longrightarrow> instEv (substEv (sts q) e1) = instEv (substEv (sts q) e2)"
  apply(clarsimp simp: learn_def)
  apply(drule firstOccOrd_cases)
  apply(assumption)
  apply(erule disjE)
  apply(simp)
  apply(erule disjE)
  apply(thin_tac "\<forall> x \<in> ?X. ?P x")
  apply(drule_tac x=ma in bspec)
  apply(force)
  apply(simp)
  apply(force)
  apply(auto)
  by(auto simp: learn_def dest: firstOccOrd_cases)

lemma learn_knbefore_evbefore:
  "\<lbrakk> learn q e1 m; knbefore q m e2 \<rbrakk> \<Longrightarrow> evbefore q e1 e2"
  apply(clarsimp simp: learn_def knbefore_def evbefore_def)
  apply(drule_tac y="instEv (substEv ya e2)" in firstOccOrd_cases)
  apply(drule in_set_firstOccOrd2, simp)
  apply(safe)
  apply(force)
  apply(subgoal_tac "(e', instEv (substEv ya e1)) \<in> firstOccOrd xa")
  apply(force)
  apply(rule firstOccOrd_trans)
  apply(auto)
  done

lemma runs_fun: "\<lbrakk> runs q tid R1; runs q tid R2 \<rbrakk> \<Longrightarrow> R1 = R2"
  by(auto simp: runs_def Rep_role_inject[symmetric] split: option.splits )

subsubsection{* Role Order *}

lemma evbefore_roleOrd:
  "\<lbrakk> ev q (DoStep tid step);  runs q tid R;
     (prev, step) \<in> roleOrd R; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> evbefore q (DoStep tid prev) (DoStep tid step)"
  apply(clarsimp simp: ev_def evbefore_def firstOccOrd_def runs_def
                split: option.splits)
  apply(rename_tac t r s todo "done")
  apply(unfold roleOrd_def)
  apply(rule reachable_roleOrd)
  apply(assumption)
  apply(assumption)
  apply(auto dest: reachable_todo_notin_trace reachable_done_in_trace in_set_listOrd2)
  done

subsubsection{* Inp'ut Messages *}

fun einp' :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "einp' s (MkStep tid (Send l m)) = {}"
| "einp' s (MkStep tid (Recv l m)) = {subst s (spec2exec m tid)}"
| "einp' s (MkHash m)              = {m}"
| "einp' s (MkTup x y)             = {x, y}"
| "einp' s (MkUnt x y)             = {Tup x y}"
| "einp' s (MkEncr m k)            = {m, k}"
| "einp' s (MkDecr m k)            = {Enc m k, inv k}"

fun inp' :: "logicevent \<Rightarrow> execmsg set"
where
  "inp' (DoStep tid (Send l m)) = {}"
| "inp' (DoStep tid (Recv l m)) = unpair (spec2exec m tid)"
| "inp' (DoHash m)            = unpair m"
| "inp' (DoEncr m k)          = unpair m \<union> unpair k"
| "inp' (DoDecr m k)          = insert (Enc m k) (unpair (inv k))"

lemma einp'_ground_by_eventMsg_ground:
  "\<lbrakk> m \<in> einp' s e; ground (eventMsg s e) \<rbrakk> \<Longrightarrow> ground m"
  by(induct e rule: einp'.induct, auto)

lemma reachable_einp'_extend_wts [simp]:
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t \<rbrakk>
    \<Longrightarrow> einp' (extend_wts s s') e = einp' s e"
  apply(induct rule: einp'.induct)
  apply(auto dest: reachable_eventMsg_ground
             simp: extend_wts_conv_subst)
  done

lemma reachable_knows_einp':
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t; m \<in> einp' s e \<rbrakk>
   \<Longrightarrow> m \<in> knows s t"
thm reachable_knows_extend_wts

thm reachable_einp'_extend_wts

  by(induct arbitrary: e rule: reachable.induct, auto)

lemma reachable_knows_before_einp':
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t; m \<in> einp' s e \<rbrakk>
   \<Longrightarrow>
   m \<in> IK0 \<or> (\<exists> e' \<in> set t. (e', e) \<in> firstOccOrd t \<and> m \<in> eout s e')"
  apply(induct arbitrary: e m rule: reachable.induct)
  apply(simp_all)
  apply(erule disjE, simp)
  apply(force intro!: firstOccOrd_appendI1)
  apply((thin_tac "dom_wts ?x = ?X")?, (thin_tac "ran_wts ?x = ?X")?)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  done

lemma Recv_knbefore:
  "\<lbrakk>  ev q (DoStep tid (Recv l msg));
      m \<in> unpair (spec2exec msg tid);
      q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoStep tid (Recv l msg))"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp', assumption, simp)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Hash_knbefore:
  "\<lbrakk>  ev q (DoHash m'); m \<in> unpair m'; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoHash m')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp', assumption, simp)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Encr_knbefore_msg:
  "\<lbrakk>  ev q (DoEncr m' k'); m \<in> unpair m'; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoEncr m' k')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp', assumption)
  apply(simp, rule disjI1, rule refl)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Encr_knbefore_key:
  "\<lbrakk>  ev q (DoEncr m' k'); m \<in> unpair k'; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoEncr m' k')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp', assumption)
  apply(simp, rule disjI2, rule refl)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Decr_knbefore_enc:
  "\<lbrakk>  ev q (DoDecr m k); q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q (Enc m k) (DoDecr m k)"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp', assumption)
  apply(simp, rule disjI1, rule refl)
  apply(force simp: out_conv_eout knows_conv_eout)
  done

lemma Decr_knbefore_key:
  "\<lbrakk>  ev q (DoDecr m' k'); m \<in> unpair (inv k'); q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoDecr m' k')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp', assumption)
  apply(simp, rule disjI2, rule refl)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemmas Hash_kn = knbeforeD1[OF Hash_knbefore, rule_format]

subsubsection{* Decryption Chains *}

types chain = "(specmsg \<times> specmsg) list \<times> specmsg"

fun msgChains :: "specmsg \<Rightarrow> chain list"
where
  "msgChains (Lit (SNonce n))      = [([], Lit (SNonce n))]"
| "msgChains (Lit (SVar (MVar n))) = [([], Lit (SVar (MVar n)))]"
| "msgChains (Lit _)               = []"
| "msgChains (Tup x y) = msgChains x @ msgChains y"
| "msgChains (Enc m k) =
     ([], Enc m k) #
     map (\<lambda> (encs,end). ((m,k)#encs,end)) (msgChains m)"
| "msgChains (Hash m)  = [([], Hash m)]"
| "msgChains (K a b)   = [([], K a b) ]"
| "msgChains (PK a)    = [([], PK a)  ]"
| "msgChains (SK a)    = [([], SK a)  ]"

fun chainStart :: "chain \<Rightarrow> specmsg"
where
  "chainStart ([],start)  = start"
| "chainStart ((m,k)#_,_) = Enc m k"

fun chainEnd :: "chain \<Rightarrow> specmsg"
where
  "chainEnd (_,end) = end"

lemma chainEnd_in_parts:
  "c \<in> set (msgChains msg) \<Longrightarrow> chainEnd c \<in> parts msg"
  apply(induct msg arbitrary: c, case_tac lit)
  apply(auto)
  by(case_tac varid, auto)

(* if there are no long-term-keys in the parts of the message
   then chain end is not part of it *)
lemma no_ltkeys_chainEnd:
  "\<lbrakk> no_ltkeys msg; c \<in> set (msgChains msg) \<rbrakk> \<Longrightarrow>
   K a b \<noteq> chainEnd c \<and> PK a \<noteq> chainEnd c \<and> SK a \<noteq> chainEnd c"
  apply(induct msg arbitrary: c, case_tac lit)
  apply(simp_all)
  apply(case_tac varid)
  by(simp+, force+)

fun chain :: "state \<Rightarrow> tid \<Rightarrow> chain \<Rightarrow> bool"
where
  "chain q tid ([],      _  ) = True"
| "chain q tid ([(m,k)], end) =
     learn q (DoDecr (spec2exec m tid)
                     (spec2exec k tid))
             (spec2exec end tid)"
| "chain q tid ((m,k)#(m',k')#encs, end) =
    (learn q (DoDecr (spec2exec m tid)
                     (spec2exec k tid))
             (spec2exec (Enc m' k') tid)
     \<and> chain q tid ((m',k')#encs, end)
    )"

lemma kn_rolemap_inv:
  "kn (t, r', s) m \<Longrightarrow> kn (t, r, s) m"
  by(simp add: kn_def)

(*
lemma reachable_kn_extend_wts [simp]:
  "\<lbrakk> (t,r,s) \<in> reachable P \<rbrakk>
  \<Longrightarrow> kn (t,r, extend_wts s s') m = kn (t,r,s) m"
  apply(simp add: kn_def)

*)

lemma kn_substI: "kn q m \<Longrightarrow> kn q (subst (sts q) m)"
  by(auto simp: kn_def)

lemma kn_substE:
  "\<lbrakk> kn q (subst s m); subst (sts q) (subst s m) = subst (sts q) m \<rbrakk>
  \<Longrightarrow> kn q m"
  by(auto simp: kn_def)

thm extend_wts_conv_subst

lemma subst_subdomain:
  "dom_wts s' \<subseteq> dom_wts s \<Longrightarrow> subst s' (subst s m) = subst s m"
  apply(induct m rule: subst.induct, simp_all)
  apply(case_tac "l \<in> dom_wts s")
  apply(auto simp: dom_wts_def)
  done

lemma substEv_subdomain:
  "dom_wts s' \<subseteq> dom_wts s \<Longrightarrow> substEv s' (substEv s e) = substEv s e"
  by(induct e rule: substEv.induct, auto intro!: subst_subdomain)

lemma reachable_kn_extend_wts [simp]:
  "(t,r,s) \<in> reachable P \<Longrightarrow>
   kn (t,r,extend_wts s s') m = kn (t,r,s) (subst (extend_wts s s') m)"
  apply(subgoal_tac "subst s (subst (extend_wts s s') m) =
                     subst (extend_wts s s') m")
  apply(auto simp: kn_def out_conv_eout
           intro!: subst_subdomain)
  done

lemma reachable_learn_extend_wts [simp]:
  "(t,r',s) \<in> reachable P \<Longrightarrow>
   learn (t,r,extend_wts s s') e m =
   learn (t,r',s) (substEv (extend_wts s s') e) (subst (extend_wts s s') m)"
  apply(subgoal_tac "subst s (subst (extend_wts s s') m) =
                     subst (extend_wts s s') m")
  apply(subgoal_tac "substEv s (substEv (extend_wts s s') e) =
                     substEv (extend_wts s s') e")
  apply(simp add: learn_def out_conv_eout)
  apply(rule iffI)
  apply(force dest: in_set_firstOccOrd1)
  apply(force dest: in_set_firstOccOrd1)
  apply(auto intro!: substEv_subdomain subst_subdomain)
  done

lemma Rep_wt_subst_atomic: "\<exists> l'. Rep_wt_subst s l = Lit l'"
  apply(insert Rep_wt_subst_welltyped[of s])
  apply(simp add: welltyped_def)
  apply(drule_tac x=l in spec, auto)
  done

lemma Rep_wt_subst_noteq_simps [simp]:
  "Rep_wt_subst s l \<noteq> Hash m"
  "Rep_wt_subst s l \<noteq> Enc m k"
  "Rep_wt_subst s l \<noteq> Tup x y"
  "Rep_wt_subst s l \<noteq> PK a"
  "Rep_wt_subst s l \<noteq> SK a"
  "Rep_wt_subst s l \<noteq> K a b"
  by(insert Rep_wt_subst_atomic[of s l], auto)

lemma kn_append_cases:
  "kn (t@t', r, s) m \<Longrightarrow>
   kn (t, r, s) m \<or>
   (\<exists> e \<in> set t'. e \<notin> set t \<and> subst s m \<in> out s e)"
  by(auto simp: kn_def)

lemma firstOccOrd_Nil [simp]: "firstOccOrd [] = {}"
  by(simp add: firstOccOrd_def)

lemma firstOccOrd_Snoc1 [simp]:
  "x \<in> set xs \<Longrightarrow> firstOccOrd (xs@[x]) = firstOccOrd xs"
  by(induct xs rule: rev_induct, auto simp: firstOccOrd_def)

lemma firstOccOrd_Snoc2 [simp]:
  "x \<notin> set xs \<Longrightarrow>
   firstOccOrd (xs@[x]) = firstOccOrd xs \<union> { (y,x) | y. y \<in> set xs }"
  by(induct xs rule: rev_induct, auto simp: firstOccOrd_def)

thm if_splits(1)

lemma firstOccOrd_splits:
  "P (firstOccOrd (xs@[x])) =
   ((x \<in> set xs \<longrightarrow> P (firstOccOrd xs)) \<and>
    (x \<notin> set xs \<longrightarrow> P (firstOccOrd xs \<union> { (y,x) | y. y \<in> set xs })))"
  by(auto, case_tac "x \<in> set xs", auto)

lemma firstOccOrd_decomp:
  "(e,e') \<in> firstOccOrd t
  \<Longrightarrow> \<exists> xs ys zs. t = xs@e#ys@e'#zs \<and>
                  e \<notin> set xs \<and> e' \<notin> set xs \<and> e \<noteq> e' \<and> e' \<notin> set ys"
  apply(induct t rule: rev_induct)
  apply(auto split: firstOccOrd_splits)
  apply(case_tac "x \<in> set xs")
  apply(simp_all)
  apply(force)
  apply(erule disjE)
  apply(force)
  apply(clarsimp)
  apply(drule split_list_first)
  apply(clarsimp)
  apply(auto)
  done

lemma append_eq_append_before_first:
  "\<lbrakk> vs @ y#ws = xs @ y#ys; y \<notin> set vs; y \<notin> set xs;
     x \<in> set xs \<rbrakk>
   \<Longrightarrow> x \<in> set vs"
  apply(simp add: append_eq_append_conv2)
  apply(auto)
  apply(case_tac us)
  apply(auto)
  done

lemma firstOccOrd_appendD1:
  "\<lbrakk> (e,e') \<in> firstOccOrd (t@t'); e' \<in> set t \<rbrakk> \<Longrightarrow> (e,e') \<in> firstOccOrd t"
  apply(drule firstOccOrd_decomp)
  apply(clarsimp)
  apply(drule split_list_first)
  apply(clarsimp)
  apply(rule firstOccOrd_appendI2)
  apply(simp_all)
  apply(simp add: append_eq_append_conv2)
  apply(auto)
  apply(case_tac us, auto)
  apply(case_tac us, auto)
  done

lemma learn_appendI1:
  "learn (t,r,s) e m \<Longrightarrow> learn (t@t', r', s) e m"
  by(auto simp: learn_def dest: firstOccOrd_appendD1)

lemma learn_Snoc_MkTup [simp]:
  "learn (t@[MkTup x y],r,s) = learn (t,r,s)"
  apply(rule ext, rule ext, rename_tac e m, case_tac e)
  by(auto simp: learn_def split: firstOccOrd_splits)

lemma learn_Snoc_MkUnt [simp]:
  "learn (t@[MkUnt x y],r,s) = learn (t,r,s)"
  apply(rule ext, rule ext, rename_tac e m, case_tac e)
  by(auto simp: learn_def split: firstOccOrd_splits)

lemma runs_free_args:
  "runs (t',r,s') = runs (t,r,s)"
  by(rule ext,rule ext, simp add: runs_def)

(* TODO: Using Isar this lemma should be removed *)
lemma chain_Snoc_MkTup_aux [rule_format]:
  "q = (t,r,s) \<longrightarrow>
   chain (t@[MkTup x y],r,s) tid c = chain q tid c"
  by(induct c rule: chain.induct, auto)

lemma chain_Snoc_MkTup [simp]:
  "chain (t@[MkTup x y],r,s) = chain (t,r,s)"
  by(rule ext, rule ext, auto intro!: chain_Snoc_MkTup_aux)

thm kn_def

lemma learn:
  "\<lbrakk> (t,r,s) \<in> reachable P; kn (t,r,s) m' \<rbrakk> \<Longrightarrow>
   subst s m' \<in> IK0 \<or>
   (\<exists> m.   m' = Hash m   \<and> learn (t,r,s) (DoHash m)   (Hash m)) \<or>
   (\<exists> m k. m' = Enc  m k \<and> learn (t,r,s) (DoEncr m k) (Enc m k)) \<or>
   (\<exists> R \<in> P. \<exists> l msg. Send l msg \<in> roleEvs R \<and>
      (\<exists> c \<in> set (msgChains msg). \<exists> tid.
         runs (t,r,s) tid R \<and>
         learn (t,r,s) (DoStep tid (Send l msg))
                       (spec2exec (chainStart c) tid) \<and>
         chain (t,r,s) tid c \<and>
         subst s m' = subst s (spec2exec (chainEnd c) tid)
      )
   )"
proof (induct arbitrary: m' rule: reachable.induct)
  case init thus ?case by(simp add: kn_def)
next
  case (tuple t r s x y) thus ?case
    apply(simp)
    apply(subst runs_free_args[where t=t and s=s])

next
  case (hash t r s m) thus ?case
    apply(insert kn_append_cases[OF prems(4)])
    apply(erule disjE)
    apply(drule prems(2))
    apply(erule disjE)
    apply(simp)
    apply(erule disjE)
    apply(rule disjI2, rule disjI1)
    apply(simp add: learn_def)
    apply(clarsimp)

    apply(insert prems(1))
    apply(rule disjI2, rule disjI1)

  case (create t r s tid R \<alpha>) show ?case using prems(1,7)
    apply(drule_tac r=r in kn_rolemap_inv)
    apply(simp)
    apply(drule prems(2))
    apply(erule disjE)
    apply(subst (asm) subst_subdomain)
    apply(force)
    apply(simp)
    apply(erule disjE)
    apply(rule disjI2,rule disjI1)
    apply(clarsimp)
    apply(cases m')
    apply(simp_all)
    apply(erule disjE)
    apply(rule disjI2, rule disjI2, rule disjI1)
    apply(cases m')
    apply(simp_all)
    apply(rule disjI2, rule disjI2, rule disjI2)
    apply(clarsimp)
    apply(case_tac "tida = tid")
    apply(clarsimp)
    apply(insert prems(3))
    apply(force simp: runs_def dom_def split: option.splits)
    apply(rule bexI)
    apply(rule exI, rule exI, rule conjI)
    apply(assumption)
    apply(rule_tac x="(a,b)" in bexI)
    apply(rule_tac x="tida" in exI)
    apply(simp add: runs_def)
    sorry
next

thm reachable_eout_extend_wts

    apply(simp add: kn_def out_conv_eout)
  sorry

lemma learn_Hash:
  "\<lbrakk> q \<in> reachable P; kn q (Hash m) \<rbrakk> \<Longrightarrow>
   learn q (DoHash m) (Hash m) \<or>
   (\<exists> R \<in> P. \<exists> l msg. Send l msg \<in> roleEvs R \<and>
      (\<exists> c \<in> set (msgChains msg). \<exists> tid.
         runs q tid R \<and>
         learn q (DoStep tid (Send l msg)) (spec2exec (chainStart c) tid) \<and>
         chain q tid c \<and>
         Hash (subst (sts q) m)  = subst (sts q) (spec2exec (chainEnd c) tid)
      )
   )"
  apply(drule learn, assumption)
  by(auto simp: IK0_def)

lemma learn_SK:
  "\<lbrakk> q \<in> reachable P; kn q (SK a) \<rbrakk> \<Longrightarrow>
   subst (sts q) a = Lit Eve"
  apply(drule learn, assumption)
  apply(auto)
  apply(force simp: IK0_def)
  apply(case_tac b, case_tac lit)
  apply(simp_all)
  apply(insert Rep_wt_subst_welltyped[of "sts q"])
  apply(simp add: welltyped_def)
  apply(drule_tac x="EVar varid tid" in spec)
  apply(force)
  apply(simp add: roleEvs_def)
  apply(drule Rep_role_Send_no_ltkeys)
  apply(drule no_ltkeys_chainEnd)
  apply(assumption)
  apply(force)
  done


theory Sequence = Main:

ML"fun no_subgoals thm = \
       let fun count_prems (Const (\"==>\",_) $ _ $ t) = 1+count_prems t  \
             | count_prems _ = 0 \
       in count_prems(#prop(rep_thm thm))  \
       end"

ML"fun build_tactic tac = \
   Method.ctxt_args (fn ctxt => ((context (ProofContext.theory_of ctxt); Method.METHOD (fn facts => tac))))"

ML"fun force_simp_fun thm = let val n=no_subgoals thm val thms = Asm_full_simp_tac 1 thm in \
                            case Seq.pull thms of None => Seq.empty \
                                  | Some (x,_) => if n=no_subgoals x then Seq.empty else thms end"

ML"fun init2_fun thm = let val thms = (REPEAT (rtac allI 1 ORELSE rtac impI 1)) thm in \
                            thms end"

ML"fun solve_fun thm = let val thms = (((REPEAT ((eatac exE 0 1 ORELSE rtac conjI 1) ORELSE eatac conjE 0 1)) THEN TRY (Asm_full_simp_tac 1)) THEN ((REPEAT ((eatac exE 0 1 ORELSE rtac conjI 1) ORELSE eatac conjE 0 1)) THEN TRY (Asm_full_simp_tac 1))) thm in \
                            thms end"

ML"fun init_fun thm = let val thms = (TRY((Asm_full_simp_tac 1) ORELSE ((solve_fun) THEN (blast_tac (claset ()) 1))) THEN (init2_fun)) thm in \
                            thms end"

ML"fun close_fun thm = let val thms = (REPEAT (rtac disjI1 1 ORELSE rtac disjI2 1) THEN REPEAT (eatac exE 0 1 ORELSE eatac conjE 0 1) THEN (force_simp_fun)) thm in \
                            thms end"
ML"fun step_fun thm = let val thms = (REPEAT (rtac disjI2 1) THEN (instantiate_tac [(\"R\" , \"Rcs union (Trans ?R)\" )])) thm in \
                            thms end"

ML"fun xy_exI_fun thm = let val thms = ((res_inst_tac [(\"x\",\"x\")] exI 1) THEN (res_inst_tac [(\"x\",\"y\")] exI 1)) thm in \
                            thms end"

ML"fun close_or_step_fun thm = let val thms = ((close_fun) ORELSE ((solve_fun) THEN ((close_fun) ORELSE ((step_fun) THEN TRY (solve_fun) THEN TRY (rtac disjI2 1) THEN TRY (solve_fun) THEN TRY (xy_exI_fun) THEN (solve_fun) THEN TRY (close_fun))))) thm in \
                           thms end"

ML"fun finish_fun thm = let val thms = ((instantiate_tac [(\"R\" , \"(BinRelImage tl (%x y. False))\" )]) THEN (solve_fun) THEN TRY(close_fun)) thm in \
                            thms end"

ML"fun breakup_fun thm = let val thms = ((Asm_full_simp_tac 1) THEN (REPEAT (eatac exE 0 1 ORELSE eatac conjE 0 1)) THEN (eatac disjE 0 1)) thm in \
                            thms end"

ML"fun solveb_fun thm = let val thms = (TRY (Asm_full_simp_tac 2)) thm in \
                            thms end"

method_setup force_simp = "build_tactic (force_simp_fun)" "simp + check if no_subgoal changed"
method_setup init = "build_tactic (init_fun)" "(simp|(solve,blast))?,init2_fun?"
method_setup init2 = "build_tactic (init2_fun)" "((allI|impI)+)?"
method_setup solve= "build_tactic (solve_fun)" "((exE|conjE|conjI)+)?,(simp)?,((exE|conjE|conjI)+)?,(simp)?"
method_setup close= "build_tactic (close_fun)" "((disjI1|disjI2)+)?,((exE|conjE)+)?,force_solve"
method_setup close_or_step= "build_tactic (close_or_step_fun)" "close|(solve,(close|(step,solve?,disjI2?,solve?,xy_exi?,solve,close?)))"
method_setup solveb= "build_tactic (solveb_fun)" "(simp)?"
method_setup finish = "build_tactic (finish_fun)" "inst r false,solve1"
method_setup step = "build_tactic (step_fun)" "((disjI2)+)?,inst r (rcs union (trans r))"
method_setup breakup = "build_tactic (breakup_fun)" "simp,((exE|conjE)+)?,disjE"
method_setup xy_exI = "build_tactic (xy_exI_fun)" "rule_tac x=x in exI, rule_tac x=y n exI"

typedecl "Elem"
typedecl "Sequence"
typedecl "Unit"
consts
"unit" :: "Unit"
"nil" :: "Unit => Sequence"
"cons" :: "Elem => Sequence => Sequence"
"hd" :: "Sequence => Elem"
"tl" :: "Sequence => Sequence"
"stop" :: "Sequence => Unit"
"conc" :: "Sequence => Sequence => Sequence"
"map" :: "(Elem => Elem) => Sequence => Sequence"
"iterate" :: "(Elem => Elem) => Elem => Sequence"

consts
  BinRelImage :: "('a => 'b) => ('a => 'a => bool) => ('b => 'b => bool)"
  Trans :: "('a => 'a => bool) => ('b => 'b => bool)"
  union :: "('a => 'a => bool)  => ('a => 'a => bool) => ('a => 'a => bool)" (infixl 20)
defs
  BinRelImage_def [simp] : "BinRelImage f R == %x y . EX u v . R u v & x = f u & y = f v"
  Trans_def [simp] : "Trans R == (BinRelImage tl R)"
  union_def [simp] : "R union S == % x y . R x y | S x y"

axioms
map_hd [simp]:  "!! f :: Elem => Elem . !! s :: Sequence . !! a :: Elem . (hd s)=a ==> (hd (map f s)) = (f a)"
map_tl [simp]:  "!! f :: Elem => Elem . !! s1 :: Sequence . !! s2 :: Sequence . (tl s1)=s2 ==> (tl (map f s1)) = (map f s2)"
map_stop [simp]:  "!! f :: Elem => Elem . !! s :: Sequence .  (stop s)=unit ==> (stop (map f s)) = unit"
iterate_hd [simp]:  "!! f :: Elem => Elem . !! a :: Elem . (hd (iterate f a)) = (f a)"
iterate_tl [simp]:  "!! f :: Elem => Elem . !! a :: Elem . (tl (iterate f a)) = (iterate f (f a))"
conc_hd_1 [simp]: "!! s1 :: Sequence . !! s2 :: Sequence . !! a :: Elem . (hd s1)=a ==> hd(conc s1 s2)=a"
conc_hd_2 [simp]: "!! s1 :: Sequence . !! s2 :: Sequence . !! b :: Elem . (stop s1)=unit & (hd s2)=b  ==> hd(conc s1 s2)=b"
conc_tl_1 [simp]: "!! s1 :: Sequence . !! s2 :: Sequence . !! s3 :: Sequence . (tl s1)=s3 ==> tl(conc s1 s2)=(conc s3 s2)"
conc_tl_2 [simp]: "!! s1 :: Sequence . !! s2 :: Sequence . !! s4 :: Sequence . (stop s1)=unit & (tl s2)=s4  ==> tl(conc s1 s2)=s4"
conc_stop [simp]: "!! s1 :: Sequence . !! s2 :: Sequence . (stop s1)=unit & (stop s2)=unit ==> stop(conc s1 s2)=unit"

ga_cogenerated_Sequence: "!! R :: Sequence => Sequence => bool . !! u :: Sequence . !! v :: Sequence . ! x :: Sequence . ! y :: Sequence . ((R x) y) --> ((hd x = hd y) & ((R (tl x)) (tl y)))  ==> ((R u) v) ==> u = v"
ga_selector_hd: "!! X1 :: Elem . !! X2 :: Sequence . (hd (cons X1 X2)) = X1"
ga_selector_tl: "!! X1 :: Elem . !! X2 :: Sequence . (tl (cons X1 X2)) = X2"
ga_selector_stop: "!! X1 :: Elem . !! X2 :: Sequence . (stop (nil(unit))) = unit"

consts Ri :: "[Sequence, Sequence] => bool"
defs Ri_def [simp] : "Ri == % x y . ( ? f a . x = (map f (iterate f a)) & y = (iterate f (f a)))"

theorem Sequence_map_iterate: "!! f :: (Elem => Elem) . !! a :: Elem . map f (iterate f a) = iterate f (f a)"
apply(rule_tac R="?Rzero" in ga_cogenerated_Sequence)
apply(tactic "instantiate_tac [(\"Rzero\" , \"% s1 s2. Ri union (Trans ?R)\" )]")
defer
apply(solve)
apply(blast)
apply(init2)

apply(breakup)

apply(solve)
apply(rule disjI1)
apply(blast)

apply(finish)

done

consts R0 :: "[Sequence, Sequence] => bool"
defs R0_def [simp] : "R0 == % x y . ( ? s1 s2 s3 . x = (conc (conc s1 s2) s3) & y = (conc s1 (conc s2 s3)) )"

theorem Sequence_Conc: "!! s1 :: Sequence . !! s2 :: Sequence . !! s3 :: Sequence . conc (conc s1 s2) s3 = conc s1 (conc s2 s3)"
apply(rule_tac R="?Rzero" in ga_cogenerated_Sequence)
apply(tactic "instantiate_tac [(\"Rzero\" , \"% s1 s2 s3. R0 union (Trans ?R)\" )]")
defer
apply(solve)
apply(blast)
apply(init2)

apply(breakup)

apply(solve)
apply(rule disjI1)
apply(blast)

apply(finish)

done

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Code Generation\<close>

theory Export_Code
  imports Main LTL_Compat LTL_Rabin_Impl
    "HOL-Library.AList_Mapping" (* Future, Performance: Replace by LC *)
    LTL.Rewriting
    "HOL-Library.Code_Target_Numeral"
begin

subsection \<open>External Interface\<close>

\<comment> \<open>Fix the type to match the type of the LTL parser\<close>

definition
  "ltlc_to_rabin eager mode (\<phi>\<^sub>c :: String.literal ltlc) \<equiv>
    (let
      \<phi>\<^sub>n = ltlc_to_ltln \<phi>\<^sub>c;
      \<Sigma> = map set (subseqs (atoms_list \<phi>\<^sub>n));
      \<phi> = ltln_to_ltl (simplify mode \<phi>\<^sub>n)
     in
      (if eager then ltl_to_generalized_rabin\<^sub>C_af\<^sub>\<UU> \<Sigma> \<phi> else ltl_to_generalized_rabin\<^sub>C_af \<Sigma> \<phi>))"

theorem ltlc_to_rabin_exec_correct:
  assumes "range w \<subseteq> Pow (atoms_ltlc \<phi>\<^sub>c)"
  shows "w \<Turnstile>\<^sub>c \<phi>\<^sub>c \<longleftrightarrow> accept\<^sub>G\<^sub>R_LTS (ltlc_to_rabin eager mode \<phi>\<^sub>c) w"
  (is "?lhs = ?rhs")
proof -
  let ?\<phi>\<^sub>n = "ltlc_to_ltln \<phi>\<^sub>c"
  let ?\<Sigma> = "map set (subseqs (atoms_list ?\<phi>\<^sub>n))"
  let ?\<phi> = "ltln_to_ltl (simplify mode ?\<phi>\<^sub>n)"

  have "set ?\<Sigma> = Pow (atoms_ltln ?\<phi>\<^sub>n)"
    unfolding atoms_list_correct[symmetric] subseqs_powset[symmetric] list.set_map ..
  hence R: "range w \<subseteq> set ?\<Sigma>"
    using assms ltlc_to_ltln_atoms[symmetric] by metis

  have "w \<Turnstile>\<^sub>c \<phi>\<^sub>c \<longleftrightarrow> w \<Turnstile> ?\<phi>"
    by (simp only: ltlc_to_ltln_semantics simplify_correct ltln_to_ltl_semantics)
  also
  have "\<dots> \<longleftrightarrow> ?rhs"
    using ltl_to_generalized_rabin\<^sub>C_af\<^sub>\<UU>_correct[OF R] ltl_to_generalized_rabin\<^sub>C_af_correct[OF R]
    unfolding ltlc_to_rabin_def Let_def by auto
  finally
  show ?thesis
    by simp
qed

subsection \<open>Normalize Equivalence Classes During DFS-Search\<close>

fun norm_rep
where
  "norm_rep (i, (q, \<nu>, p)) (q', \<nu>', p') = (
    let
      eq_q = (q = q'); eq_p = (p = p');
      q'' = if eq_q then q' else if q = p' then p' else q;
      p'' = if eq_p then p' else if p = q' then q' else p
    in
      (i | (eq_q & eq_p & \<nu> = \<nu>'), q'', \<nu>, p''))"

fun norm_fold :: "('a, 'b) transition \<Rightarrow> ('a, 'b) transition list \<Rightarrow> (bool * 'a * 'b * 'a)"
where
  "norm_fold (q, \<nu>, p) xs = foldl_break norm_rep fst (False, q, \<nu>, if q = p then q else p) xs"

definition norm_insert :: "('a, 'b) transition \<Rightarrow> ('a, 'b) transition list \<Rightarrow> (bool * ('a, 'b) transition list)"
where
  "norm_insert x xs \<equiv> let (i, x') = norm_fold x xs in if i then (i, xs) else (i, x' # xs)"

lemma norm_fold:
  "norm_fold (q, \<nu>, p) xs = ((q, \<nu>, p) \<in> set xs, q, \<nu>, p)"
proof (induction xs rule: rev_induct)
  case (snoc x xs)
    obtain q' \<nu>' p' where x_def: "x = (q', \<nu>', p')"
      by (blast intro: prod_cases3)
    show ?case
      using snoc by (auto simp add: x_def foldl_break_append)
qed simp

lemma norm_insert:
  "norm_insert x xs = (x \<in> set xs, List.insert x xs)"
proof -
  obtain q \<nu> p where x_def: "x = (q, \<nu>, p)"
    by (blast intro: prod_cases3)
  show ?thesis
    unfolding x_def norm_insert_def norm_fold by simp
qed

declare list_dfs_def [code del]
declare norm_insert_def [code_unfold]

lemma list_dfs_norm_insert [code]:
  "list_dfs succ S [] = S"
  "list_dfs succ S (x # xs) = (let (memb, S') = norm_insert x S in list_dfs succ S' (if memb then xs else succ x @ xs))"
  unfolding list_dfs_def Let_def norm_insert by simp+

subsection \<open>Register Code Equations\<close>

lemmas ltl_to_rabin_base_code_export [code, code_unfold] =
  ltl_to_rabin_base_code_def.ltl_to_generalized_rabin\<^sub>C.simps
  ltl_to_rabin_base_code_def.reachable_transitions\<^sub>C_def
  ltl_to_rabin_base_code_def.mappings\<^sub>C_code
  ltl_to_rabin_base_code_def.delta\<^sub>C.simps
  ltl_to_rabin_base_code_def.initial\<^sub>C.simps
  ltl_to_rabin_base_code_def.Acc_inf\<^sub>C.simps
  ltl_to_rabin_base_code_def.Acc_fin\<^sub>C.simps
  ltl_to_rabin_base_code_def.max_rank_of\<^sub>C_def

lemmas M_fin\<^sub>C_lhs [code del, code_unfold] =
  M_fin\<^sub>C_af\<^sub>\<UU>_lhs_def M_fin\<^sub>C_af_lhs_def

\<comment> \<open>Test code export\<close>
export_code true\<^sub>c Iff_ltlc Nop true Abs AList_Mapping.Mapping set ltlc_to_rabin checking

\<comment> \<open>Export translator (and also constructors)\<close>
export_code true\<^sub>c Iff_ltlc Nop true Abs AList_Mapping.Mapping set ltlc_to_rabin
  in SML module_name LTL file \<open>../Code/LTL_to_DRA_Translator.sml\<close>

end