section {*FUNCTION\_\_SDPDA\_TO\_LR1\_OPT*}
theory
  FUNCTION__SDPDA_TO_LR1_OPT

imports
  PRJ_12_04_06_08__ENTRY

begin

theorem F_SDPDA_TO_LR1_OPT__SOUND: "
  F_SDPDA_TO_LR1_STD__SpecInput G
  \<Longrightarrow> k > 0
  \<Longrightarrow> F_SDPDA_TO_LR1_STD__SpecOutput G (F_SDPDA_TO_LR1_OPT G k)"
  apply(simp add: F_SDPDA_TO_LR1_STD__SpecInput_def F_SDPDA_TO_LR1_STD__SpecOutput_def)
  apply(case_tac "F_SDPDA_TO_LR1_OPT G k")
   apply(clarsimp)
   apply(simp add: F_SDPDA_TO_LR1_OPT_def)
   apply(case_tac "F_SDPDA_TO_CFG_OPT G k")
    apply(clarsimp)
    apply(subgoal_tac "X" for X)
     prefer 2
     apply(rule_tac G="G" in F_SDPDA_TO_CFG_OPT__SOUND2)
       apply(simp add: F_SDPDA_TO_CFG_STD__SpecInput_def)
      apply(force)
     apply(force)
    apply(rule_tac t="epdaS.marked_language G" and s="epdaH.marked_language G" in ssubst)
     apply(rule epdaS_to_epdaH_mlang)
     apply(simp only: valid_simple_dpda_def valid_pda_def valid_dpda_def)
    apply(force)
   apply(clarsimp)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="G" in F_SDPDA_TO_CFG_OPT__SOUND)
       apply(simp add: F_SDPDA_TO_CFG_STD__SpecInput_def)
      apply(force)
     apply(force)
    apply(force)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="G" in F_SDPDA_TO_CFG_STD__SOUND)
    apply(simp add: F_SDPDA_TO_CFG_STD__SpecInput_def)
   apply(simp add: F_SDPDA_TO_CFG_STD__SpecOutput_def)
   apply(clarsimp)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="X" for X in F_CFG_TRIM__SOUND)
    apply(simp add: F_CFG_TRIM__SpecInput_def F_SDPDA_TO_CFG_STD__SpecOutput_def)
   apply(simp add: F_CFG_TRIM__SpecOutput_def)
   apply (metis CFG_lang_lm_lang_equal)
  apply(clarsimp)
  apply(simp add: F_SDPDA_TO_LR1_OPT_def)
  apply(case_tac "F_SDPDA_TO_CFG_OPT G k")
   apply(force)
  apply(clarsimp)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" in F_SDPDA_TO_CFG_OPT__SOUND)
      apply(simp add: F_SDPDA_TO_CFG_STD__SpecInput_def)
     apply(force)
    apply(force)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" in F_SDPDA_TO_CFG_STD__SOUND)
   apply(simp add: F_SDPDA_TO_CFG_STD__SpecInput_def)
  apply(simp add: F_SDPDA_TO_CFG_STD__SpecOutput_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="X" for X in F_CFG_TRIM__SOUND)
   apply(simp add: F_CFG_TRIM__SpecInput_def F_SDPDA_TO_CFG_STD__SpecOutput_def)
   apply(force)
  apply(simp add: F_CFG_TRIM__SpecOutput_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G'="a" in F_SDPDA_TO_CFG_STD__enforces_cfg_LRk)
       apply(force)
      apply(force)
     apply(simp add: cfg_sub_def)
     apply(force)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply (metis CFG_lang_lm_lang_equal)
  done

theorem F_SDPDA_TO_LR1_OPT__vs__F_SDPDA_TO_LR1_STD: "
  F_SDPDA_TO_LR1_STD__SpecInput G
  \<Longrightarrow> k > 0
  \<Longrightarrow> F_SDPDA_TO_LR1_STD G = F_SDPDA_TO_LR1_OPT G k"
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule F_SDPDA_TO_LR1_STD__SOUND)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" in F_SDPDA_TO_CFG_STD__SOUND)
   apply(simp add: F_SDPDA_TO_LR1_STD__SpecInput_def F_SDPDA_TO_LR1_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecInput_def)
  apply(simp add: F_SDPDA_TO_LR1_STD__SpecInput_def F_SDPDA_TO_LR1_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecInput_def)
  apply(clarsimp)
  apply(simp add: F_SDPDA_TO_LR1_STD_def F_SDPDA_TO_LR1_OPT_def)
  apply(case_tac "F_SDPDA_TO_CFG_OPT G k")
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule F_SDPDA_TO_CFG_OPT__SOUND2)
      apply(force)
     apply(force)
    apply(force)
   apply(clarsimp)
   apply(case_tac "F_CFG_TRIM (F_SDPDA_TO_CFG_STD G) ")
    apply(force)
   apply(clarsimp)
   apply(rename_tac G2)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="F_SDPDA_TO_CFG_STD G" in F_CFG_TRIM__SOUND)
    apply(simp add: F_CFG_TRIM__SpecInput_def)
   apply(simp add: F_CFG_TRIM__SpecOutput_def)
   apply(clarsimp)
   apply(subgoal_tac "cfgLM.marked_language G2 = {}")
    prefer 2
    apply(rule_tac t="cfgLM.marked_language G2" and s="cfgLM.marked_language (F_SDPDA_TO_CFG_STD G)" in ssubst)
     apply(force)
    apply(rule_tac t="cfgLM.marked_language (F_SDPDA_TO_CFG_STD G)" and s="epdaS.marked_language G" in ssubst)
     apply(force)
    apply(rule_tac t="epdaS.marked_language G" and s="epdaH.marked_language G" in ssubst)
     apply(rule epdaS_to_epdaH_mlang)
     apply(simp only: valid_simple_dpda_def valid_pda_def valid_dpda_def)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule F_SDPDA_TO_CFG_OPT__SOUND)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rename_tac G2)
  apply(rule sym)
  apply(rule cfg_equal_trim_by_cfg_sub_and_equal_marked_language)
       apply(force)
      apply(force)
     apply(simp add: cfg_sub_def F_SDPDA_TO_CFG_OPT_def Let_def F_SDPDA_TO_CFG_STD_def)
     apply(case_tac "cons_l2 (epda_initial G) (epda_box G)
              \<in> (case F_SDPDA_TO_CFG_OPT__nonterminals G k of
                  cons_tuple2 S2 S3 \<Rightarrow> S2)")
      prefer 2
      apply(force)
     apply(clarsimp)
    apply(force)
   apply(force)
  apply(force)
  done

theorem F_SDPDA_TO_LR1_OPT__vs__F_SDPDA_TO_LR1_STD__stronger: "
  valid_simple_dpda G
  \<Longrightarrow> k > 0
  \<Longrightarrow> F_SDPDA_TO_LR1_STD G = F_SDPDA_TO_LR1_OPT G k"
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" in F_SDPDA_TO_CFG_STD__SOUND)
   apply(simp add: F_SDPDA_TO_LR1_STD__SpecInput_def F_SDPDA_TO_LR1_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecInput_def)
  apply(simp add: F_SDPDA_TO_LR1_STD__SpecInput_def F_SDPDA_TO_LR1_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecOutput_def F_SDPDA_TO_CFG_STD__SpecInput_def)
  apply(clarsimp)
  apply(simp add: F_SDPDA_TO_LR1_STD_def F_SDPDA_TO_LR1_OPT_def)
  apply(case_tac "F_SDPDA_TO_CFG_OPT G k")
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule F_SDPDA_TO_CFG_OPT__SOUND2)
      apply(force)
     apply(force)
    apply(force)
   apply(clarsimp)
   apply(case_tac "F_CFG_TRIM (F_SDPDA_TO_CFG_STD G) ")
    apply(force)
   apply(clarsimp)
   apply(rename_tac G2)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="F_SDPDA_TO_CFG_STD G" in F_CFG_TRIM__SOUND)
    apply(simp add: F_CFG_TRIM__SpecInput_def)
   apply(simp add: F_CFG_TRIM__SpecOutput_def)
   apply(clarsimp)
   apply(subgoal_tac "cfgLM.marked_language G2 = {}")
    prefer 2
    apply(rule_tac t="cfgLM.marked_language G2" and s="cfgLM.marked_language (F_SDPDA_TO_CFG_STD G)" in ssubst)
     apply(force)
    apply(rule_tac t="cfgLM.marked_language (F_SDPDA_TO_CFG_STD G)" and s="epdaS.marked_language G" in ssubst)
     apply (metis CFG_lang_lm_lang_equal)
    apply(rule_tac t="epdaS.marked_language G" and s="epdaH.marked_language G" in ssubst)
     apply(rule epdaS_to_epdaH_mlang)
     apply(simp only: valid_simple_dpda_def valid_pda_def valid_dpda_def)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule F_SDPDA_TO_CFG_OPT__SOUND)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(rename_tac G2)
  apply(rule sym)
  apply(rule cfg_equal_trim_by_cfg_sub_and_equal_marked_language)
       apply(force)
      apply(force)
     apply(simp add: cfg_sub_def F_SDPDA_TO_CFG_OPT_def Let_def F_SDPDA_TO_CFG_STD_def)
     apply(case_tac "cons_l2 (epda_initial G) (epda_box G)
              \<in> (case F_SDPDA_TO_CFG_OPT__nonterminals G k of
                  cons_tuple2 S2 S3 \<Rightarrow> S2)")
      prefer 2
      apply(force)
     apply(clarsimp)
    apply(force)
   apply(force)
  apply(force)
  done

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)
 *)

(*
  The state and error monads in Isabelle,
*)

chapter "Monads"

theory StateMonad (* FIXME: untested/unused *)
imports Lib
begin

type_synonym ('s,'a) state_monad = "'s \<Rightarrow> 'a \<times> 's"

definition
  runState :: "('s,'a) state_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "runState \<equiv> id"

definition
  "return a \<equiv> \<lambda>s. (a,s)"

definition
  bind :: "('s, 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow>
           ('s, 'b) state_monad" (infixl ">>=" 60)
where
  "bind f g \<equiv> (\<lambda>s. let (v,s') = f s in (g v) s')"

definition
  "bind' f g \<equiv> bind f (\<lambda>_. g)"

declare bind'_def [iff]

definition
  "get \<equiv> \<lambda>s. (s,s)"

definition
  "put s \<equiv> \<lambda>_. ((),s)"

definition
  "gets f \<equiv> get >>= (\<lambda>s. return $ f s)"

definition
  "modify f \<equiv> get >>= (\<lambda>s. put $ f s)"

definition
  "when p s \<equiv> if p then s else return ()"

definition
  "unless p s \<equiv> when (\<not>p) s"

text {* The monad laws: *}

lemma return_bind [simp]: "(return x >>= f) = f x"
  by (simp add: return_def bind_def runState_def)

lemma bind_return [simp]: "(m >>= return) = m"
  unfolding bind_def return_def runState_def
  by (simp add: Let_def split_def)

lemma bind_assoc:
  fixes m :: "('s,'a) state_monad"
  fixes f :: "'a \<Rightarrow> ('s,'b) state_monad"
  fixes g :: "'b \<Rightarrow> ('s,'c) state_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  unfolding bind_def
  by (clarsimp simp add: Let_def split_def)

text {* An errorT state\_monad (returnOk=return, bindE=bind): *}

definition
  "returnOk \<equiv> return o Inr"

definition
  "throwError \<equiv> return o Inl"

definition
  "Ok \<equiv> Inr"

definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow> 'e+'a \<Rightarrow> ('s, 'e + 'b) state_monad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e | Inr v' \<Rightarrow> f v'"

definition
  lift2 :: "('c \<Rightarrow> ('a, 'b + 'e + 'd) state_monad) \<Rightarrow> 'b+'e+'c \<Rightarrow> ('a, 'b+'e+'d) state_monad"
where
  "lift2 f v \<equiv> case v of
                 Inl e \<Rightarrow> throwError e
               | Inr v'' \<Rightarrow> (case v'' of Inl e' \<Rightarrow> return $ Inr $ Inl e' | Inr v' \<Rightarrow> f v')"

(* This is used if you are just trying to throwError by itself *)
definition
  raise :: "'a \<Rightarrow> 's \<Rightarrow> ('a + unit) \<times> 's"
where
  "raise \<equiv> return \<circ> Inl"

definition
  bindE :: "('s, 'e + 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow>
            ('s, 'e + 'b) state_monad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

definition
  "bindE' f g \<equiv> bindE f (\<lambda>_. g)"

definition
  liftE :: "('s,'a) state_monad \<Rightarrow> ('s, 'e+'a) state_monad" where
  "liftE f \<equiv> \<lambda>s. let (v,s') = f s in (Inr v, s')"

definition
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  "unlessE P f \<equiv> if P then returnOk () else f"

definition
  "throw_opt ex x \<equiv> case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

definition
  "bindEE f g \<equiv> bind f (lift2 g)"
definition
  "bindEE' f g \<equiv> bindEE f (\<lambda>_. g)"

definition
  "modifyE \<equiv> (liftE \<circ> modify)"
definition
  "getsE x \<equiv> liftE $ gets x"

syntax
  bindEE :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixl ">>=EE" 60)

declare
  bindE'_def [iff]
  bindEE_def [iff]
  bindEE'_def [iff]

lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  unfolding bindE_def return_def returnOk_def
  by (clarsimp simp: lift_def)

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (auto simp: lift_def throwError_def split: sum.splits)

lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

 lemma bindE_assoc:
  shows "(m >>=E f) >>=E g  =  m >>=E (\<lambda>x. f x >>=E g)"
  by (auto simp: Let_def bindE_def bind_def lift_def split_def runState_def throwError_def return_def
           split: sum.splits)

lemma throwError_bindE [simp]:
  "throwError E >>=E f = throwError E"
  by (simp add: bindE_def bind_def throwError_def lift_def return_def)

subsection "Syntax for state monad"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do (_);//   (_)//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "CONST bind' b e"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

lemma "do x \<leftarrow> return 1; return 2; return x od = return 1"
  by simp

subsection "Syntax for errorT state monad"

syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE (_);//    (_)//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "CONST bindE' b e"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

subsection "Syntax for errorT errorT state monad"

syntax
  "_doEE" :: "[dobinds, 'a] => 'a" ("(doEE (_);//     (_)//odEE)" 100)

translations
  "_doEE (_dobinds b bs) e"  == "_doEE b (_doEE bs e)"
  "_doEE (_nobind b) e"      == "CONST bindEE' b e"
  "doEE x <- a; e odEE"      == "a >>=EE (\<lambda>x. e)"

primrec
  inc_forloop :: "nat \<Rightarrow> 'g::{plus,one} \<Rightarrow> ('g \<Rightarrow> ('a, 'b + unit) state_monad) \<Rightarrow>
                  ('a, 'b + unit) state_monad"
where
  "inc_forloop 0 current body = returnOk ()"
| "inc_forloop (Suc left) current body = doE body current ; inc_forloop left (current+1) body odE"

primrec
  do_times :: "nat \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow>
              ('a, 'b + unit) state_monad"
where
  "do_times 0 body increment = returnOk ()"
| "do_times (Suc left) body increment = doE body ; increment ; do_times left body increment odE"

definition
  function_update :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "function_update index modifier f \<equiv>
   \<lambda>x. if x = index then modifier (f x) else (f x)"

lemma "doE x \<leftarrow> returnOk 1; returnOk 2; returnOk x odE = returnOk 1"
  by simp

term "doEE x \<leftarrow> returnOk $ Ok 1; returnOk $ Ok 2; returnOk $ Ok x odEE"

definition
  "skip \<equiv> returnOk $ Ok ()"

definition
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"
definition
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

definition
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

definition
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"
definition
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

definition
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE uu <- x; y odE) xs (returnOk ())"
definition
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  "sequenceEE_x xs \<equiv> foldr bindEE' xs (skip)"
definition
  "mapMEE_x f xs \<equiv> sequenceEE_x (map f xs)"

definition
  catch :: "('s, 'a + 'b) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow> ('s, 'b) state_monad"
where
  "catch f handler \<equiv> do x \<leftarrow> f;
                        case x of
                            Inr b \<Rightarrow> return b
                          | Inl e \<Rightarrow> handler e
                      od"

definition
  handleE :: "('s, 'x + 'a) state_monad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
              ('s, 'x + 'a) state_monad" (infix "<handle>" 11) where
  "f <handle> handler \<equiv>
   do v \<leftarrow> f; case v of Inl e \<Rightarrow> handler e | Inr v' \<Rightarrow> return v od"

definition
  handle_elseE :: "('s, 'x + 'a) state_monad \<Rightarrow>
                   ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('s, 'x + 'a) state_monad" ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
    do v \<leftarrow> f;
       case v of Inl e \<Rightarrow> handler e
               | Inr v \<Rightarrow> continue v
    od"

definition
  isSkip :: "('s, 'a) state_monad \<Rightarrow> bool" where
  "isSkip m \<equiv> \<forall>s. \<exists>r. m s = (r,s)"

lemma isSkip_bindI: "\<lbrakk> isSkip f; \<And>x. isSkip (g x) \<rbrakk> \<Longrightarrow> isSkip (f >>= g)"
  apply (clarsimp simp: isSkip_def bind_def Let_def)
  apply (erule_tac x=s in allE)
  apply clarsimp
  done

lemma isSkip_return [simp,intro!]:
  "isSkip (return x)"
  by (simp add: isSkip_def return_def)

lemma isSkip_gets [simp,intro!]:
  "isSkip (gets x)"
  by (simp add: isSkip_def gets_def get_def bind_def return_def)

lemma isSkip_liftE [iff]: "isSkip (liftE f) = isSkip f"
  apply (simp add: isSkip_def liftE_def Let_def split_def)
  apply rule
   apply clarsimp
   apply (case_tac "f s")
   apply (erule_tac x = s in allE)
   apply simp
  apply clarsimp
  apply (case_tac "f s")
  apply (erule_tac x = s in allE)
  apply simp
  done

lemma isSkip_liftI [simp, intro!]:
  "\<lbrakk> \<And>y. x = Inr y \<Longrightarrow> isSkip (f y) \<rbrakk> \<Longrightarrow> isSkip (lift f x)"
  by (simp add: lift_def throwError_def return_def isSkip_def split: sum.splits)

lemma isSkip_Error [iff]:
  "isSkip (throwError x)"
  by (simp add: throwError_def)

lemma isSkip_returnOk [iff]:
  "isSkip (returnOk x)"
  by (simp add: returnOk_def)

lemma isSkip_throw_opt [iff]:
  "isSkip (throw_opt e x)"
  by (simp add: throw_opt_def split: option.splits)

lemma nested_bind [simp]:
  "do x <- do y <- f; return (g y) od; h x od =
   do y <- f; h (g y) od"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: Let_def split_def runState_def return_def)
  done

lemma skip_bind:
  "isSkip s \<Longrightarrow> do _ \<leftarrow> s; g od = g"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: isSkip_def Let_def)
  apply (erule_tac x=sa in allE)
  apply clarsimp
  done

lemma bind_eqI:
  "\<lbrakk> f = f'; \<And>x. g x = g' x \<rbrakk> \<Longrightarrow> f >>= g = f' >>= g'"
  by (simp add: bind_def)

lemma bind'_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s s'. f' s = (v, s') \<Longrightarrow> g s' = g' s' \<rbrakk> \<Longrightarrow> bind' f g = bind' f' g'"
  by (auto intro: bind_cong)

lemma bindE_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N v s' = N' v s' \<rbrakk> \<Longrightarrow> bindE M N = bindE M' N'"
  apply (simp add: bindE_def)
  apply (rule bind_cong)
   apply (rule refl)
  apply (unfold lift_def)
  apply (case_tac v, simp_all)
  done

lemma bindE'_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N s' = N' s' \<rbrakk> \<Longrightarrow> bindE' M N = bindE' M' N'"
  by (auto intro: bindE_cong)

definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) state_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> split Q (f s)"

definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) state_monad \<Rightarrow> ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>, \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> split (\<lambda>r s. case r of Inr b \<Rightarrow> Q b s
                                                  | Inl a \<Rightarrow> R a s) (f s)"

lemma validE_def2:
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>r s. case r of Inr b \<Rightarrow> Q b s | Inl a \<Rightarrow> R a s \<rbrace>"
  by (unfold valid_def validE_def)

(* FIXME: modernize *)
syntax top :: "'a \<Rightarrow> bool" ("\<top>")
       bottom :: "'a \<Rightarrow> bool" ("\<bottom>")

translations
  "\<top>" == "\<lambda>_. CONST True"
  "\<bottom>" == "\<lambda>_. CONST False"

definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

definition
  bipred_disj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" (infixl "Or" 91)
where
  "bipred_disj P Q \<equiv> \<lambda>x y. P x y \<or> Q x y"

definition
  bipred_neg :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" ("Not _") where
  "bipred_neg P \<equiv> \<lambda>x y. \<not> P x y"

syntax toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
       botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")

translations "\<top>\<top>" == "\<lambda>_ _. CONST True"
             "\<bottom>\<bottom>" == "\<lambda>_ _. CONST False"

definition
  pred_lift_exact :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" ("\<guillemotleft>_,_\<guillemotright>") where
  "pred_lift_exact P Q \<equiv> \<lambda>x y. P x \<and> Q y"

lemma pred_lift_taut[simp]: "\<guillemotleft>\<top>,\<top>\<guillemotright> = \<top>\<top>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_l[simp]: "\<guillemotleft>\<bottom>,x\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_r[simp]: "\<guillemotleft>x,\<bottom>\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_liftI[intro!]: "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<guillemotleft>P,Q\<guillemotright> x y"
  by (simp add:pred_lift_exact_def)

lemma pred_exact_split:
  "\<guillemotleft>P,Q\<guillemotright> = (\<guillemotleft>P,\<top>\<guillemotright> And \<guillemotleft>\<top>,Q\<guillemotright>)"
  by (simp add:pred_lift_exact_def bipred_conj_def)

lemma pred_andE[elim!]: "\<lbrakk> (A and B) x; \<lbrakk> A x; B x \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (simp add:pred_conj_def)

lemma pred_andI[intro!]: "\<lbrakk> A x; B x \<rbrakk> \<Longrightarrow> (A and B) x"
  by (simp add:pred_conj_def)

lemma bipred_conj_app[simp]: "(P And Q) x = (P x and Q x)"
  by (simp add:pred_conj_def bipred_conj_def)

lemma bipred_disj_app[simp]: "(P Or Q) x = (P x or Q x)"
  by (simp add:pred_disj_def bipred_disj_def)

lemma pred_conj_app[simp]: "(P and Q) x = (P x \<and> Q x)"
  by (simp add:pred_conj_def)

lemma pred_disj_app[simp]: "(P or Q) x = (P x \<or> Q x)"
  by (simp add:pred_disj_def)

lemma pred_notnotD[simp]: "(not not P) = P"
  by (simp add:pred_neg_def)

lemma bipred_notnotD[simp]: "(Not Not P) = P"
  by (simp add:bipred_neg_def)

lemma pred_lift_add[simp]: "\<guillemotleft>P,Q\<guillemotright> x = ((\<lambda>s. P x) and Q)"
  by (simp add:pred_lift_exact_def pred_conj_def)

lemma pred_and_true[simp]: "(P and \<top>) = P"
  by (simp add:pred_conj_def)

lemma pred_and_true_var[simp]: "(\<top> and P) = P"
  by (simp add:pred_conj_def)

lemma pred_and_false[simp]: "(P and \<bottom>) = \<bottom>"
  by (simp add:pred_conj_def)

lemma pred_and_false_var[simp]: "(\<bottom> and P) = \<bottom>"
  by (simp add:pred_conj_def)

lemma seq':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>;
     \<forall>x. P x \<longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>;
     \<forall>x s. B x s \<longrightarrow> P x \<and> C s \<rbrakk> \<Longrightarrow>
   \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply (clarsimp simp: valid_def runState_def bind_def Let_def split_def)
  apply (case_tac "f s")
  apply fastforce
  done

lemma seq:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>"
  assumes "\<And>x. P x \<Longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>"
  assumes "\<And>x s. B x s \<Longrightarrow> P x \<and> C s"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  using assms by (blast intro: seq')

lemma seq_invar_nobind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>\<top>,A\<guillemotright>" and C="A" and P="\<top>" in seq)
    apply(insert f_valid g_valid)
    apply(simp_all add:pred_lift_exact_def)
  done

lemma seq_invar_bind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>B,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. P x \<Longrightarrow> \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes bind: "\<And>x. B x \<Longrightarrow> P x"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>B,A\<guillemotright>" and C="A" and P="P" in seq)
    apply(insert f_valid g_valid bind)
    apply(simp_all add: pred_lift_exact_def)
  done

lemma seq_noimp:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>C,B\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. C x \<Longrightarrow> \<lbrace>B\<rbrace> g x \<lbrace>D\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply(rule_tac B="\<guillemotleft>C,B\<guillemotright>" and C="B" and P="C" in seq)
    apply(insert f_valid g_valid, simp_all add:pred_lift_exact_def)
  done

lemma seq_ext':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<forall>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
  by (clarsimp simp: valid_def runState_def bind_def Let_def split_def)

lemma seq_ext:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
  using assms by (blast intro: seq_ext')

lemma seqE':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>;
     \<forall>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  apply(simp add: bindE_def lift_def bind_def Let_def split_def)
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac "fst (f s)"; case_tac r; fastforce simp:throwError_def return_def)
  done

lemma seqE:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  shows "\<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  using assms by(blast intro: seqE')

lemma get_sp:
  "\<lbrace>P\<rbrace> get \<lbrace>\<lambda>a s. s = a \<and> P s\<rbrace>"
  by (simp add:get_def valid_def)

lemma put_sp:
  "\<lbrace>\<top>\<rbrace> put a \<lbrace>\<lambda>_ s. s = a\<rbrace>"
  by (simp add:put_def valid_def)

lemma return_sp:
  "\<lbrace>P\<rbrace> return a \<lbrace>\<lambda>b s. b = a \<and> P s\<rbrace>"
  by (simp add:return_def valid_def)

lemma hoare_post_conj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> Q \<rbrace>; \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> a \<lbrace> Q And R \<rbrace>"
  by (simp add:valid_def split_def bipred_conj_def)

lemma hoare_pre_disj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace>; \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P or Q \<rbrace> a \<lbrace> R \<rbrace>"
  by (simp add:valid_def pred_disj_def)

lemma hoare_post_taut [iff]: "\<lbrace> P \<rbrace> a \<lbrace> \<top>\<top> \<rbrace>"
  by (simp add:valid_def)

lemma hoare_pre_cont [iff]: "\<lbrace> \<bottom> \<rbrace> a \<lbrace> P \<rbrace>"
  by (simp add:valid_def)

lemma hoare_return [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop_var [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<lambda>r. Q \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_only [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,\<top>\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_get [iff]: "\<lbrace> P \<rbrace> get \<lbrace> \<guillemotleft>P,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def get_def pred_lift_exact_def)

lemma hoare_gets [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) s \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> gets f \<lbrace> Q \<rbrace>"
  by (simp add:valid_def gets_def get_def bind_def return_def)

lemma hoare_modify [iff]: "\<lbrace> P o f \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE_var [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<lambda>r s. Q s \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_put [intro!]: "P x \<Longrightarrow> \<lbrace> Q \<rbrace> put x \<lbrace> \<guillemotleft>\<top>,P\<guillemotright>\<rbrace>"
  by (simp add:valid_def put_def pred_lift_exact_def)

lemma hoare_if [intro!]:
  "\<lbrakk> P \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace>; \<not> P \<Longrightarrow> \<lbrace> Q \<rbrace> b \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> if P then a else b \<lbrace> R \<rbrace>"
  by (simp add:valid_def)

lemma hoare_when [intro!]:
  "\<lbrakk> \<lbrakk> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>; \<And>s. \<lbrakk> \<not> P; Q s \<rbrakk> \<Longrightarrow> R s \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> when P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def when_def split_def return_def pred_lift_exact_def)

lemma hoare_unless [intro!]:
  "\<lbrakk> \<And>s. \<lbrakk> P; Q s \<rbrakk> \<Longrightarrow> R s; \<lbrakk> \<not> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> unless P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def unless_def split_def when_def return_def pred_lift_exact_def)

lemma hoare_pre_subst: "\<lbrakk> A = B; \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>B\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

lemma hoare_post_subst: "\<lbrakk> B = C; \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

lemma hoare_pre_tautI: "\<lbrakk> \<lbrace>A and P\<rbrace> a \<lbrace>B\<rbrace>; \<lbrace>A and not P\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace>"
  by (clarsimp simp:valid_def split_def pred_conj_def pred_neg_def, blast)

lemma hoare_return_var[intro!]: "\<lbrakk> \<And>x. P x \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> \<lbrace>R\<rbrace> return x \<lbrace>\<guillemotleft>Q,R\<guillemotright>\<rbrace>)"
  by (rule hoare_return)

lemma hoare_return_drop_imp[intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> return x \<lbrace>\<guillemotleft>\<top>,Q\<guillemotright>\<rbrace>"
 by (simp add:valid_def return_def)

lemmas hoare_case_option_inference = option.exhaust

lemma hoare_pre_imp: "\<lbrakk> \<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def)

lemma hoare_post_imp: "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def split_def)

lemma hoare_post_impE:
  "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s; \<And>e s. E e s \<Longrightarrow> F e s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>F\<rbrace>"
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac r; fastforce)
  done

lemma "isSkip f \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  apply (clarsimp simp: valid_def split_def isSkip_def)
  apply (rename_tac s)
  apply (case_tac "f s")
  apply (erule_tac x=s in allE)
  apply auto
  done

end


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

theory SUF_CMA imports
  CryptHOL.Computational_Model
  CryptHOL.Negligible
  CryptHOL.Environment_Functor
begin

subsection \<open>Strongly existentially unforgeable signature scheme\<close>

locale sig_scheme =
  fixes key_gen :: "security \<Rightarrow> ('vkey \<times> 'sigkey) spmf"
  and sign :: "security \<Rightarrow> 'sigkey \<Rightarrow> 'message \<Rightarrow> 'signature spmf"
  and verify :: "security \<Rightarrow> 'vkey \<Rightarrow> 'message \<Rightarrow> 'signature \<Rightarrow> bool" \<comment> \<open>verification is deterministic\<close>
  and valid_message :: "security \<Rightarrow> 'message \<Rightarrow> bool"

locale suf_cma = sig_scheme +
  constrains key_gen :: "security \<Rightarrow> ('vkey \<times> 'sigkey) spmf"
  and sign :: "security \<Rightarrow> 'sigkey \<Rightarrow> 'message \<Rightarrow> 'signature spmf"
  and verify :: "security \<Rightarrow> 'vkey \<Rightarrow> 'message \<Rightarrow> 'signature \<Rightarrow> bool"
  and valid_message :: "security \<Rightarrow> 'message \<Rightarrow> bool"
begin

type_synonym ('vkey', 'sigkey', 'message', 'signature') state_oracle
  = "('vkey' \<times> 'sigkey' \<times> ('message' \<times> 'signature') list) option"

fun vkey_oracle :: "security \<Rightarrow> (('vkey, 'sigkey, 'message, 'signature) state_oracle, unit, 'vkey) oracle'"
where
  "vkey_oracle \<eta> None _ = do {
     (vkey, sigkey) \<leftarrow> key_gen \<eta>;
     return_spmf (vkey, Some (vkey, sigkey, []))
   }"
| "\<And>log. vkey_oracle \<eta> (Some (vkey, sigkey, log)) _ = return_spmf (vkey, Some (vkey, sigkey, log))"

context notes bind_spmf_cong[fundef_cong] begin
function sign_oracle
  :: "security \<Rightarrow> (('vkey, 'sigkey, 'message, 'signature) state_oracle, 'message, 'signature) oracle'"
where
  "sign_oracle \<eta> None m = do { (_, \<sigma>) \<leftarrow> vkey_oracle \<eta> None (); sign_oracle \<eta> \<sigma> m }"
| "\<And>log. sign_oracle \<eta> (Some (vkey, skey, log)) m =
  (if valid_message \<eta> m then do {
    sig \<leftarrow> sign \<eta> skey m;
    return_spmf (sig, Some (vkey, skey, (m, sig) # log))
  } else return_pmf None)"
by pat_completeness auto
termination by(relation "Wellfounded.measure (\<lambda>(\<eta>, \<sigma>, m). case \<sigma> of None \<Rightarrow> 1 | _ \<Rightarrow> 0)") auto
end

lemma lossless_vkey_oracle [simp]:
  "lossless_spmf (vkey_oracle \<eta> \<sigma> x) \<longleftrightarrow> (\<sigma> = None \<longrightarrow> lossless_spmf (key_gen \<eta>))"
by(cases "(\<eta>, \<sigma>, x)" rule: vkey_oracle.cases) auto

lemma lossless_sign_oracle [simp]:
  "\<lbrakk> \<sigma> = None \<Longrightarrow> lossless_spmf (key_gen \<eta>);
    \<And>skey m. valid_message \<eta> m \<Longrightarrow> lossless_spmf (sign \<eta> skey m) \<rbrakk>
  \<Longrightarrow> lossless_spmf (sign_oracle \<eta> \<sigma> m) \<longleftrightarrow> valid_message \<eta> m"
apply(cases "(\<eta>, \<sigma>, m)" rule: sign_oracle.cases)
apply(auto simp add: split_beta dest: lossless_spmfD_set_spmf_nonempty)
done

lemma lossless_sign_oracle_Some: fixes log shows
  "lossless_spmf (sign_oracle \<eta> (Some (vkey, skey, log)) m) \<longleftrightarrow> lossless_spmf (sign \<eta> skey m) \<and> valid_message \<eta> m"
by(simp)

subsubsection \<open>Single-user setting\<close>

type_synonym 'message' call\<^sub>1 = "unit + 'message'"
type_synonym ('vkey', 'signature') ret\<^sub>1 = "'vkey' + 'signature'"

definition oracle\<^sub>1 :: "security
  \<Rightarrow> (('vkey, 'sigkey, 'message, 'signature) state_oracle, 'message call\<^sub>1, ('vkey, 'signature) ret\<^sub>1) oracle'"
where "oracle\<^sub>1 \<eta> = vkey_oracle \<eta> \<oplus>\<^sub>O sign_oracle \<eta>"

lemma oracle\<^sub>1_simps [simp]:
  "oracle\<^sub>1 \<eta> s (Inl x) = map_spmf (apfst Inl) (vkey_oracle \<eta> s x)"
  "oracle\<^sub>1 \<eta> s (Inr y) = map_spmf (apfst Inr) (sign_oracle \<eta> s y)"
by(simp_all add: oracle\<^sub>1_def)

type_synonym ('vkey', 'message', 'signature') adversary\<^sub>1' =
  "(('message' \<times> 'signature'), 'message' call\<^sub>1, ('vkey', 'signature') ret\<^sub>1) gpv"
type_synonym ('vkey', 'message', 'signature') adversary\<^sub>1 =
  "security \<Rightarrow> ('vkey', 'message', 'signature') adversary\<^sub>1'"

definition suf_cma\<^sub>1 :: "('vkey, 'message, 'signature) adversary\<^sub>1 \<Rightarrow> security \<Rightarrow> bool spmf"
where
  "\<And>log. suf_cma\<^sub>1 \<A> \<eta> = do {
    ((m, sig), \<sigma>) \<leftarrow> exec_gpv (oracle\<^sub>1 \<eta>) (\<A> \<eta>) None;
    return_spmf (
      case \<sigma> of None \<Rightarrow> False
      | Some (vkey, skey, log) \<Rightarrow> verify \<eta> vkey m sig \<and> (m, sig) \<notin> set log)
  }"

definition advantage\<^sub>1 :: "('vkey, 'message, 'signature) adversary\<^sub>1 \<Rightarrow> advantage"
where "advantage\<^sub>1 \<A> \<eta> = spmf (suf_cma\<^sub>1 \<A> \<eta>) True"

lemma advantage\<^sub>1_nonneg: "advantage\<^sub>1 \<A> \<eta> \<ge> 0" by(simp add: advantage\<^sub>1_def pmf_nonneg)

abbreviation secure_for\<^sub>1 :: "('vkey, 'message, 'signature) adversary\<^sub>1 \<Rightarrow> bool"
where "secure_for\<^sub>1 \<A> \<equiv> negligible (advantage\<^sub>1 \<A>)"

definition ibounded_by\<^sub>1' :: "('vkey, 'message, 'signature) adversary\<^sub>1' \<Rightarrow> nat \<Rightarrow> bool"
where "ibounded_by\<^sub>1' \<A> q = (interaction_any_bounded_by \<A> q)"

abbreviation ibounded_by\<^sub>1 :: "('vkey, 'message, 'signature) adversary\<^sub>1 \<Rightarrow> (security \<Rightarrow> nat) \<Rightarrow> bool"
where "ibounded_by\<^sub>1 \<equiv> rel_envir ibounded_by\<^sub>1'"

definition lossless\<^sub>1' :: "('vkey, 'message, 'signature) adversary\<^sub>1' \<Rightarrow> bool"
where "lossless\<^sub>1' \<A> = (lossless_gpv \<I>_full \<A>)"

abbreviation lossless\<^sub>1 :: "('vkey, 'message, 'signature) adversary\<^sub>1 \<Rightarrow> bool"
where "lossless\<^sub>1 \<equiv> pred_envir lossless\<^sub>1'"

subsubsection \<open>Multi-user setting\<close>

definition oracle\<^sub>n :: "security
  \<Rightarrow> ('i \<Rightarrow> ('vkey, 'sigkey, 'message, 'signature) state_oracle, 'i \<times> 'message call\<^sub>1, ('vkey, 'signature) ret\<^sub>1) oracle'"
where "oracle\<^sub>n \<eta> = family_oracle (\<lambda>_. oracle\<^sub>1 \<eta>)"

lemma oracle\<^sub>n_apply [simp]:
  "oracle\<^sub>n \<eta> s (i, x) = map_spmf (apsnd (fun_upd s i)) (oracle\<^sub>1 \<eta> (s i) x)"
by(simp add: oracle\<^sub>n_def)

type_synonym ('i, 'vkey', 'message', 'signature') adversary\<^sub>n' =
  "(('i \<times> 'message' \<times> 'signature'), 'i \<times> 'message' call\<^sub>1, ('vkey', 'signature') ret\<^sub>1) gpv"
type_synonym ('i, 'vkey', 'message', 'signature') adversary\<^sub>n =
  "security \<Rightarrow> ('i, 'vkey', 'message', 'signature') adversary\<^sub>n'"

definition suf_cma\<^sub>n :: "('i, 'vkey, 'message, 'signature) adversary\<^sub>n \<Rightarrow> security \<Rightarrow> bool spmf"
where
  "\<And>log. suf_cma\<^sub>n \<A> \<eta> = do {
    ((i, m, sig), \<sigma>) \<leftarrow> exec_gpv (oracle\<^sub>n \<eta>) (\<A> \<eta>) (\<lambda>_. None);
    return_spmf (
      case \<sigma> i of None \<Rightarrow> False
      | Some (vkey, skey, log) \<Rightarrow> verify \<eta> vkey m sig \<and> (m, sig) \<notin> set log)
  }"

definition advantage\<^sub>n :: "('i, 'vkey, 'message, 'signature) adversary\<^sub>n \<Rightarrow> advantage"
where "advantage\<^sub>n \<A> \<eta> = spmf (suf_cma\<^sub>n \<A> \<eta>) True"

lemma advantage\<^sub>n_nonneg: "advantage\<^sub>n \<A> \<eta> \<ge> 0" by(simp add: advantage\<^sub>n_def pmf_nonneg)

abbreviation secure_for\<^sub>n :: "('i, 'vkey, 'message, 'signature) adversary\<^sub>n \<Rightarrow> bool"
where "secure_for\<^sub>n \<A> \<equiv> negligible (advantage\<^sub>n \<A>)"

definition ibounded_by\<^sub>n' :: "('i, 'vkey, 'message, 'signature) adversary\<^sub>n' \<Rightarrow> nat \<Rightarrow> bool"
where "ibounded_by\<^sub>n' \<A> q = (interaction_any_bounded_by \<A> q)"

abbreviation ibounded_by\<^sub>n :: "('i, 'vkey, 'message, 'signature) adversary\<^sub>n \<Rightarrow> (security \<Rightarrow> nat) \<Rightarrow> bool"
where "ibounded_by\<^sub>n \<equiv> rel_envir ibounded_by\<^sub>n'"

definition lossless\<^sub>n' :: "('i, 'vkey, 'message, 'signature) adversary\<^sub>n' \<Rightarrow> bool"
where "lossless\<^sub>n' \<A> = (lossless_gpv \<I>_full \<A>)"

abbreviation lossless\<^sub>n :: "('i, 'vkey, 'message, 'signature) adversary\<^sub>n \<Rightarrow> bool"
where "lossless\<^sub>n \<equiv> pred_envir lossless\<^sub>n'"

end

end


theory General_Luby_Rackoff
  imports Misc_Luby_Rackoff
begin

type_synonym whole = \<open>half \<times> half\<close>

(*                      x       x1       x2      y      D1   D2    D3 *)
type_synonym state = \<open>whole \<times> whole \<times> whole \<times> whole \<times> db \<times> db \<times> db\<close>

definition X :: \<open>whole update \<Rightarrow> state update\<close> where \<open>X = Fst\<close>
definition X1 :: \<open>whole update \<Rightarrow> state update\<close> where \<open>X1 = Snd o Fst\<close>
definition X2 :: \<open>whole update \<Rightarrow> state update\<close> where \<open>X2 = Snd o Snd o Fst\<close>
definition Y :: \<open>whole update \<Rightarrow> state update\<close> where \<open>Y = Snd o Snd o Snd o Fst\<close>
definition D1 :: \<open>db update \<Rightarrow> state update\<close> where \<open>D1 = Snd o Snd o Snd o Snd o Fst\<close>
definition D2 :: \<open>db update \<Rightarrow> state update\<close> where \<open>D2 = Snd o Snd o Snd o Snd o Snd o Fst\<close>
definition D3 :: \<open>db update \<Rightarrow> state update\<close> where \<open>D3 = Snd o Snd o Snd o Snd o Snd o Snd\<close>

lemma [simp,register]: \<open>mutually compatible (X,X1,X2,Y,D1,D2,D3)\<close>
  by (auto simp add: X_def X1_def D1_def X2_def D2_def D3_def Y_def)

(*

(* lemma [simp]: \<open>each register (reg_1_3, reg_2_3, reg_3_3)\<close>
  by (auto simp add: reg_1_3_def reg_2_3_def reg_3_3_def) *)

(* LR2 as partial function *)
definition LR2 :: \<open>db \<Rightarrow> db \<Rightarrow> whole \<Rightarrow> whole option\<close> where
  \<open>LR2 D1 D2 = (\<lambda>(xL,xR). do {\<alpha> \<leftarrow> D1 xL; \<beta> \<leftarrow> D2 (xR + \<alpha>); Some (xL + \<beta>, xR + \<alpha>)})\<close>
  for D1 D2

end


(*  Title:      HOL/IOA/Solve.thy
    Author:     Tobias Nipkow & Konrad Slind
    Copyright   1994  TU Muenchen
*)

section \<open>Weak possibilities mapping (abstraction)\<close>

theory Solve
imports IOA
begin

definition is_weak_pmap :: "['c \<Rightarrow> 'a, ('action,'c)ioa,('action,'a)ioa] \<Rightarrow> bool" where
  "is_weak_pmap f C A \<equiv>
   (\<forall>s\<in>starts_of(C). f(s)\<in>starts_of(A)) \<and>
   (\<forall>s t a. reachable C s \<and>
            (s,a,t)\<in>trans_of(C)
            \<longrightarrow> (if a\<in>externals(asig_of(C)) then
                   (f(s),a,f(t))\<in>trans_of(A)
                 else f(s)=f(t)))"

declare mk_trace_thm [simp] trans_in_actions [simp]

lemma trace_inclusion:
  "[| IOA(C); IOA(A); externals(asig_of(C)) = externals(asig_of(A));
           is_weak_pmap f C A |] ==> traces(C) \<subseteq> traces(A)"
  apply (unfold is_weak_pmap_def traces_def)

  apply (simp (no_asm) add: has_trace_def)
  apply safe
  apply (rename_tac ex1 ex2)

  (* choose same trace, therefore same NF *)
  apply (rule_tac x = "mk_trace C ex1" in exI)
  apply simp

  (* give execution of abstract automata *)
  apply (rule_tac x = "(mk_trace A ex1,\<lambda>i. f (ex2 i))" in bexI)

  (* Traces coincide *)
   apply (simp (no_asm_simp) add: mk_trace_def filter_oseq_idemp)

  (* Use lemma *)
  apply (frule states_of_exec_reachable)

  (* Now show that it's an execution *)
  apply (simp add: executions_def)
  apply safe

  (* Start states map to start states *)
  apply (drule bspec)
  apply assumption

  (* Show that it's an execution fragment *)
  apply (simp add: is_execution_fragment_def)
  apply safe

  apply (erule_tac x = "ex2 n" in allE)
  apply (erule_tac x = "ex2 (Suc n)" in allE)
  apply (erule_tac x = a in allE)
  apply simp
  done

(* Lemmata *)

lemma imp_conj_lemma: "(P \<Longrightarrow> Q\<longrightarrow>R) \<Longrightarrow> P\<and>Q \<longrightarrow> R"
  by blast

(* fist_order_tautology of externals_of_par *)
lemma externals_of_par_extra:
  "a\<in>externals(asig_of(A1||A2)) =
   (a\<in>externals(asig_of(A1)) \<and> a\<in>externals(asig_of(A2)) \<or>
   a\<in>externals(asig_of(A1)) \<and> a\<notin>externals(asig_of(A2)) \<or>
   a\<notin>externals(asig_of(A1)) \<and> a\<in>externals(asig_of(A2)))"
  apply (auto simp add: externals_def asig_of_par asig_comp_def asig_inputs_def asig_outputs_def)
  done

lemma comp1_reachable: "[| reachable (C1||C2) s |] ==> reachable C1 (fst s)"
  apply (simp add: reachable_def)
  apply (erule bexE)
  apply (rule_tac x =
    "(filter_oseq (\<lambda>a. a\<in>actions (asig_of (C1))) (fst ex) , \<lambda>i. fst (snd ex i))" in bexI)
(* fst(s) is in projected execution *)
  apply force
(* projected execution is indeed an execution *)
  apply (simp cong del: if_weak_cong
    add: executions_def is_execution_fragment_def par_def starts_of_def
      trans_of_def filter_oseq_def
    split: option.split)
  done

(* Exact copy of proof of comp1_reachable for the second
   component of a parallel composition.     *)
lemma comp2_reachable: "[| reachable (C1||C2) s|] ==> reachable C2 (snd s)"
  apply (simp add: reachable_def)
  apply (erule bexE)
  apply (rule_tac x =
    "(filter_oseq (\<lambda>a. a\<in>actions (asig_of (C2))) (fst ex) , \<lambda>i. snd (snd ex i))" in bexI)
(* fst(s) is in projected execution *)
  apply force
(* projected execution is indeed an execution *)
  apply (simp cong del: if_weak_cong
    add: executions_def is_execution_fragment_def par_def starts_of_def
    trans_of_def filter_oseq_def
    split: option.split)
  done

declare if_split [split del] if_weak_cong [cong del]

(*Composition of possibility-mappings *)
lemma fxg_is_weak_pmap_of_product_IOA:
     "[| is_weak_pmap f C1 A1;
         externals(asig_of(A1))=externals(asig_of(C1));
         is_weak_pmap g C2 A2;
         externals(asig_of(A2))=externals(asig_of(C2));
         compat_ioas C1 C2; compat_ioas A1 A2  |]
   ==> is_weak_pmap (\<lambda>p.(f(fst(p)),g(snd(p)))) (C1||C2) (A1||A2)"
  apply (unfold is_weak_pmap_def)
  apply (rule conjI)
(* start_states *)
  apply (simp add: par_def starts_of_def)
(* transitions *)
  apply (rule allI)+
  apply (rule imp_conj_lemma)
  apply (simp (no_asm) add: externals_of_par_extra)
  apply (simp (no_asm) add: par_def)
  apply (simp add: trans_of_def)
  apply (simplesubst if_split)
  apply (rule conjI)
  apply (rule impI)
  apply (erule disjE)
(* case 1      a:e(A1) | a:e(A2) *)
  apply (simp add: comp1_reachable comp2_reachable ext_is_act)
  apply (erule disjE)
(* case 2      a:e(A1) | a~:e(A2) *)
  apply (simp add: comp1_reachable comp2_reachable ext_is_act ext1_ext2_is_not_act2)
(* case 3      a:~e(A1) | a:e(A2) *)
  apply (simp add: comp1_reachable comp2_reachable ext_is_act ext1_ext2_is_not_act1)
(* case 4      a:~e(A1) | a~:e(A2) *)
  apply (rule impI)
  apply (subgoal_tac "a\<notin>externals (asig_of (A1)) & a\<notin>externals (asig_of (A2))")
(* delete auxiliary subgoal *)
  prefer 2
  apply force
  apply (simp (no_asm) add: conj_disj_distribR cong add: conj_cong split: if_split)
  apply (tactic \<open>
    REPEAT((resolve_tac \<^context> [conjI, impI] 1 ORELSE eresolve_tac \<^context> [conjE] 1) THEN
      asm_full_simp_tac(\<^context> addsimps [@{thm comp1_reachable}, @{thm comp2_reachable}]) 1)\<close>)
  done

lemma reachable_rename_ioa: "[| reachable (rename C g) s |] ==> reachable C s"
  apply (simp add: reachable_def)
  apply (erule bexE)
  apply (rule_tac x = "((\<lambda>i. case (fst ex i) of None \<Rightarrow> None | Some (x) => g x) ,snd ex)" in bexI)
  apply (simp (no_asm))
(* execution is indeed an execution of C *)
  apply (simp add: executions_def is_execution_fragment_def par_def
    starts_of_def trans_of_def rename_def split: option.split)
  apply force
  done

lemma rename_through_pmap: "[| is_weak_pmap f C A |]
                       ==> (is_weak_pmap f (rename C g) (rename A g))"
  apply (simp add: is_weak_pmap_def)
  apply (rule conjI)
  apply (simp add: rename_def starts_of_def)
  apply (rule allI)+
  apply (rule imp_conj_lemma)
  apply (simp (no_asm) add: rename_def)
  apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
  apply safe
  apply (simplesubst if_split)
  apply (rule conjI)
  apply (rule impI)
  apply (erule disjE)
  apply (erule exE)
  apply (erule conjE)
(* x is input *)
  apply (drule sym)
  apply (drule sym)
  apply simp
  apply hypsubst+
  apply (cut_tac C = "C" and g = "g" and s = "s" in reachable_rename_ioa)
  apply assumption
  apply simp
(* x is output *)
  apply (erule exE)
  apply (erule conjE)
  apply (drule sym)
  apply (drule sym)
  apply simp
  apply hypsubst+
  apply (cut_tac C = "C" and g = "g" and s = "s" in reachable_rename_ioa)
  apply assumption
  apply simp
(* x is internal *)
  apply (simp (no_asm) cong add: conj_cong)
  apply (rule impI)
  apply (erule conjE)
  apply (cut_tac C = "C" and g = "g" and s = "s" in reachable_rename_ioa)
  apply auto
  done

declare if_split [split] if_weak_cong [cong]

end


section\<open>Theory of Cryptographic Keys for Security Protocols against the General Attacker\<close>

theory PublicGA imports EventGA begin

lemma invKey_K: "K \<in> symKeys \<Longrightarrow> invKey K = K"
by (simp add: symKeys_def)

subsection\<open>Asymmetric Keys\<close>

datatype keymode = Signature | Encryption

consts
  publicKey :: "[keymode,agent] => key"

abbreviation
  pubEK :: "agent => key" where
  "pubEK == publicKey Encryption"

abbreviation
  pubSK :: "agent => key" where
  "pubSK == publicKey Signature"

abbreviation
  privateKey :: "[keymode, agent] => key" where
  "privateKey b A == invKey (publicKey b A)"

abbreviation
  (*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
  priEK :: "agent => key" where
  "priEK A == privateKey Encryption A"

abbreviation
  priSK :: "agent => key" where
  "priSK A == privateKey Signature A"

text\<open>These abbreviations give backward compatibility.  They represent the
simple situation where the signature and encryption keys are the same.\<close>

abbreviation
  pubK :: "agent => key" where
  "pubK A == pubEK A"

abbreviation
  priK :: "agent => key" where
  "priK A == invKey (pubEK A)"

text\<open>By freeness of agents, no two agents have the same key.  Since
  @{term "True\<noteq>False"}, no agent has identical signing and encryption keys\<close>
specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' \<Longrightarrow> b=c \<and> A=A'"
   apply (rule exI [of _
       "%b A. 2 * case_agent (\<lambda>n. n + 2) A + case_keymode 0 1 b"])
   apply (auto simp add: inj_on_def split: agent.split keymode.split)
   apply presburger
   apply presburger
   done

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]: "privateKey b A \<noteq> publicKey c A'"

lemmas publicKey_neq_privateKey = privateKey_neq_publicKey [THEN not_sym]
declare publicKey_neq_privateKey [iff]

subsection\<open>Basic properties of @{term pubK} and @{term priK}\<close>

lemma publicKey_inject [iff]: "(publicKey b A = publicKey c A') = (b=c \<and> A=A')"
by (blast dest!: injective_publicKey)

lemma not_symKeys_pubK [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_priK [iff]: "privateKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKey_neq_priEK: "K \<in> symKeys \<Longrightarrow> K \<noteq> priEK A"
by auto

lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) \<Longrightarrow> K \<noteq> K'"
by blast

lemma symKeys_invKey_iff [iff]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

lemma analz_symKeys_Decrypt:
     "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
      ==> X \<in> analz H"
by (auto simp add: symKeys_def)

subsection\<open>"Image" equations that hold for injective functions\<close>

lemma invKey_image_eq [simp]: "(invKey x \<in> invKey`A) = (x \<in> A)"
by auto

(*holds because invKey is injective*)
lemma publicKey_image_eq [simp]:
     "(publicKey b x \<in> publicKey c ` AA) = (b=c \<and> x \<in> AA)"
by auto

lemma privateKey_notin_image_publicKey [simp]: "privateKey b x \<notin> publicKey c ` AA"
by auto

lemma privateKey_image_eq [simp]:
     "(privateKey b A \<in> invKey ` publicKey c ` AS) = (b=c \<and> A\<in>AS)"
by auto

lemma publicKey_notin_image_privateKey [simp]: "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

subsection\<open>Symmetric Keys\<close>

text\<open>For some protocols, it is convenient to equip agents with symmetric as
well as asymmetric keys.  The theory \<open>Shared\<close> assumes that all keys
are symmetric.\<close>

consts
  shrK    :: "agent => key"    \<comment> \<open>long-term shared keys\<close>

specification (shrK)
  inj_shrK: "inj shrK"
  \<comment> \<open>No two agents have the same long-term key\<close>
   apply (rule exI [of _ "case_agent (\<lambda>n. n + 2)"])
   apply (simp add: inj_on_def split: agent.split)
   done

axiomatization where
  sym_shrK [iff]: "shrK X \<in> symKeys" \<comment> \<open>All shared keys are symmetric\<close>

text\<open>Injectiveness: Agents' long-term keys are distinct.\<close>
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_shrK [simp]: "invKey (shrK A) = shrK A"
by (simp add: invKey_K)

lemma analz_shrK_Decrypt:
     "[| Crypt (shrK A) X \<in> analz H; Key(shrK A) \<in> analz H |] ==> X \<in> analz H"
by auto

lemma analz_Decrypt':
     "[| Crypt K X \<in> analz H; K \<in> symKeys; Key K \<in> analz H |] ==> X \<in> analz H"
by (auto simp add: invKey_K)

lemma priK_neq_shrK [iff]: "shrK A \<noteq> privateKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_priK = priK_neq_shrK [THEN not_sym]
declare shrK_neq_priK [simp]

lemma pubK_neq_shrK [iff]: "shrK A \<noteq> publicKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_pubK = pubK_neq_shrK [THEN not_sym]
declare shrK_neq_pubK [simp]

lemma priEK_noteq_shrK [simp]: "priEK A \<noteq> shrK B"
by auto

lemma publicKey_notin_image_shrK [simp]: "publicKey b x \<notin> shrK ` AA"
by auto

lemma privateKey_notin_image_shrK [simp]: "privateKey b x \<notin> shrK ` AA"
by auto

lemma shrK_notin_image_publicKey [simp]: "shrK x \<notin> publicKey b ` AA"
by auto

lemma shrK_notin_image_privateKey [simp]: "shrK x \<notin> invKey ` publicKey b ` AA"
by auto

lemma shrK_image_eq [simp]: "(shrK x \<in> shrK ` AA) = (x \<in> AA)"
by auto

text\<open>For some reason, moving this up can make some proofs loop!\<close>
declare invKey_K [simp]

subsection\<open>Initial States of Agents\<close>

overloading
  initState \<equiv> initState
begin

primrec initState where

  initState_Friend:
    "initState (Friend i) =
       {Key (priEK (Friend i)), Key (priSK (Friend i)), Key (shrK (Friend i))} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"
end

lemma used_parts_subset_parts [rule_format]:
     "\<forall>X \<in> used evs. parts {X} \<subseteq> used evs"
apply (induct evs)
 prefer 2
 apply (simp add: used_Cons)
 apply (rule ballI)
 apply (case_tac a, auto)
apply (auto dest!: parts_cut)
txt\<open>Base case\<close>
apply (simp add: used_Nil)
done

lemma MPair_used_D: "\<lbrace>X,Y\<rbrace> \<in> used H \<Longrightarrow> X \<in> used H \<and> Y \<in> used H"
by (drule used_parts_subset_parts, simp, blast)

text\<open>There was a similar theorem in Event.thy, so perhaps this one can
  be moved up if proved directly by induction.\<close>
lemma MPair_used [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> used H;
         [| X \<in> used H; Y \<in> used H |] ==> P |]
      ==> P"
by (blast dest: MPair_used_D)

text\<open>Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.\<close>

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C")
apply (auto intro: range_eqI)
done

lemma Crypt_notin_initState: "Crypt K X \<notin> parts (initState B)"
by (induct B, auto)

lemma Crypt_notin_used_empty [simp]: "Crypt K X \<notin> used []"
by (simp add: Crypt_notin_initState used_Nil)

(*** Basic properties of shrK ***)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_knows [iff]: "Key (shrK A) \<in> knows A evs"
by (simp add: initState_subset_knows [THEN subsetD])

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(** Fresh keys never clash with long-term shared keys **)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range shrK"
by blast

lemma shrK_neq: "Key K \<notin> used evs \<Longrightarrow> shrK B \<noteq> K"
by blast

lemmas neq_shrK = shrK_neq [THEN not_sym]
declare neq_shrK [simp]

subsection\<open>Function @{term "knows Spy"}\<close>

lemma not_SignatureE [elim!]: "b \<noteq> Signature \<Longrightarrow> b = Encryption"
  by (cases b, auto)

text\<open>Agents see their own private keys!\<close>
lemma priK_in_initState [iff]: "Key (privateKey b A) \<in> initState A"
  by (cases A, auto)

text\<open>Agents see all public keys!\<close>
lemma publicKey_in_initState [iff]: "Key (publicKey b A) \<in> initState B"
  by (cases B, auto)

text\<open>All public keys are visible\<close>
lemma spies_pubK [iff]: "Key (publicKey b A) \<in> knows B evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split: event.split)
done

lemmas analz_spies_pubK = spies_pubK [THEN analz.Inj]
declare analz_spies_pubK [iff]

(*Note: there never is at this stage a lemma about what an agent cannot know*)

lemma publicKey_into_used [iff] :"Key (publicKey b A) \<in> used evs"
apply (rule initState_into_used)
apply (rule publicKey_in_initState [THEN parts.Inj])
done

lemma privateKey_into_used [iff]: "Key (privateKey b A) \<in> used evs"
apply(rule initState_into_used)
apply(rule priK_in_initState [THEN parts.Inj])
done

lemma Crypt_analz_bad:
     "[| Crypt (shrK A) X \<in> analz (knows A evs) |]
      ==> X \<in> analz (knows A evs)"
by force

subsection\<open>Fresh Nonces\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection\<open>Supply fresh nonces for possibility theorems\<close>

text\<open>In any trace, there is an upper bound N on the greatest nonce in use\<close>
lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split: event.split)
apply safe
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection\<open>Specialized Rewriting for Theorems About @{term analz} and Image\<close>

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
by blast

lemma Crypt_imp_keysFor :"[|Crypt K X \<in> H; K \<in> symKeys|] ==> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text\<open>Lemma for the trivial direction of the if-and-only-if of the
Session Key Compromise Theorem\<close>
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) \<longrightarrow> (K \<in> nE | Key K \<in> analz H)  \<Longrightarrow>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment> \<open>these two allow its use with @{text "only:"}\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD]
       insert_Key_singleton
       Key_not_used insert_Key_image Un_assoc [THEN sym]

ML \<open>
structure Public =
struct

val analz_image_freshK_ss =
  simpset_of (@{context}
    delsimps [image_insert, image_Un]
    delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
    addsimps @{thms analz_image_freshK_simps})

(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt delsimps [@{thm used_Says}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

end
\<close>

method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Public.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

subsection\<open>Specialized Methods for Possibility Theorems\<close>

method_setup possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o Public.possibility_tac)\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o Public.basic_possibility_tac)\<close>
    "for proving possibility theorems"

end


theory step_rel
imports memory_model trans_sim
begin

locale step_rel = memory_model
 where actions =  "actions :: (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action set"
    and locations = "locations :: loc_type set"
    and actionIDs = "actionIDs :: aid_type set"
    and times = "times :: time_type set"
    and threads = "threads :: 'tid set"
    and locks = "locks :: 'lock set"
    and names = "names :: 'name set"
    and callIDs = "callIDs :: 'callID set"
    and free_set = "free_set:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)
             \<Rightarrow> time_type \<Rightarrow> loc_type set"
    and can_read = "can_read:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)
                 \<Rightarrow> 'tid \<Rightarrow> time_type \<Rightarrow> loc_type \<Rightarrow> 'val set"
    and update_mem = "update_mem:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)
                       \<Rightarrow> time_type \<Rightarrow> ('tid \<times> aid_type \<times>
                             (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) set
                        \<Rightarrow> (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option) \<Rightarrow> bool"
    and start_mem = "start_mem:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)"
  for actions locations actionIDs times threads locks names callIDs
         free_set can_read update_mem start_mem +
  fixes step_rel::"'tid \<Rightarrow> time_type \<Rightarrow> ('node, 'edge_type, 'instr) flowgraph \<Rightarrow> (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option) \<Rightarrow> 'config \<Rightarrow>
   ('tid \<times> aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) set \<Rightarrow> 'config \<Rightarrow> bool"
  and start_state::"('tid \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph)
                                \<Rightarrow> time_type \<Rightarrow> ('tid \<rightharpoonup> 'config) \<Rightarrow> (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option) \<Rightarrow> bool"
  and get_point::"'config \<Rightarrow> 'node"
  and instr_edges::"'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq::'edge_type
  assumes start_points [simp]: "start_state CFGs t S m
         \<Longrightarrow> (\<lambda> x . case S x of Some a \<Rightarrow> (\<lambda>C. Some (get_point C)) a
                              | None \<Rightarrow> None) = start_points CFGs"
      and step_along_edge: "\<lbrakk>step_rel tid t G m C ops C'; is_flowgraph G Seq instr_edges; get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow>
    \<exists>ty. (get_point C, get_point C', ty) \<in> Edges (G::('node, 'edge_type, 'instr) flowgraph)"

begin

lemma step_safe: "\<lbrakk>step_rel tid t G m C ops C'; is_flowgraph G Seq instr_edges; get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow>
    get_point C' \<in> Nodes G"
by (drule step_along_edge, simp+, simp add: is_flowgraph_def flowgraph_def pointed_graph_def)

abbreviation "well_formed G \<equiv> is_flowgraph G Seq instr_edges"

inductive one_step where
step_single [intro!]: "\<lbrakk>step_rel tid t G mem C ops C'; update_mem mem t ops mem'\<rbrakk> \<Longrightarrow>
  one_step tid G (t,C, mem) (Suc t,C', mem')"

lemma one_step_safe: "\<lbrakk>one_step tid G (t,C, mem) (t',C', mem'); well_formed G; get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow>
  get_point C' \<in> Nodes G"
by (erule one_step.cases, rule step_safe, simp+)

lemma one_step_along_edge: "\<lbrakk>one_step tid G (t,C, m) (t',C', m'); is_flowgraph G Seq instr_edges;
  get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow> \<exists>ty. (get_point C, get_point C', ty) \<in> Edges G"
by (erule one_step.cases, rule step_along_edge, simp+)

inductive conc_step where
step_thread [intro]: "\<lbrakk>CFGs tid = Some G; states tid = Some C; step_rel tid t G mem C ops C';
  update_mem mem t ops mem'\<rbrakk> \<Longrightarrow> conc_step CFGs (t,states, mem) (Suc t,states(tid \<mapsto> C'), mem')"

abbreviation "get_points (S::'tid \<rightharpoonup> 'config) \<equiv>
                  (\<lambda> x . case S x of Some a \<Rightarrow> (\<lambda>C. Some (get_point C)) a
                              | None \<Rightarrow> None)"

lemma one_step_conc_step: "\<lbrakk>one_step tid G (t,C, m) (t',C', m'); CFGs tid = Some G; states tid = Some C\<rbrakk> \<Longrightarrow>
  conc_step CFGs (t,states, m) (t',states(tid \<mapsto> C'), m')"
  apply (erule one_step.cases)
  by blast

term "safe_points"

lemma conc_step_safe: "\<lbrakk>conc_step CFGs (t,states, mem) (t',states', mem'); tCFG CFGs instr_edges Seq;
  safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points states')"
apply (erule conc_step.cases, clarsimp simp add: safe_points_def)
apply (case_tac "t = t", clarsimp)
apply (rule step_safe, simp+)
apply (erule tCFG.CFGs, simp)
apply force
apply (force simp add: map_comp_def)
done

lemma conc_steps_safe: "\<lbrakk>(conc_step CFGs)^** (t,states, mem) (t',states', mem'); tCFG CFGs instr_edges Seq;
  safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points states')"
by (drule_tac P="\<lambda>(t,states, mem) (t',states', mem'). safe_points CFGs (get_points states) \<longrightarrow>
  safe_points CFGs (get_points states')" in rtranclp.induct, auto intro: conc_step_safe)

definition "run_prog CFGs C \<equiv> \<exists>t C0 mem0. start_state CFGs t C0 mem0 \<and> (conc_step CFGs)^** (t,C0, mem0) C"

lemma run_progI [intro]: "\<lbrakk>start_state CFGs t C0 mem0; (conc_step CFGs)^** (t,C0, mem0) C\<rbrakk> \<Longrightarrow>
  run_prog CFGs C"
by (force simp add: run_prog_def)

lemma run_prog_conc_step [intro]: "\<lbrakk>run_prog CFGs C; conc_step CFGs C C'\<rbrakk> \<Longrightarrow> run_prog CFGs C'"
  by (meson rtranclp.rtrancl_into_rtrancl run_prog_def)

lemma run_prog_conc_steps [intro]: "\<lbrakk>run_prog CFGs C; (conc_step CFGs)^** C C'\<rbrakk> \<Longrightarrow> run_prog CFGs C'"
  by (meson rtranclp_trans run_prog_def)

lemma run_prog_induct [elim]: "\<lbrakk>run_prog CFGs C; \<And>t C0 mem0. start_state CFGs t C0 mem0 \<Longrightarrow> P (t,C0, mem0);
 \<And>C C'. run_prog CFGs C \<Longrightarrow> P C \<Longrightarrow> conc_step CFGs C C' \<Longrightarrow> P C'\<rbrakk> \<Longrightarrow> P C"
apply (clarsimp simp add: run_prog_def)
  by (smt conc_step.cases rtranclp_induct)

lemma run_prog_one_step: "\<lbrakk>run_prog CFGs (t,S, mem); S tid = Some s; CFGs tid = Some G;
 one_step tid G (t,s, mem) (t',s', mem')\<rbrakk> \<Longrightarrow> run_prog CFGs (t',S(tid \<mapsto> s'), mem')"
  apply (erule run_prog_conc_step)
  by (simp add: one_step_conc_step)

lemma run_prog_one_steps: "\<lbrakk>run_prog CFGs (t,S, mem); S tid = Some s; CFGs tid = Some G;
 (one_step tid G)^** (t,s, mem) (t',s', mem')\<rbrakk> \<Longrightarrow> run_prog CFGs (t',S(tid \<mapsto> s'), mem')"
apply (drule_tac P="\<lambda>(t,s, mem) (t',s', mem'). run_prog CFGs (t,S, mem) \<and> S tid = Some s \<and> CFGs tid = Some G \<longrightarrow>
  run_prog CFGs (t',S(tid \<mapsto> s'), mem')" in rtranclp.induct, auto simp add: map_upd_triv)
apply (drule_tac mem=ba in run_prog_one_step, simp+, force, simp+)
done

lemma run_prog_step: "\<lbrakk>run_prog CFGs (t,S, mem); S tid = Some s; CFGs tid = Some G;
 step_rel tid t G mem s ops s'; update_mem mem t ops mem'\<rbrakk> \<Longrightarrow> run_prog CFGs (Suc t,S(tid \<mapsto> s'), mem')"
  by (erule run_prog_one_step, auto)

lemma run_prog_safe: "\<lbrakk>run_prog CFGs (t,S, mem); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points S)"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs (t,S, mem); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points S)"
by (clarsimp simp add: run_prog_def, rule conc_steps_safe, simp+)
qed

(* paths *)
lemma step_increment_path: "\<lbrakk>step_rel tid t G m C a C'; tCFG CFGs instr_edges Seq; CFGs tid = Some G;
  l \<in> pre_tCFG.Paths CFGs ps; p = get_point C; p' = get_point C'; ps tid = Some p'; p \<in> Nodes G\<rbrakk> \<Longrightarrow>
  [ps(tid \<mapsto> p)] \<frown> l \<in> pre_tCFG.Paths CFGs (ps(tid \<mapsto> p))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>step_rel tid t G m C a C'; tCFG CFGs instr_edges Seq; CFGs tid = Some G;
  l \<in> pre_tCFG.Paths CFGs ps; p = get_point C; p' = get_point C'; ps tid = Some p'; p \<in> Nodes G\<rbrakk> \<Longrightarrow>
  [ps(tid \<mapsto> p)] \<frown> l \<in> pre_tCFG.Paths CFGs (ps(tid \<mapsto> p))"
apply (rule pre_tCFG.path_incremental_gen, unfold_locales, simp)
apply (frule step_along_edge)
apply (erule tCFG.CFGs, simp+)
done
qed

lemma step_increment_rpath: "\<lbrakk>step_rel tid t G m C a C'; tCFG CFGs instr_edges Seq; CFGs tid = Some G;
  l \<in> pre_tCFG.RPaths CFGs ps; p0 = get_point C; p = get_point C'; ps tid = Some p0; p0 \<in> Nodes G\<rbrakk> \<Longrightarrow>
 [ps(tid \<mapsto> p)] \<frown> l \<in> pre_tCFG.RPaths CFGs (ps(tid \<mapsto> p))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>step_rel tid t G m C a C'; tCFG CFGs instr_edges Seq; CFGs tid = Some G;
  l \<in> pre_tCFG.RPaths CFGs ps; p0 = get_point C; p = get_point C'; ps tid = Some p0; p0 \<in> Nodes G\<rbrakk> \<Longrightarrow>
 [ps(tid \<mapsto> p)] \<frown> l \<in> pre_tCFG.RPaths CFGs (ps(tid \<mapsto> p))"
apply (rule rpath_incremental_gen, simp+, clarsimp)
apply (frule step_along_edge)
apply (erule tCFG.CFGs, simp+)
done
qed

lemma one_step_increment_path: "\<lbrakk>one_step tid G (t,C, m) (t',C', m'); tCFG CFGs instr_edges Seq; CFGs tid = Some G;
  l \<in> pre_tCFG.Paths CFGs ps; p = get_point C; p' = get_point C'; ps tid = Some p'; p \<in> Nodes G\<rbrakk> \<Longrightarrow>
  [ps(tid \<mapsto> p)] \<frown> l \<in> pre_tCFG.Paths CFGs (ps(tid \<mapsto> p))"
by (erule one_step.cases, rule step_increment_path, simp+)

lemma one_step_increment_rpath: "\<lbrakk>one_step tid G (t,C, m) (t',C', m'); tCFG CFGs instr_edges Seq; CFGs tid = Some G;
  l \<in> pre_tCFG.RPaths CFGs ps; p0 = get_point C; p = get_point C'; ps tid = Some p0; p0 \<in> Nodes G\<rbrakk> \<Longrightarrow>
 [ps(tid \<mapsto> p)] \<frown> l \<in> pre_tCFG.RPaths CFGs (ps(tid \<mapsto> p))"
by (erule one_step.cases, rule step_increment_rpath, simp+)

lemma conc_step_increment_path: "\<lbrakk>conc_step CFGs C C'; tCFG CFGs instr_edges Seq;
  l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C'))); safe_points CFGs (get_points (fst (snd C)))\<rbrakk> \<Longrightarrow>
 [get_points (fst (snd C))] \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C)))"
apply (auto elim!: conc_step.cases)
apply (frule_tac ps="get_points (states(tid \<mapsto> C'a))" in step_increment_path, auto simp add: safe_points_def)
apply force
apply (subgoal_tac "get_points (states(tid \<mapsto> C'a))(tid \<mapsto> get_point Ca) = get_points states", simp)
apply (rule ext, clarsimp simp add: map_comp_def)
done

lemma conc_steps_path: "\<lbrakk>(conc_step CFGs)^** (t,states, mem) (t',states', mem'); tCFG CFGs instr_edges Seq;
  l \<in> pre_tCFG.Paths CFGs (get_points states'); safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points states \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points states)"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>(conc_step CFGs)^** (t,states, mem) (t',states', mem'); tCFG CFGs instr_edges Seq;
  l \<in> pre_tCFG.Paths CFGs (get_points states'); safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points states \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points states)"
apply (drule_tac P="\<lambda>(t,states, mem) (t',states', mem'). \<forall>l. l \<in> pre_tCFG.Paths CFGs (get_points states') \<and>
  safe_points CFGs (get_points states) \<longrightarrow> (\<exists>l'. hd (l' @ [l 0]) = get_points states \<and>
  l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points states))" in rtranclp.induct, auto)
apply (rule_tac x="[]" in exI, simp)
apply (drule conc_step_increment_path, simp+)
apply (drule conc_steps_safe, simp+)
by (metis append_is_Nil_conv hd_append2 i_append_assoc i_append_nth_Cons_0 not_Cons_self2)
qed

lemma run_prog_path: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>t C0 mem0. start_state CFGs t C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs). \<exists>i. l i = get_points (fst (snd C)))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>t C0 mem0. start_state CFGs t C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs). \<exists>i. l i = get_points (fst (snd C)))"
apply (clarsimp simp add: run_prog_def)
apply (cut_tac q="get_points (fst (snd C))" in exists_path, clarsimp)
apply (case_tac C, clarsimp)
apply (drule conc_steps_path, simp+)
apply clarsimp
apply (rule conjI, force)
apply (rule_tac x="l' \<frown> l" in bexI, simp_all)
apply (rule_tac x="length l'" in exI, simp)
done
qed

(* The step-star relation as inducing a list of intermediate states. *)
lemma conc_step_star_steps: "(conc_step CFGs)^** C C' \<Longrightarrow>
 \<exists>l. hd (l @ [C']) = C \<and> (\<forall>i<length l. conc_step CFGs (l ! i) ((l @ [C']) ! Suc i))"
apply (induct rule: rtranclp_induct, auto)
apply (rule_tac x="[]" in exI, simp)
apply (rule_tac x="l @ [(a,aa, b)]" in exI, clarsimp)
apply (rule conjI, case_tac l, simp+)
apply clarsimp
apply (case_tac "i = length l", clarsimp simp add: nth_append)
apply (erule_tac x=i in allE, auto simp add: nth_append)
done

lemma step_star_path: "\<lbrakk>hd (l' @ [C']) = C; \<forall>i<length l'. conc_step CFGs (l' ! i) ((l' @ [C']) ! Suc i);
 l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C'))); safe_points CFGs (get_points (fst (snd C)));
          tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 map (get_points o (\<lambda> x . fst (snd x))) l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C)))"
apply (induct l' arbitrary: C l, auto)
apply (case_tac l', auto)
apply (drule conc_step_increment_path, simp+)
apply (subgoal_tac "(get_points aa # map (get_points \<circ> (\<lambda> x . fst (snd x))) list) \<frown> l \<in> pre_tCFG.Paths CFGs (get_points aa)")
   apply (erule_tac x=0 in allE,clarsimp)
apply (drule conc_step_increment_path, simp+)
apply (subgoal_tac "\<forall>i<Suc (length list). conc_step CFGs (((a, aa, b) # list) ! i) ((list @ [C']) ! i)")
apply (subgoal_tac "safe_points CFGs (get_points aa)")
apply (erule_tac x=0 in allE, clarsimp, rule conc_step_safe, auto)
done

lemma run_prog_steps: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l t C0 mem0. start_state CFGs t C0 mem0 \<and>
 (\<forall>i<length l. conc_step CFGs (l ! i) ((l @ [C]) ! Suc i)) \<and>
 (\<exists>l'\<in>pre_tCFG.Paths CFGs (get_points (fst (snd C))).
                 map (get_points o (\<lambda> x . fst (snd x))) l \<frown> l' \<in> pre_tCFG.Paths CFGs (start_points CFGs))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l t C0 mem0. start_state CFGs t C0 mem0 \<and>
 (\<forall>i<length l. conc_step CFGs (l ! i) ((l @ [C]) ! Suc i)) \<and>
 (\<exists>l'\<in>pre_tCFG.Paths CFGs (get_points (fst (snd C))).
           map (get_points o (\<lambda> x . fst (snd x))) l \<frown> l' \<in> pre_tCFG.Paths CFGs (start_points CFGs))"
apply (clarsimp simp add: run_prog_def)
apply (drule conc_step_star_steps, clarsimp)
apply (cut_tac q="get_points (fst (snd C))" in exists_path, clarsimp)
apply (frule step_star_path, simp+)
apply (rule conjI, force+)
done
qed

lemma conc_step_star_path2: "\<lbrakk>(conc_step CFGs)^** C C'; l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C')));
 safe_points CFGs (get_points (fst (snd C))); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points (fst (snd C)) \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C))) \<and>
 (\<forall>i<length l'. \<exists>C''. l' ! i = get_points (fst (snd C'')) \<and> (conc_step CFGs)^** C C'' \<and> (conc_step CFGs)^** C'' C')"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>(conc_step CFGs)^** C C'; l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C')));
 safe_points CFGs (get_points (fst (snd C))); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points (fst (snd C)) \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst (snd C))) \<and>
 (\<forall>i<length l'. \<exists>C''. l' ! i = get_points (fst (snd C'')) \<and> (conc_step CFGs)^** C C'' \<and> (conc_step CFGs)^** C'' C')"
apply (induct arbitrary: l rule: rtranclp_induct, auto)
apply (rule_tac x="[]" in exI, simp)
apply (frule conc_step_increment_path, simp+)
apply (case_tac C, rule conc_steps_safe, simp+)
apply (subgoal_tac "\<exists>l'. hd (l' @ [get_points aa]) = get_points (fst (snd C)) \<and> l' \<frown> [get_points aa] \<frown> l \<in>
 pre_tCFG.Paths CFGs (get_points (fst (snd C))) \<and> (\<forall>i<length l'. \<exists>ab ac. l' ! i = get_points ac \<and> (\<exists>ba.
 (conc_step CFGs)^** C (ab, ac, ba) \<and> (conc_step CFGs)^** (ab, ac, ba) (a,aa, b)))", clarsimp)
apply (rule_tac x="l' @ [get_points aa]" in exI, clarsimp)
apply (rule conjI, case_tac l', simp+)
apply clarsimp
   apply (case_tac "i = length l'", clarsimp)
  apply (rule_tac x =a in exI)
apply (rule_tac x=aa in exI, simp, rule_tac x=b in exI, simp)
   apply (erule_tac x=i in allE, clarsimp)
  apply (rule_tac x = aba in exI)
apply (rule_tac x=aca in exI, simp add: nth_append)
apply (rule_tac x=baa in exI, simp)
  by blast
qed

lemma run_prog_path2: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>t C0 mem0. start_state CFGs t C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs).
    \<exists>i. l i = get_points (fst (snd C)) \<and> (\<forall>j<i. \<exists>C'. run_prog CFGs C' \<and> l j = get_points (fst (snd C'))))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>t C0 mem0. start_state CFGs t C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs).
    \<exists>i. l i = get_points (fst (snd C)) \<and> (\<forall>j<i. \<exists>C'. run_prog CFGs C' \<and> l j = get_points (fst (snd C'))))"
apply (clarsimp simp add: run_prog_def)
apply (cut_tac q="get_points (fst (snd C))" in exists_path, clarsimp)
apply (drule conc_step_star_path2, simp+)
apply clarsimp
apply (rule conjI, force)
apply (rule_tac x="l' \<frown> l" in bexI, simp_all)
apply (rule_tac x="length l'" in exI, clarsimp)
by smt
qed

lemma run_prog_rpath: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>l. l \<in> pre_tCFG.RPaths CFGs (get_points (fst (snd C)))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>l. l \<in> pre_tCFG.RPaths CFGs (get_points (fst (snd C)))"
by (drule run_prog_path, simp, clarsimp, drule_tac i=i in reverse_path, simp, force)
qed

(* simulation relations and lifting *)
definition "lift_reach_sim_rel sim_rel CFGs CFGs' tid C C' \<equiv>
 run_prog CFGs C \<and> run_prog CFGs' C' \<and> (case (C, C') of ((t,states, mem), (t',states', mem')) \<Rightarrow>
 (\<exists>s s' G G'. states tid = Some s \<and> states' tid = Some s' \<and> CFGs tid = Some G \<and> CFGs' tid = Some G' \<and>
 sim_rel G G' (t,s, mem) (t',s', mem')) \<and> (\<forall>tid'. tid' \<noteq> tid \<longrightarrow> states tid' = states' tid'))"

definition "add_reach CFGs CFGs' tid sim_rel G G' c c' \<equiv> \<exists>S S'. S tid = Some (fst (snd c)) \<and>
 run_prog CFGs (fst c, S, snd (snd c)) \<and> S' tid = Some (fst (snd c'))
         \<and> run_prog CFGs' (fst c', S', snd (snd c')) \<and> sim_rel G G' c c'"

lemma add_reach_sim_rel: "\<lbrakk>sim_rel G G' c c'; \<exists>S S'. S tid = Some (fst (snd c)) \<and> run_prog CFGs (fst c, S, snd (snd c)) \<and>
  S' tid = Some (fst (snd c')) \<and> run_prog CFGs' (fst c',S', snd (snd c'))\<rbrakk> \<Longrightarrow>
 add_reach CFGs CFGs' tid sim_rel G G' c c'"
by (simp add: add_reach_def)

end

fun acLoc' where
"acLoc' (x,y,z) = (case acLoc z of None \<Rightarrow> 0 | Some v \<Rightarrow> v)"

abbreviation "get_ptrs S \<equiv> acLoc' ` S"
abbreviation "get_thread a \<equiv> (\<lambda> (x,y,z) . x) a"

locale sim_base = step_rel
  where actions =  "actions :: (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action set"
    and locations = "locations :: loc_type set"
    and actionIDs = "actionIDs :: aid_type set"
    and times = "times :: time_type set"
    and threads = "threads :: 'tid set"
    and locks = "locks :: 'lock set"
    and names = "names :: 'name set"
    and callIDs = "callIDs :: 'callID set"
    and free_set = "free_set:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)
             \<Rightarrow> time_type \<Rightarrow> loc_type set"
    and can_read = "can_read:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)
                 \<Rightarrow> 'tid \<Rightarrow> time_type \<Rightarrow> loc_type \<Rightarrow> 'val set"
    and update_mem = "update_mem:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)
                       \<Rightarrow> time_type \<Rightarrow> ('tid \<times> aid_type \<times>
                             (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) set
                        \<Rightarrow> (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option) \<Rightarrow> bool"
    and start_mem = "start_mem:: (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option)"
  and step_rel = "step_rel::'tid \<Rightarrow> time_type \<Rightarrow> ('node, 'edge_type, 'instr) flowgraph \<Rightarrow> (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option) \<Rightarrow> 'config \<Rightarrow>
   ('tid \<times> aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) set \<Rightarrow> 'config \<Rightarrow> bool"
  and start_state = "start_state ::
                    ('tid \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph)
                                \<Rightarrow> time_type \<Rightarrow> ('tid \<rightharpoonup> 'config) \<Rightarrow> (('tid \<times> time_type \<times> loc_type)
            \<Rightarrow> (aid_type \<times> (aid_type, 'val, loc_type, 'lock, 'name, 'callID) action) option) \<Rightarrow> bool"
  and get_point = "get_point::'config \<Rightarrow> 'node"
  and instr_edges = "instr_edges:: 'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq = "Seq :: 'edge_type"
 +tCFG? : tCFG
   where CFGs="CFGs::('tid \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph)"
   and instr_edges="instr_edges::'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq="Seq::'edge_type" +
  tCFG': tCFG
   where CFGs="CFGs'::('tid \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph)"
   and instr_edges="instr_edges::'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq="Seq::'edge_type"
  for actions locations actionIDs times threads locks names callIDs
         free_set can_read update_mem start_mem step_rel start_state get_point instr_edges Seq
          CFGs CFGs' +
  assumes step_read_ops: "\<lbrakk>step_rel tid t G mem C ops C'; CFGs tid = Some G;
    \<forall>l\<in>get_ptrs ops. can_read mem tid t l = can_read mem' tid t l; free_set mem = free_set mem'\<rbrakk> \<Longrightarrow>
    step_rel tid t G mem' C ops C'"
      and ops_thread: "\<lbrakk>step_rel tid t G mem state ops state'; CFGs tid = Some G; a \<in> ops\<rbrakk>
                      \<Longrightarrow> get_thread a = tid"

begin

thm step_thread

lemma sim_by_reachable_thread_mem_obs [rule_format]:
"\<lbrakk>tCFG_sim (add_reach CFGs' CFGs tid sim_rel G' G) (=) G' G (one_step tid) obs (get_mem o (\<lambda> x . snd (snd x)));
 CFGs tid = Some G; CFGs' tid = Some G'; \<forall>tid'. tid' \<noteq> tid \<longrightarrow> CFGs tid' = CFGs' tid'; \<forall>t mem s t' mem' s'.
 sim_rel G' G (t,s, mem) (t',s', mem') \<longrightarrow> (\<forall>S. run_prog CFGs' (t,S, mem) \<longrightarrow> (free_set mem = free_set mem' \<and>
 (\<forall>tid' ops s1 s2. run_prog CFGs' (t,S, mem) \<and> run_prog CFGs (t',S(tid \<mapsto> s'), mem') \<and> S tid = Some s \<and>
 S tid' = Some s1 \<and> tid' \<noteq> tid \<and> tid' \<in> dom CFGs \<longrightarrow> (step_rel tid' t' (the (CFGs tid')) mem s1 ops s2  \<longrightarrow>
 (\<forall>l\<in>get_ptrs ops. can_read mem tid' t l = can_read mem' tid' t' l)) \<and>
 (step_rel tid' t' (the (CFGs tid')) mem' s1 ops s2  \<longrightarrow> (\<forall>mem2. update_mem mem t ops mem2 \<and> tid \<notin> get_thread ` ops \<longrightarrow>
 (\<exists>mem2'. update_mem mem' t' ops mem2' \<and> (\<forall>l\<in>obs. get_mem mem2' l = get_mem mem2 l)
       \<and> sim_rel G' G (t,s, mem2) (t',s', mem2')))))))\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs tid) (=) CFGs' CFGs conc_step obs (get_mem o (\<lambda> x . snd (snd x)))"
apply (simp add: tCFG_sim_def, unfold_locales, clarsimp simp add: trsys_of_tCFG_def)
apply (rule conc_step.cases, simp+, clarsimp simp add: lift_reach_sim_rel_def)
apply (rule conjI, clarsimp)
apply (drule_tac sa="(t,C, mem)" and sb="(ab,s', ba)" in simulation.simulation)
     apply (clarsimp simp add: add_reach_def)
apply (rule_tac x=states in exI, simp, rule_tac x=ac in exI, simp)
apply (clarsimp simp add: trsys_of_tCFG_def)
apply (rule conjI, erule step_single, simp+)
apply (clarsimp simp add: trsys_of_tCFG_def add_reach_def)
   apply (erule one_step.cases, clarsimp)
  apply ((rule exI)+, rule context_conjI)
    apply (rule_tac tid=tid in step_thread)
    apply (simp add: dom_def, simp+)
   apply (rule conjI,erule run_prog_step,simp+)
apply (erule run_prog_step, simp+)
apply clarsimp
  apply (subgoal_tac "ac = states(tid \<mapsto> s')")
  apply (thin_tac "\<forall>tid'. tid' \<noteq> tid \<longrightarrow> states tid' = ac tid'", clarsimp)
   apply(erule_tac x = tida in allE)
   apply (erule_tac x = t in allE)
   apply (erule_tac x = mem in allE)
  apply (erule_tac x = s in allE)
   apply (erule_tac x = ab in allE)
   apply (erule_tac x = ba in allE)
  apply (erule_tac x = s' in allE)
   apply (erule impE, simp)
  apply (erule impE,simp)
apply (erule_tac x=states in allE, clarsimp)
apply (erule_tac x=tida in allE, erule_tac x=ops in allE, erule_tac x=C in allE, simp, erule impE,
  simp add: dom_def)
apply (erule_tac x=C' in allE, clarsimp)
   apply (drule_tac mem=mem and mem'=ba in step_read_ops,simp,clarsimp)
     apply (case_tac "acLoc b",clarsimp)
  sorry
(*apply (erule_tac x=mem' in allE, clarsimp)
apply (erule impE, clarsimp)
apply (cut_tac t=ta in ops_thread, simp_all, simp+)
apply clarsimp
apply (rule exI, rule_tac x=mem2' in exI, rule context_conjI, rule_tac t=ta in step_thread,
 simp add: dom_def, simp+)
apply (rule conjI, erule run_prog_conc_step, simp+)
apply (rule conjI, erule run_prog_conc_step, simp+)
apply (clarsimp intro!: ext simp add: restrict_map_def)
apply (rule ext, simp)
done*)

(* Slightly reorganized other-threads hypothesis. *)
lemma sim_by_reachable_thread_obs [rule_format]:
"\<lbrakk>tCFG_sim (add_reach CFGs' CFGs t sim_rel G' G) (=) G' G (one_step tid) obs (get_mem o (\<lambda> x . snd (snd x)));
 CFGs tid = Some G; CFGs' tid = Some G'; \<forall>tid'. tid' \<noteq> tid \<longrightarrow> CFGs tid' = CFGs' tid';
 \<forall>t mem s t' mem' s'. sim_rel G' G (t,s, mem) (t',s', mem') \<longrightarrow> (free_set mem = free_set mem' \<and>
 (\<forall>tid' ops s1 s2 S. run_prog CFGs' (t,S, mem) \<and> run_prog CFGs (t',S(tid \<mapsto> s'), mem') \<and>
 S tid = Some s \<and> S tid' = Some s1 \<and> tid' \<noteq> tid \<and> tid' \<in> dom CFGs \<longrightarrow>
 (step_rel tid' t' (the (CFGs tid')) mem s1 ops s2
    \<longrightarrow> (\<forall>l\<in>get_ptrs ops. can_read mem tid' t l = can_read mem' tid' t' l)) \<and>
 (step_rel tid' t' (the (CFGs tid')) mem' s1 ops s2
   \<longrightarrow> (\<forall>mem2. update_mem mem t ops mem2 \<and> tid \<notin> get_thread ` ops \<longrightarrow>
 (\<exists>mem2'. update_mem mem' t ops mem2'
      \<and> (\<forall>l\<in>obs. get_mem mem2' l = get_mem mem2 l) \<and> sim_rel G' G (t,s, mem2) (t',s', mem2'))))))\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs tid) (=) CFGs' CFGs conc_step obs (get_mem o (\<lambda> x . snd (snd x)))"
  apply (rule sim_by_reachable_thread_mem_obs, simp+)
  sorry

(*
apply clarsimp
apply (erule_tac x=mem in allE, erule_tac x=s in allE, erule_tac x=mem' in allE,
  erule_tac x=s' in allE, erule impE, assumption, clarsimp)
apply (erule_tac x=t' in allE, erule_tac x=ops in allE, erule_tac x=s1 in allE, erule impE)
apply (rule_tac x=S in exI, force)
apply (erule_tac x=s2 in allE, force)
done

lemma sim_by_reachable_thread [rule_format]: "\<lbrakk>tCFG_sim (add_reach CFGs' CFGs t sim_rel G' G) (=)
 G' G (one_step t) UNIV (get_mem o snd); CFGs t = Some G; CFGs' t = Some G';
 \<forall>t'. t' \<noteq> t \<longrightarrow> CFGs t' = CFGs' t'; \<forall>mem s mem' s'. sim_rel G' G (s, mem) (s', mem') \<longrightarrow>
 (free_set mem = free_set mem' \<and> (\<forall>t'. t' \<noteq> t \<longrightarrow> can_read mem t' = can_read mem' t') \<and>
 (\<forall>ops mem2. update_mem mem ops mem2 \<and> t \<notin> get_thread ` ops \<longrightarrow>
 (\<exists>mem2'. update_mem mem' ops mem2' \<and> get_mem mem2' = get_mem mem2 \<and> sim_rel G' G (s, mem2) (s', mem2'))))\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs t) (=) CFGs' CFGs conc_step UNIV (get_mem o snd)"
apply (erule sim_by_reachable_thread_obs, auto simp add: fun_upd_def)
by (smt UNIV_I UNIV_eq_I domD domI)

lemma sim_no_mem [rule_format]: "\<lbrakk>tCFG_sim (add_reach CFGs' CFGs t sim_rel G' G) (=)
 G' G (one_step t) UNIV (get_mem o snd); CFGs t = Some G; CFGs' t = Some G';
 \<forall>t'. t' \<noteq> t \<longrightarrow> CFGs t' = CFGs' t'; \<forall>mem s mem' s'. sim_rel G' G (s, mem) (s', mem') \<longrightarrow> mem = mem';
 \<forall>s s' mem ops mem'. sim_rel G' G (s, mem) (s', mem) \<and> t \<notin> get_thread ` ops \<and> update_mem mem ops mem' \<longrightarrow>
 sim_rel G' G (s, mem') (s', mem')\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs t) (=) CFGs' CFGs conc_step UNIV (get_mem o snd)"
by (rule sim_by_reachable_thread, simp+, metis)

*)
end

end