(*  Title:      HOL/UNITY/Simple/NSP_Bad.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Original file is ../Auth/NS_Public_Bad
*)

section\<open>Analyzing the Needham-Schroeder Public-Key Protocol in UNITY\<close>

theory NSP_Bad imports "HOL-Auth.Public" "../UNITY_Main" begin

text\<open>This is the flawed version, vulnerable to Lowe's attack.
From page 260 of
  Burrows, Abadi and Needham.  A Logic of Authentication.
  Proc. Royal Soc. 426 (1989).
\<close>

type_synonym state = "event list"

  (*The spy MAY say anything he CAN say.  We do not expect him to
    invent new nonces here, but he can also use NS1.  Common to
    all similar protocols.*)
definition
  Fake :: "(state*state) set"
  where "Fake = {(s,s').
              \<exists>B X. s' = Says Spy B X # s
                    & X \<in> synth (analz (spies s))}"

  (*The numeric suffixes on A identify the rule*)

  (*Alice initiates a protocol run, sending a nonce to Bob*)
definition
  NS1 :: "(state*state) set"
  where "NS1 = {(s1,s').
             \<exists>A1 B NA.
                 s' = Says A1 B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A1\<rbrace>) # s1
               & Nonce NA \<notin> used s1}"

  (*Bob responds to Alice's message with a further nonce*)
definition
  NS2 :: "(state*state) set"
  where "NS2 = {(s2,s').
             \<exists>A' A2 B NA NB.
                 s' = Says B A2 (Crypt (pubK A2) \<lbrace>Nonce NA, Nonce NB\<rbrace>) # s2
               & Says A' B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A2\<rbrace>) \<in> set s2
               & Nonce NB \<notin> used s2}"

  (*Alice proves her existence by sending NB back to Bob.*)
definition
  NS3 :: "(state*state) set"
  where "NS3 = {(s3,s').
             \<exists>A3 B' B NA NB.
                 s' = Says A3 B (Crypt (pubK B) (Nonce NB)) # s3
               & Says A3  B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A3\<rbrace>) \<in> set s3
               & Says B' A3 (Crypt (pubK A3) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s3}"

definition Nprg :: "state program" where
    (*Initial trace is empty*)
    "Nprg = mk_total_program({[]}, {Fake, NS1, NS2, NS3}, UNIV)"

declare spies_partsEs [elim]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text\<open>For other theories, e.g. Mutex and Lift, using [iff] slows proofs down.
  Here, it facilitates re-use of the Auth proofs.\<close>

declare Fake_def [THEN def_act_simp, iff]
declare NS1_def [THEN def_act_simp, iff]
declare NS2_def [THEN def_act_simp, iff]
declare NS3_def [THEN def_act_simp, iff]

declare Nprg_def [THEN def_prg_Init, simp]

text\<open>A "possibility property": there are traces that reach the end.
  Replace by LEADSTO proof!\<close>
lemma "A \<noteq> B ==>
       \<exists>NB. \<exists>s \<in> reachable Nprg. Says A B (Crypt (pubK B) (Nonce NB)) \<in> set s"
apply (intro exI bexI)
apply (rule_tac [2] act = "totalize_act NS3" in reachable.Acts)
apply (rule_tac [3] act = "totalize_act NS2" in reachable.Acts)
apply (rule_tac [4] act = "totalize_act NS1" in reachable.Acts)
apply (rule_tac [5] reachable.Init)
apply (simp_all (no_asm_simp) add: Nprg_def totalize_act_def)
apply auto
done

subsection\<open>Inductive Proofs about \<^term>\<open>ns_public\<close>\<close>

lemma ns_constrainsI:
     "(!!act s s'. [| act \<in> {Id, Fake, NS1, NS2, NS3};
                      (s,s') \<in> act;  s \<in> A |] ==> s' \<in> A')
      ==> Nprg \<in> A co A'"
apply (simp add: Nprg_def mk_total_program_def)
apply (rule constrainsI, auto)
done

text\<open>This ML code does the inductions directly.\<close>
ML\<open>
fun ns_constrains_tac ctxt i =
  SELECT_GOAL
    (EVERY
     [REPEAT (eresolve_tac ctxt @{thms Always_ConstrainsI} 1),
      REPEAT (resolve_tac ctxt [@{thm StableI}, @{thm stableI}, @{thm constrains_imp_Constrains}] 1),
      resolve_tac ctxt @{thms ns_constrainsI} 1,
      full_simp_tac ctxt 1,
      REPEAT (FIRSTGOAL (eresolve_tac ctxt [disjE])),
      ALLGOALS (clarify_tac (ctxt delrules [impI, @{thm impCE}])),
      REPEAT (FIRSTGOAL (analz_mono_contra_tac ctxt)),
      ALLGOALS (asm_simp_tac ctxt)]) i;

(*Tactic for proving secrecy theorems*)
fun ns_induct_tac ctxt =
  (SELECT_GOAL o EVERY)
     [resolve_tac ctxt @{thms AlwaysI} 1,
      force_tac ctxt 1,
      (*"reachable" gets in here*)
      resolve_tac ctxt [@{thm Always_reachable} RS @{thm Always_ConstrainsI} RS @{thm StableI}] 1,
      ns_constrains_tac ctxt 1];
\<close>

method_setup ns_induct = \<open>
    Scan.succeed (SIMPLE_METHOD' o ns_induct_tac)\<close>
    "for inductive reasoning about the Needham-Schroeder protocol"

text\<open>Converts invariants into statements about reachable states\<close>
lemmas Always_Collect_reachableD =
     Always_includes_reachable [THEN subsetD, THEN CollectD]

text\<open>Spy never sees another agent's private key! (unless it's bad at start)\<close>
lemma Spy_see_priK:
     "Nprg \<in> Always {s. (Key (priK A) \<in> parts (spies s)) = (A \<in> bad)}"
apply ns_induct
apply blast
done
declare Spy_see_priK [THEN Always_Collect_reachableD, simp]

lemma Spy_analz_priK:
     "Nprg \<in> Always {s. (Key (priK A) \<in> analz (spies s)) = (A \<in> bad)}"
by (rule Always_reachable [THEN Always_weaken], auto)
declare Spy_analz_priK [THEN Always_Collect_reachableD, simp]

subsection\<open>Authenticity properties obtained from NS2\<close>

text\<open>It is impossible to re-use a nonce in both NS1 and NS2 provided the
     nonce is secret.  (Honest users generate fresh nonces.)\<close>
lemma no_nonce_NS1_NS2:
 "Nprg
  \<in> Always {s. Crypt (pubK C) \<lbrace>NA', Nonce NA\<rbrace> \<in> parts (spies s) -->
                Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (spies s) -->
                Nonce NA \<in> analz (spies s)}"
apply ns_induct
apply (blast intro: analz_insertI)+
done

text\<open>Adding it to the claset slows down proofs...\<close>
lemmas no_nonce_NS1_NS2_reachable =
       no_nonce_NS1_NS2 [THEN Always_Collect_reachableD, rule_format]

text\<open>Unicity for NS1: nonce NA identifies agents A and B\<close>
lemma unique_NA_lemma:
     "Nprg
  \<in> Always {s. Nonce NA \<notin> analz (spies s) -->
                Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts(spies s) -->
                Crypt(pubK B') \<lbrace>Nonce NA, Agent A'\<rbrace> \<in> parts(spies s) -->
                A=A' & B=B'}"
apply ns_induct
apply auto
txt\<open>Fake, NS1 are non-trivial\<close>
done

text\<open>Unicity for NS1: nonce NA identifies agents A and B\<close>
lemma unique_NA:
     "[| Crypt(pubK B)  \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts(spies s);
         Crypt(pubK B') \<lbrace>Nonce NA, Agent A'\<rbrace> \<in> parts(spies s);
         Nonce NA \<notin> analz (spies s);
         s \<in> reachable Nprg |]
      ==> A=A' & B=B'"
by (blast dest: unique_NA_lemma [THEN Always_Collect_reachableD])

text\<open>Secrecy: Spy does not see the nonce sent in msg NS1 if A and B are secure\<close>
lemma Spy_not_see_NA:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says A B (Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s
                  --> Nonce NA \<notin> analz (spies s)}"
apply ns_induct
txt\<open>NS3\<close>
prefer 4 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt\<open>NS2\<close>
prefer 3 apply (blast dest: unique_NA)
txt\<open>NS1\<close>
prefer 2 apply blast
txt\<open>Fake\<close>
apply spy_analz
done

text\<open>Authentication for A: if she receives message 2 and has used NA
  to start a run, then B has sent message 2.\<close>
lemma A_trusts_NS2:
 "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says A B (Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s &
                  Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts (knows Spy s)
         --> Says B A (Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s}"
  (*insert an invariant for use in some of the subgoals*)
apply (insert Spy_not_see_NA [of A B NA], simp, ns_induct)
apply (auto dest: unique_NA)
done

text\<open>If the encrypted message appears then it originated with Alice in NS1\<close>
lemma B_trusts_NS1:
     "Nprg \<in> Always
              {s. Nonce NA \<notin> analz (spies s) -->
                  Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (spies s)
         --> Says A B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s}"
apply ns_induct
apply blast
done

subsection\<open>Authenticity properties obtained from NS2\<close>

text\<open>Unicity for NS2: nonce NB identifies nonce NA and agent A.
   Proof closely follows that of \<open>unique_NA\<close>.\<close>
lemma unique_NB_lemma:
 "Nprg
  \<in> Always {s. Nonce NB \<notin> analz (spies s)  -->
                Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts (spies s) -->
                Crypt(pubK A') \<lbrace>Nonce NA', Nonce NB\<rbrace> \<in> parts(spies s) -->
                A=A' & NA=NA'}"
apply ns_induct
apply auto
txt\<open>Fake, NS2 are non-trivial\<close>
done

lemma unique_NB:
     "[| Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts(spies s);
         Crypt(pubK A') \<lbrace>Nonce NA', Nonce NB\<rbrace> \<in> parts(spies s);
         Nonce NB \<notin> analz (spies s);
         s \<in> reachable Nprg |]
      ==> A=A' & NA=NA'"
apply (blast dest: unique_NB_lemma [THEN Always_Collect_reachableD])
done

text\<open>NB remains secret PROVIDED Alice never responds with round 3\<close>
lemma Spy_not_see_NB:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s &
                  (\<forall>C. Says A C (Crypt (pubK C) (Nonce NB)) \<notin> set s)
                  --> Nonce NB \<notin> analz (spies s)}"
apply ns_induct
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>NS3: because NB determines A\<close>
prefer 4 apply (blast dest: unique_NB)
txt\<open>NS2: by freshness and unicity of NB\<close>
prefer 3 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt\<open>NS1: by freshness\<close>
prefer 2 apply blast
txt\<open>Fake\<close>
apply spy_analz
done

text\<open>Authentication for B: if he receives message 3 and has used NB
  in message 2, then A has sent message 3--to somebody....\<close>
lemma B_trusts_NS3:
     "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Crypt (pubK B) (Nonce NB) \<in> parts (spies s) &
                  Says B A  (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s
                  --> (\<exists>C. Says A C (Crypt (pubK C) (Nonce NB)) \<in> set s)}"
  (*insert an invariant for use in some of the subgoals*)
apply (insert Spy_not_see_NB [of A B NA NB], simp, ns_induct)
apply (simp_all (no_asm_simp) add: ex_disj_distrib)
apply auto
txt\<open>NS3: because NB determines A. This use of \<open>unique_NB\<close> is robust.\<close>
apply (blast intro: unique_NB [THEN conjunct1])
done

text\<open>Can we strengthen the secrecy theorem?  NO\<close>
lemma "[| A \<notin> bad;  B \<notin> bad |]
  ==> Nprg \<in> Always
              {s. Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s
                  --> Nonce NB \<notin> analz (spies s)}"
apply ns_induct
apply auto
txt\<open>Fake\<close>
apply spy_analz
txt\<open>NS2: by freshness and unicity of NB\<close>
 apply (blast intro: no_nonce_NS1_NS2_reachable)
txt\<open>NS3: unicity of NB identifies A and NA, but not B\<close>
apply (frule_tac A'=A in Says_imp_spies [THEN parts.Inj, THEN unique_NB])
apply (erule Says_imp_spies [THEN parts.Inj], auto)
apply (rename_tac s B' C)
txt\<open>This is the attack!
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

(*
THIS IS THE ATTACK!
[| A \<notin> bad; B \<notin> bad |]
==> Nprg
   \<in> Always
       {s. Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s -->
           Nonce NB \<notin> analz (knows Spy s)}
 1. !!s B' C.
       [| A \<notin> bad; B \<notin> bad; s \<in> reachable Nprg
          Says A C (Crypt (pubK C) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set s;
          Says B' A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s;
          C \<in> bad; Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set s;
          Nonce NB \<notin> analz (knows Spy s) |]
       ==> False
*)

end


section\<open>Lambda-replacements required for cardinal inequalities\<close>

theory Replacement_Lepoll
  imports
    ZF_Library_Relative
begin

definition
  lepoll_assumptions1 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions1(M,A,F,S,fa,K,x,f,r) \<equiv> \<forall>x\<in>S. strong_replacement(M, \<lambda>y z. y \<in> F(A, x) \<and> z = {\<langle>x, y\<rangle>})"

definition
  lepoll_assumptions2 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions2(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x z. z = Sigfun(x, F(A)))"

definition
  lepoll_assumptions3 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions3(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x y. y = F(A, x))"

definition
  lepoll_assumptions4 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions4(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x y. y = \<langle>x, minimum(r, F(A, x))\<rangle>)"

definition
  lepoll_assumptions5 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions5(M,A,F,S,fa,K,x,f,r) \<equiv>
strong_replacement(M, \<lambda>x y. y = \<langle>x, \<mu> i. x \<in> F(A, i), f ` (\<mu> i. x \<in> F(A, i)) ` x\<rangle>)"

definition
  lepoll_assumptions6 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions6(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>y z. y \<in> inj\<^bsup>M\<^esup>(F(A, x),S) \<and> z = {\<langle>x, y\<rangle>})"

definition
  lepoll_assumptions7 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions7(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x y. y = inj\<^bsup>M\<^esup>(F(A, x),S))"

definition
  lepoll_assumptions8 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions8(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x z. z = Sigfun(x, \<lambda>i. inj\<^bsup>M\<^esup>(F(A, i),S)))"

definition
  lepoll_assumptions9 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions9(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x y. y = \<langle>x, minimum(r, inj\<^bsup>M\<^esup>(F(A, x),S))\<rangle>)"

definition
  lepoll_assumptions10 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions10(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement
           (M, \<lambda>x z. z = Sigfun(x, \<lambda>k. if k \<in> range(f) then F(A, converse(f) ` k) else 0))"

definition
  lepoll_assumptions11 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions11(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x y. y = (if x \<in> range(f) then F(A, converse(f) ` x) else 0))"

definition
  lepoll_assumptions12 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions12(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>y z. y \<in> F(A, converse(f) ` x) \<and> z = {\<langle>x, y\<rangle>})"

definition
  lepoll_assumptions13 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions13(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement
         (M, \<lambda>x y. y = \<langle>x, minimum(r, if x \<in> range(f) then F(A,converse(f) ` x) else 0)\<rangle>)"

definition
  lepoll_assumptions14 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions14(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement
         (M, \<lambda>x y. y = \<langle>x, \<mu> i. x \<in> (if i \<in> range(f) then F(A, converse(f) ` i) else 0),
                        fa ` (\<mu> i. x \<in> (if i \<in> range(f) then F(A, converse(f) ` i) else 0)) ` x\<rangle>)"

definition
  lepoll_assumptions15 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions15(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement
         (M, \<lambda>y z. y \<in> inj\<^bsup>M\<^esup>(if x \<in> range(f) then F(A, converse(f) ` x) else 0,K) \<and> z = {\<langle>x, y\<rangle>})"

definition
  lepoll_assumptions16 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions16(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement(M, \<lambda>x y. y = inj\<^bsup>M\<^esup>(if x \<in> range(f) then F(A, converse(f) ` x) else 0,K))"

definition
  lepoll_assumptions17 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions17(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement
             (M, \<lambda>x z. z = Sigfun(x, \<lambda>i. inj\<^bsup>M\<^esup>(if i \<in> range(f) then F(A, converse(f) ` i) else 0,K)))"

definition
  lepoll_assumptions18 :: "[i\<Rightarrow>o,i,[i,i]\<Rightarrow>i,i,i,i,i,i,i] \<Rightarrow> o" where
  "lepoll_assumptions18(M,A,F,S,fa,K,x,f,r) \<equiv> strong_replacement
         (M, \<lambda>x y. y = \<langle>x, minimum(r, inj\<^bsup>M\<^esup>(if x \<in> range(f) then F(A, converse(f) ` x) else 0,K))\<rangle>)"

lemmas lepoll_assumptions_defs[simp] = lepoll_assumptions1_def
  lepoll_assumptions2_def lepoll_assumptions3_def lepoll_assumptions4_def
  lepoll_assumptions5_def lepoll_assumptions6_def lepoll_assumptions7_def
  lepoll_assumptions8_def lepoll_assumptions9_def lepoll_assumptions10_def
  lepoll_assumptions11_def lepoll_assumptions12_def lepoll_assumptions13_def
  lepoll_assumptions14_def lepoll_assumptions15_def lepoll_assumptions16_def
  lepoll_assumptions17_def lepoll_assumptions18_def

definition if_range_F where
  [simp]: "if_range_F(H,f,i) \<equiv> if i \<in> range(f) then H(converse(f) ` i) else 0"

definition if_range_F_else_F where
  "if_range_F_else_F(H,b,f,i) \<equiv> if b=0 then if_range_F(H,f,i) else H(i)"

lemma (in M_basic) lam_Least_assumption_general:
  assumes
    separations:
    "\<forall>A'[M]. separation(M, \<lambda>y. \<exists>x\<in>A'. y = \<langle>x, \<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i)\<rangle>)"
    and
    mem_F_bound:"\<And>x c. x\<in>F(A,c) \<Longrightarrow> c \<in> range(f) \<union> U(A)"
    and
    types:"M(A)" "M(b)" "M(f)" "M(U(A))"
  shows "lam_replacement(M,\<lambda>x . \<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i))"
proof -
  have "\<forall>x\<in>X. (\<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i)) \<in>
    Pow\<^bsup>M\<^esup>(\<Union>(X \<union> range(f) \<union> U(A)))" if "M(X)" for X
  proof
    fix x
    assume "x\<in>X"
    moreover
    note \<open>M(X)\<close>
    moreover from calculation
    have "M(x)" by (auto dest:transM)
    moreover
    note assms
    ultimately
    show "(\<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i)) \<in>
        Pow\<^bsup>M\<^esup>(\<Union>(X \<union> range(f) \<union> U(A)))"
    proof (rule_tac Least_in_Pow_rel_Union, cases "b=0", simp_all)
      case True
      fix c
      assume asm:"x \<in> if_range_F_else_F(F(A), 0, f, c)"
      with mem_F_bound
      show "c\<in>X \<or> c \<in> range(f) \<or> c \<in> U(A)"
        unfolding if_range_F_else_F_def if_range_F_def by (cases "c\<in>range(f)") auto
    next
      case False
      fix c
      assume "x \<in> if_range_F_else_F(F(A), b, f, c)"
      with False mem_F_bound[of x c]
      show "c\<in>X \<or> c \<in> range(f) \<or> c\<in>U(A)"
        unfolding if_range_F_else_F_def if_range_F_def by auto
    qed
  qed
  with assms
  show ?thesis
    using bounded_lam_replacement[of "\<lambda>x.(\<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i))"
        "\<lambda>X. Pow\<^bsup>M\<^esup>(\<Union>(X \<union> range(f) \<union> U(A)))"] by simp
qed

lemma (in M_basic) lam_Least_assumption_ifM_b0:
  fixes F
  defines "F \<equiv> \<lambda>_ x. if M(x) then x else 0"
  assumes
    separations:
    "\<forall>A'[M]. separation(M, \<lambda>y. \<exists>x\<in>A'. y = \<langle>x, \<mu> i. x \<in> if_range_F_else_F(F(A),0,f,i)\<rangle>)"
    and
    types:"M(A)" "M(f)"
  shows "lam_replacement(M,\<lambda>x . \<mu> i. x \<in> if_range_F_else_F(F(A),0,f,i))"
    (is "lam_replacement(M,\<lambda>x . Least(?P(x)))")
proof -
  {
    fix x X
    assume "M(X)" "x\<in>X" "(\<mu> i. ?P(x,i)) \<noteq> 0"
    moreover from this
    obtain m where "Ord(m)" "?P(x,m)"
      using Least_0[of "?P(_)"] by auto
    moreover
    note assms
    moreover
    have "?P(x,i) \<longleftrightarrow> (M(converse(f) ` i) \<and> i \<in> range(f) \<and> x \<in> converse(f) ` i)"  for i
      unfolding F_def if_range_F_else_F_def if_range_F_def by auto
    ultimately
    have "(\<mu> i. ?P(x,i)) \<in> range (f)"
      unfolding F_def if_range_F_else_F_def if_range_F_def
      by (rule_tac LeastI2) auto
  }
  with assms
  show ?thesis
    by (rule_tac bounded_lam_replacement[of _ "\<lambda>X. range(f) \<union> {0}"]) auto
qed

lemma (in M_replacement) lam_Least_assumption_ifM_bnot0:
  fixes F
  defines "F \<equiv> \<lambda>_ x. if M(x) then x else 0"
  assumes
    lam_replacement_minimum:"lam_replacement(M, \<lambda>p. minimum(fst(p),snd(p)))"
    and
    separations:
    "\<forall>A'[M]. separation(M, \<lambda>y. \<exists>x\<in>A'. y = \<langle>x, \<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i)\<rangle>)"
    "separation(M,Ord)"
    and
    types:"M(A)" "M(f)"
    and
    "b\<noteq>0"
  shows "lam_replacement(M,\<lambda>x . \<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i))"
    (is "lam_replacement(M,\<lambda>x . Least(?P(x)))")
proof -
  have "M(x) \<Longrightarrow>(\<mu> i. (M(i) \<longrightarrow> x \<in> i) \<and> M(i)) = (if Ord(x) then succ(x) else 0)" for x
    using Ord_in_Ord
    apply (auto intro:Least_0, rule_tac Least_equality, simp_all)
    by (frule lt_Ord) (auto dest:le_imp_not_lt[of _ x] intro:ltI[of x])
  moreover
  have "lam_replacement(M, \<lambda>x. if Ord(x) then succ(x) else 0)"
    using lam_replacement_if[OF _ _ separations(2)] lam_replacement_identity
      lam_replacement_constant lam_replacement_hcomp lam_replacement_succ
    by simp
  moreover
  note types \<open>b\<noteq>0\<close>
  ultimately
  show ?thesis
    using lam_replacement_cong
    unfolding F_def if_range_F_else_F_def if_range_F_def
    by auto
qed

lemma (in M_replacement) lam_Least_assumption_drSR_Y:
  fixes F r' D
  defines "F \<equiv> drSR_Y(r',D)"
  assumes "\<forall>A'[M]. separation(M, \<lambda>y. \<exists>x\<in>A'. y = \<langle>x, \<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i)\<rangle>)"
    "M(A)" "M(b)" "M(f)" "M(r')"
    and
    lam_replacement_minimum:"lam_replacement(M, \<lambda>p. minimum(fst(p),snd(p)))"
  shows "lam_replacement(M,\<lambda>x . \<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i))"
proof -
  from assms(2-)
  have [simp]: "M(X) \<Longrightarrow> M(X \<union> range(f) \<union> {domain(x) . x \<in> A})"
    "M(r') \<Longrightarrow> M(X) \<Longrightarrow> M({restrict(x,r') . x \<in> A})"
    for X r'
    using lam_replacement_domain[THEN lam_replacement_imp_strong_replacement,
        THEN RepFun_closed, of A]
      lam_replacement_restrict'[THEN lam_replacement_imp_strong_replacement,
        THEN RepFun_closed, of r' A] by (auto dest:transM)
  have "\<forall>x\<in>X. (\<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i)) \<in>
    Pow\<^bsup>M\<^esup>(\<Union>(X \<union> range(f) \<union> {domain(x). x\<in>A} \<union> {restrict(x,r'). x\<in>A} \<union> domain(A) \<union> range(A) \<union> \<Union>A))" if "M(X)" for X
  proof
    fix x
    assume "x\<in>X"
    moreover
    note \<open>M(X)\<close>
    moreover from calculation
    have "M(x)" by (auto dest:transM)
    moreover
    note assms(2-)
    ultimately
    show "(\<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i)) \<in>
        Pow\<^bsup>M\<^esup>(\<Union>(X \<union> range(f) \<union> {domain(x). x\<in>A} \<union> {restrict(x,r'). x\<in>A} \<union> domain(A) \<union> range(A) \<union> \<Union>A))"
      unfolding if_range_F_else_F_def if_range_F_def
    proof (rule_tac Least_in_Pow_rel_Union, simp_all,cases "b=0", simp_all)
      case True
      fix c
      assume asm:"x \<in> (if c \<in> range(f) then F(A, converse(f) ` c) else 0)"
      then
      show "c\<in>X \<or> c\<in>range(f) \<or> (\<exists>x\<in>A. c = domain(x)) \<or> (\<exists>x\<in>A. c = restrict(x,r')) \<or> c \<in> domain(A) \<or> c \<in> range(A) \<or> (\<exists>x\<in>A. c\<in>x)" by auto
    next
      case False
      fix c
      assume "x \<in> F(A, c)"
      then
      show "c\<in>X \<or> c\<in>range(f) \<or> (\<exists>x\<in>A. c = domain(x)) \<or> (\<exists>x\<in>A. c = restrict(x,r')) \<or> c \<in> domain(A) \<or> c \<in> range(A) \<or> (\<exists>x\<in>A. c\<in>x)"
        using apply_0
        by (cases "M(c)", auto simp:F_def drSR_Y_def dC_F_def)
    qed
  qed
  with assms(2-)
  show ?thesis
    using bounded_lam_replacement[of "\<lambda>x.(\<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i))"
        "\<lambda>X. Pow\<^bsup>M\<^esup>(\<Union>(X \<union> range(f) \<union> {domain(x). x\<in>A} \<union> {restrict(x,r'). x\<in>A} \<union> domain(A) \<union> range(A) \<union> \<Union>A))"] by simp
qed

locale M_replacement_lepoll = M_replacement + M_inj +
  fixes F
  assumes
    F_type[simp]: "M(A) \<Longrightarrow> \<forall>x[M]. M(F(A,x))"
    and
    lam_lepoll_assumption_F:"M(A) \<Longrightarrow> lam_replacement(M,F(A))"
    and
    \<comment> \<open>Here b is a Boolean.\<close>
    lam_Least_assumption:"M(A) \<Longrightarrow> M(b) \<Longrightarrow> M(f) \<Longrightarrow>
        lam_replacement(M,\<lambda>x . \<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i))"
    and
    F_args_closed: "M(A) \<Longrightarrow> M(x) \<Longrightarrow> x \<in> F(A,i) \<Longrightarrow> M(i)"
    and
    lam_replacement_inj_rel:"lam_replacement(M, \<lambda>p. inj\<^bsup>M\<^esup>(fst(p),snd(p)))"
    and
    lam_replacement_minimum:"lam_replacement(M, \<lambda>p. minimum(fst(p),snd(p)))"
begin

declare if_range_F_else_F_def[simp]

lemma lepoll_assumptions1:
  assumes types[simp]:"M(A)" "M(S)"
  shows "lepoll_assumptions1(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
    transM[of _ S]
  by simp

lemma lepoll_assumptions2:
  assumes types[simp]:"M(A)" "M(S)"
  shows "lepoll_assumptions2(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    assms lam_lepoll_assumption_F
  by simp

lemma lepoll_assumptions3:
  assumes types[simp]:"M(A)"
  shows "lepoll_assumptions3(M,A,F,S,fa,K,x,f,r)"
  using lam_lepoll_assumption_F[THEN lam_replacement_imp_strong_replacement]
  by simp

lemma lepoll_assumptions4:
  assumes types[simp]:"M(A)" "M(r)"
  shows "lepoll_assumptions4(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_minimum lam_replacement_constant lam_lepoll_assumption_F
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by (rule_tac lam_replacement_hcomp2[of _ _ minimum])
    (force intro: lam_replacement_identity)+

lemma lam_Least_closed :
  assumes "M(A)" "M(b)" "M(f)"
  shows "\<forall>x[M]. M(\<mu> i. x \<in> if_range_F_else_F(F(A),b,f,i))"
proof -
  have "x \<in> (if i \<in> range(f) then F(A, converse(f) ` i) else 0) \<Longrightarrow> M(i)" for x i
  proof (cases "i\<in>range(f)")
    case True
    with \<open>M(f)\<close>
    show ?thesis by (auto dest:transM)
  next
    case False
    moreover
    assume "x \<in> (if i \<in> range(f) then F(A, converse(f) ` i) else 0)"
    ultimately
    show ?thesis
      by auto
  qed
  with assms
  show ?thesis
    using F_args_closed[of A] unfolding if_range_F_else_F_def if_range_F_def
    by (clarify, rule_tac Least_closed', cases "b=0") simp_all
qed

lemma lepoll_assumptions5:
  assumes
    types[simp]:"M(A)" "M(f)"
  shows "lepoll_assumptions5(M,A,F,S,fa,K,x,f,r)"
  using
    lam_replacement_apply2[THEN [5] lam_replacement_hcomp2]
    lam_replacement_hcomp[OF _ lam_replacement_apply[of f]]
    lam_replacement_identity
    lam_replacement_product lam_Least_closed[where b=1]
    assms lam_Least_assumption[where b=1,OF \<open>M(A)\<close> _ \<open>M(f)\<close>]
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by simp

lemma lepoll_assumptions6:
  assumes types[simp]:"M(A)" "M(S)" "M(x)"
  shows "lepoll_assumptions6(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
    lam_replacement_inj_rel
  by simp

lemma lepoll_assumptions7:
  assumes types[simp]:"M(A)" "M(S)" "M(x)"
  shows "lepoll_assumptions7(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_constant lam_lepoll_assumption_F lam_replacement_inj_rel
  unfolding lepoll_assumptions_defs
  by (rule_tac lam_replacement_imp_strong_replacement)
    (rule_tac lam_replacement_hcomp2[of _ _ "inj_rel(M)"], simp_all)

lemma lepoll_assumptions8:
  assumes types[simp]:"M(A)" "M(S)"
  shows "lepoll_assumptions8(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    lam_replacement_inj_rel lam_replacement_constant
    lam_replacement_hcomp2[of _ _ "inj_rel(M)",OF lam_lepoll_assumption_F[of A]]
  by simp

lemma lepoll_assumptions9:
  assumes types[simp]:"M(A)" "M(S)" "M(r)"
  shows "lepoll_assumptions9(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_minimum lam_replacement_constant lam_lepoll_assumption_F
    lam_replacement_hcomp2[of _ _ "inj_rel(M)"] lam_replacement_inj_rel lepoll_assumptions4
  unfolding lepoll_assumptions_defs lam_replacement_def[symmetric]
  by (rule_tac lam_replacement_hcomp2[of _ _ minimum])
    (force intro: lam_replacement_identity)+

lemma lepoll_assumptions10:
  assumes types[simp]:"M(A)" "M(f)"
  shows "lepoll_assumptions10(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    lam_replacement_constant[OF nonempty]
    lam_replacement_if[OF _ _ separation_in_constant]
    lam_replacement_hcomp
    lam_replacement_apply[OF converse_closed[OF \<open>M(f)\<close>]]
    lam_lepoll_assumption_F[of A]
  by simp

lemma lepoll_assumptions11:
  assumes types[simp]:"M(A)" "M(f)"
  shows "lepoll_assumptions11(M, A, F, S, fa, K, x, f, r)"
  using lam_replacement_imp_strong_replacement
    lam_replacement_if[OF _ _ separation_in_constant[of "range(f)"]]
    lam_replacement_constant
    lam_replacement_hcomp lam_replacement_apply
    lam_lepoll_assumption_F
  by simp

lemma lepoll_assumptions12:
  assumes types[simp]:"M(A)" "M(x)" "M(f)"
  shows "lepoll_assumptions12(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
  by simp

lemma lepoll_assumptions13:
  assumes types[simp]:"M(A)" "M(r)" "M(f)"
  shows "lepoll_assumptions13(M,A,F,S,fa,K,x,f,r)"
  using  lam_replacement_constant[OF nonempty] lam_lepoll_assumption_F
    lam_replacement_hcomp lam_replacement_apply
    lam_replacement_hcomp2[OF lam_replacement_constant[OF \<open>M(r)\<close>]
      lam_replacement_if[OF _ _ separation_in_constant[of "range(f)"]] _ _
      lam_replacement_minimum] assms
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by simp

lemma lepoll_assumptions14:
  assumes types[simp]:"M(A)" "M(f)" "M(fa)"
  shows "lepoll_assumptions14(M,A,F,S,fa,K,x,f,r)"
  using
    lam_replacement_apply2[THEN [5] lam_replacement_hcomp2]
    lam_replacement_hcomp[OF _ lam_replacement_apply[of fa]]
    lam_replacement_identity
    lam_replacement_product  lam_Least_closed[where b=0]
    assms lam_Least_assumption[where b=0,OF \<open>M(A)\<close> _ \<open>M(f)\<close>]
  unfolding lepoll_assumptions_defs
    lam_replacement_def[symmetric]
  by simp

lemma lepoll_assumptions15:
  assumes types[simp]:"M(A)" "M(x)" "M(f)" "M(K)"
  shows "lepoll_assumptions15(M,A,F,S,fa,K,x,f,r)"
  using strong_replacement_separation[OF lam_replacement_sing_const_id separation_in_constant]
  by simp

lemma lepoll_assumptions16:
  assumes types[simp]:"M(A)" "M(f)" "M(K)"
  shows "lepoll_assumptions16(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_imp_strong_replacement
    lam_replacement_inj_rel lam_replacement_constant
    lam_replacement_hcomp2[of _ _ "inj_rel(M)"]
    lam_replacement_constant[OF nonempty]
    lam_replacement_if[OF _ _ separation_in_constant]
    lam_replacement_hcomp
    lam_replacement_apply[OF converse_closed[OF \<open>M(f)\<close>]]
    lam_lepoll_assumption_F[of A]
  by simp

lemma lepoll_assumptions17:
  assumes types[simp]:"M(A)" "M(f)" "M(K)"
  shows "lepoll_assumptions17(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_Sigfun lam_replacement_imp_strong_replacement
    lam_replacement_inj_rel lam_replacement_constant
    lam_replacement_hcomp2[of _ _ "inj_rel(M)"]
    lam_replacement_constant[OF nonempty]
    lam_replacement_if[OF _ _ separation_in_constant]
    lam_replacement_hcomp
    lam_replacement_apply[OF converse_closed[OF \<open>M(f)\<close>]]
    lam_lepoll_assumption_F[of A]
  by simp

lemma lepoll_assumptions18:
  assumes types[simp]:"M(A)" "M(K)" "M(f)" "M(r)"
  shows "lepoll_assumptions18(M,A,F,S,fa,K,x,f,r)"
  using lam_replacement_constant lam_replacement_inj_rel lam_lepoll_assumption_F
    lam_replacement_minimum lam_replacement_identity lam_replacement_apply2 separation_in_constant
  unfolding lepoll_assumptions18_def lam_replacement_def[symmetric]
  by (rule_tac lam_replacement_hcomp2[of _ _ minimum], simp_all,
      rule_tac lam_replacement_hcomp2[of _ _ "inj_rel(M)"], simp_all)
    (rule_tac lam_replacement_if, rule_tac lam_replacement_hcomp[of _ "F(A)"],
      rule_tac lam_replacement_hcomp2[of _ _ "(`)"], simp_all)

lemmas lepoll_assumptions = lepoll_assumptions1 lepoll_assumptions2
  lepoll_assumptions3 lepoll_assumptions4 lepoll_assumptions5
  lepoll_assumptions6 lepoll_assumptions7 lepoll_assumptions8
  lepoll_assumptions9 lepoll_assumptions10 lepoll_assumptions11
  lepoll_assumptions12 lepoll_assumptions13 lepoll_assumptions14
  lepoll_assumptions15 lepoll_assumptions16
  lepoll_assumptions17 lepoll_assumptions18

end \<comment> \<open>\<^locale>\<open>M_replacement_lepoll\<close>\<close>

end


(*
   Copyright 2017 Sidney Amani
   Copyright 2017 Maksym Bortin

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
*)
theory EvmFacts
  imports "lem/Evm"
      "Hoare/Hoare"
begin

lemmas gas_simps = Gverylow_def Glow_def Gmid_def Gbase_def Gzero_def Glogtopic_def
    Gsha3word_def Gsha3_def Gextcode_def Gcopy_def Gblockhash_def Gexpbyte_def Gexp_def
    Gbalance_def Gsload_def Gsreset_def Gsset_def Gjumpdest_def Ghigh_def
    Glogdata_def  Glog_def Gcreate_def Ccall_def
    Cgascap_def Cextra_def Gnewaccount_def Cxfer_def Cnew_def
    Gcall_def Gcallvalue_def Csstore_def Csuicide_def

lemma log256floor_ge_0:
  "0 \<le> log256floor s"
  apply (induct s rule: log256floor.induct)
  subgoal for x
    by (case_tac "\<not> x \<le> 255")
       (clarsimp simp: log256floor.simps)+
  done
declare  log256floor.simps[simp del ]

lemma Cextra_gt_0:
  "0 < Cextra  a b c"
  by (simp add:  gas_simps)

lemma Cgascap_gt_0:
  " 0 \<le> Cgascap a b c d e f"
  apply (simp add: Cgascap_def L_def )
  apply clarsimp
  apply (rule zdiv_le_dividend)
  apply linarith
  apply simp
done
(*  by (case_tac " b = 0" ; auto simp:L_def gas_simps)+*)

lemma Ccall_gt_0:
  "0 < Ccall s0 s1 s2 recipient_empty
            remaining_gas net mmu_extra"
  unfolding Ccall_def
  using Cextra_gt_0 Cgascap_gt_0
  by (clarsimp simp add: ordered_comm_monoid_add_class.add_nonneg_pos)+

lemma Csuicide_gt_0:
  "Gsuicide net \<noteq> 0 \<Longrightarrow> 0 < Csuicide recipient_empty net"
  unfolding Csuicide_def
  by (auto split: if_splits
           simp add: gas_simps Gsuicide_def)

lemma thirdComponentOfC_gt_0:
  "i \<noteq> Misc STOP \<Longrightarrow> i \<noteq> Misc RETURN \<Longrightarrow> (\<forall>v. i \<noteq> Unknown v) \<Longrightarrow>
   i = Misc SUICIDE \<longrightarrow> Gsuicide net \<noteq> 0 \<Longrightarrow>
   i \<notin>  (if before_homestead net then {Misc DELEGATECALL} else {}) \<Longrightarrow>
  0 < thirdComponentOfC  i s0 s1 s2 s3 recipient_empty orig_val new_val remaining_gas net mmu_extra"
  unfolding thirdComponentOfC_def
  apply (case_tac i ; simp add: gas_simps del: Cextra_def )
           apply (case_tac x2; simp add: gas_simps)
          apply (case_tac x3; simp add: gas_simps )
         apply (case_tac x4 ; simp add: gas_simps)
         using log256floor_ge_0[where s="uint s1"]
                 apply (simp add: )
              apply (clarsimp; simp add: word_less_def word_neq_0_conv)
                apply (case_tac x5; simp add: gas_simps)
              apply (case_tac x7; simp add: gas_simps)
                apply (case_tac "s2 = 0" ; auto simp: word_less_def word_neq_0_conv)
                apply (case_tac "s2 = 0" ; auto simp: word_less_def word_neq_0_conv)
              apply (case_tac "s3 = 0" ; auto simp: word_less_def word_neq_0_conv)
            apply (case_tac x8; simp add: gas_simps Csstore_def)
            apply (case_tac x9; simp add: gas_simps Csstore_def)
           apply (case_tac x10; simp add: gas_simps Csstore_def)
          apply ( case_tac x12; case_tac "s1 = 0";
             simp add: gas_simps word_less_def word_neq_0_conv)
         apply (clarsimp split: misc_inst.splits)
         apply (rule conjI, clarsimp simp add: gas_simps L_def)
         apply (clarsimp simp: Csuicide_gt_0 Ccall_gt_0  split:if_splits)
         done

lemma Cmem_lift:
  "max 0 x \<le> y \<Longrightarrow> Cmem (max 0 x) \<le> Cmem y"
  apply (simp add: Cmem_def Gmemory_def)
  apply (case_tac "x = y")
   apply (clarsimp simp: max_def)
  apply clarsimp
  apply (drule (1) order_class.le_neq_trans)
  apply simp
  apply (rule add_mono, simp)
  apply (rule zdiv_mono1[rotated], simp)
  apply (rule mult_mono ; simp)
  done

lemma vctx_memory_usage_never_decreases:
  "max 0 (vctx_memory_usage v) \<le> (new_memory_consumption i(max 0 (vctx_memory_usage   v)) (vctx_stack_default(( 0 :: int)) v) (vctx_stack_default(( 1 :: int)) v) (vctx_stack_default(( 2 :: int)) v) (vctx_stack_default(( 3 :: int)) v)
      (vctx_stack_default(( 4 :: int)) v) (vctx_stack_default(( 5 :: int)) v) (vctx_stack_default(( 6 :: int)) v))"
apply(case_tac i)
apply(rename_tac x, case_tac x; simp add: new_memory_consumption.simps vctx_stack_default_def M_def max_def)+
done

lemma meter_gas_gt_0:
  " inst \<noteq> Misc STOP \<Longrightarrow>
    inst \<noteq> Misc RETURN \<Longrightarrow>
    inst \<noteq> Misc SUICIDE \<Longrightarrow>
    inst \<notin> range Unknown \<Longrightarrow>
    inst \<notin>  (if before_homestead net then {Misc DELEGATECALL} else {}) \<Longrightarrow>
program_content (cctx_program const) (vctx_pc var) = Some inst \<Longrightarrow>
   0 < meter_gas inst var const net"

  using Cmem_lift[OF
    vctx_memory_usage_never_decreases[where i=inst and v=var]]
  apply (clarsimp simp add: C_def meter_gas_def Cmem_def Gmemory_def Let_def)
  apply(case_tac inst)
apply( simp add: new_memory_consumption.simps vctx_next_instruction_default_def vctx_next_instruction_def;
   fastforce  intro: ordered_comm_monoid_add_class.add_nonneg_pos
          thirdComponentOfC_gt_0) +
done

lemma subtract_gas_lower_gas:
   "subtract_gas m k (InstructionContinue var) = InstructionContinue v
    \<Longrightarrow> 0 < m \<Longrightarrow> vctx_gas v < vctx_gas var "
  by (auto simp add: subtract_gas.simps)

lemmas stack_op_simps = stack_0_0_op_def stack_0_1_op_def
   stack_2_1_op_def stack_1_1_op_def stack_3_1_op_def

lemmas op_simps = mstore8_def mload_def sha3_def
  general_dup_def mstore_def swap_def ret_def create_def
  call_def suicide_def calldatacopy_def codecopy_def
  extcodecopy_def sstore_def jump_def jumpi_def
  pc_def pop_def log_def callcode_def delegatecall_def

lemmas instruction_sem_simps =
  stack_op_simps instruction_failure_result_def
  subtract_gas.simps vctx_advance_pc_def
  op_simps vctx_update_storage_def
  blocked_jump_def blockedInstructionContinue_def
  strict_if_def vctx_pop_stack_def
  vctx_next_instruction_def

lemma instruction_sem_not_continuing:
  "\<lbrakk> inst \<in> {Misc STOP, Misc RETURN, Misc SUICIDE} \<union> range Unknown \<rbrakk> \<Longrightarrow>
\<forall>v. instruction_sem var const inst net \<noteq> InstructionContinue v"
  apply (case_tac inst; clarsimp simp: instruction_sem_def instruction_failure_result_def subtract_gas.simps)
  subgoal for opcode
   apply (case_tac opcode; simp add: ret_def suicide_def image_def stop_def instruction_sem_def instruction_failure_result_def subtract_gas.simps split:list.splits)
   done
  done

lemma instruction_sem_continuing:
  "\<lbrakk> instruction_sem var const inst net = InstructionContinue v \<rbrakk> \<Longrightarrow>
inst \<notin> {Misc STOP, Misc RETURN, Misc SUICIDE} \<union> range Unknown \<union> (if  before_homestead net then {Misc DELEGATECALL} else {})"
  apply (case_tac inst; clarsimp simp: instruction_sem_def instruction_failure_result_def subtract_gas.simps)
  subgoal for opcode
   apply (case_tac opcode; simp add: ret_def suicide_def image_def stop_def instruction_sem_def instruction_failure_result_def subtract_gas.simps split:list.splits if_split_asm)
   done
  done

lemma inst_sem_gas_consume:
  "instruction_sem var const inst net = InstructionContinue v \<Longrightarrow>
   inst \<notin> {Misc STOP, Misc RETURN, Misc SUICIDE} \<union> range Unknown \<union> (if before_homestead net then {Misc DELEGATECALL} else {}) \<Longrightarrow>
  \<not> vctx_gas var \<le> 0 \<Longrightarrow>
  program_content (cctx_program const) (vctx_pc var) = Some inst \<Longrightarrow>
  vctx_gas v < vctx_gas var"
  apply (cut_tac meter_gas_gt_0[where inst=inst and var=var and const=const and net=net]; simp)
  apply (simp only: instruction_sem_def)
  apply (case_tac inst; clarsimp)
             apply (case_tac x2 ; clarsimp simp: instruction_sem_simps split:list.splits)
         apply (case_tac x3 ; clarsimp simp: instruction_sem_simps split:list.splits)
         apply (case_tac x4 ; clarsimp simp: Let_def instruction_sem_simps split:list.splits if_splits)
         apply (case_tac x5 ; clarsimp simp: instruction_sem_simps split:list.splits)
         apply (case_tac x6 ; clarsimp simp: instruction_sem_simps split:list.splits option.splits)
         apply (case_tac x7 ; clarsimp simp: instruction_sem_simps split:list.splits option.splits)
         apply (case_tac x8 ; clarsimp simp: instruction_sem_simps split:list.splits option.splits)
      apply (case_tac x9 ; clarsimp simp: instruction_sem_simps Let_def split:list.splits option.splits pc_inst.splits )
      apply (case_tac x2; clarsimp simp: instruction_sem_simps Let_def split: pc_inst.splits)
       apply (case_tac "x21a = 0"; clarsimp simp: instruction_sem_simps Let_def split: pc_inst.splits option.splits)
       apply (case_tac "x2"; clarsimp simp: instruction_sem_simps Let_def split: pc_inst.splits option.splits)
     apply (case_tac "x10"; clarsimp simp: instruction_sem_simps  split: pc_inst.splits option.splits list.splits)
     apply (clarsimp simp: instruction_sem_simps  split: pc_inst.splits option.splits)
     apply (case_tac "x12"; clarsimp simp: instruction_sem_simps  split: pc_inst.splits option.splits)
  apply (case_tac "x13"; clarsimp simp: instruction_sem_simps  split: pc_inst.splits option.splits list.splits if_splits)
    done

termination program_sem_t
  apply (relation "measure (\<lambda>(c,net,ir). nat (case ir of InstructionContinue v \<Rightarrow>  vctx_gas v | _ \<Rightarrow> 0))")
   apply (simp)
  apply clarsimp
  subgoal for const net var inst
    apply (case_tac "instruction_sem var const inst net" ; simp)
    apply (clarsimp simp add: check_resources_def prod.case_eq_if )
     apply (frule instruction_sem_continuing)
     apply (erule (2) inst_sem_gas_consume)
  apply (simp add: vctx_next_instruction_def split:option.splits)
    done
done

lemma program_sem_t_no_gas_not_continuing:
  "\<lbrakk>vctx_gas var \<le> 0 \<rbrakk> \<Longrightarrow>
\<forall>v. program_sem_t const net (InstructionContinue var) \<noteq> InstructionContinue v"
  apply (clarsimp simp add: check_resources_def prod.case_eq_if  split:option.split)
  apply (drule instruction_sem_continuing)
  subgoal for i inst
  using meter_gas_gt_0[where inst=i and var=var and const=const and net=net]
  apply (simp add: vctx_next_instruction_def split:option.splits)
  done
 done

declare program_sem_t.simps[simp del]
declare next_state_def[simp del]

lemma program_sem_t_imp_program_sem:
  notes if_split[split del]
  shows
 "\<exists>k. program_sem_t const net ir = program_sem (\<lambda>_. ()) const k net ir"
  apply (induct rule:program_sem_t.induct)
  apply (case_tac p)
    apply clarify
    apply (rename_tac c net p inst)
    apply (drule_tac x=inst in meta_spec)
    apply (case_tac "vctx_next_instruction inst c", simp add: vctx_next_instruction_def split:option.splits)
    apply (rename_tac nxt_inst)
    apply (drule_tac x="nxt_inst" in meta_spec)
    apply (erule meta_impE , simp)
    apply (erule meta_impE , simp)
    apply (subst program_sem_t.simps)
    apply (simp)
    apply (split if_split)
    apply (rule conjI)
    apply clarify
    apply (drule meta_mp, simp)
    apply (split if_split)
    apply (rule conjI)
     apply clarsimp
     apply (rule exI[where x="Suc 0"])
     apply (simp add: program_sem.simps next_state_def )
    apply (rule impI)
    apply (clarsimp split:if_split)
    apply (rule_tac x="Suc k" in exI)
    apply (simp add: program_sem.simps next_state_def)
   apply (clarsimp )
   apply (rule exI[where x="Suc 0"])
   apply (clarsimp simp: program_sem.simps next_state_def)
  apply (rule exI[where x="Suc 0"])
  apply (clarsimp simp: program_sem_t.simps program_sem.simps next_state_def)
  done

lemma program_sem_ItoE :
"program_sem (\<lambda>_. ()) const k net (InstructionToEnvironment a b c) = InstructionToEnvironment a b c"
  apply(induct_tac k, simp add: program_sem.simps next_state_def split: if_split)
  apply(simp add: program_sem.simps next_state_def split: if_split)
  done

(* perhaps rename this to 'program_sem_no_gas_not_continuing' and
   the above to 'program_sem_t_no_gas_not_continuing' *)
lemma program_sem_no_gas_not_continuing' :
  "\<lbrakk>vctx_gas var \<le> 0  \<rbrakk> \<Longrightarrow>
\<forall>k>0. \<forall>v. program_sem (\<lambda>_. ()) c k net (InstructionContinue var) \<noteq> InstructionContinue v"
  apply clarify
  apply(case_tac k, simp)
  apply (simp add: program_sem.simps next_state_def split: if_split_asm)
  apply (case_tac "vctx_next_instruction var c", simp  split:option.splits)
   apply(simp add: program_sem_ItoE)
    apply(simp split: if_split_asm)
    apply (clarsimp simp add: check_resources_def prod.case_eq_if split:option.split)
    apply(clarsimp simp: vctx_next_instruction_def split:option.splits)
     apply(simp add: instruction_sem_def stop_def subtract_gas.simps)
     apply(simp add: program_sem_ItoE)
    apply(rename_tac inst)
    apply(case_tac "instruction_sem var c inst net")
      apply(drule instruction_sem_continuing, clarsimp)
    apply(drule_tac const=c in meter_gas_gt_0[where net=net], assumption+)
      apply fastforce
     apply clarsimp
    apply(simp add: program_sem_ItoE)
   apply(simp add: program_sem_ItoE)
  apply(simp add: program_sem_ItoE)
  done

theorem program_sem_t_in_program_sem:
  notes if_split[split del]
  shows
 "\<exists>k. program_sem_t const net ir  = program_sem (\<lambda>_. ()) const k net  ir \<and>
     (\<forall>l\<ge>k. \<forall>z. program_sem (\<lambda>_. ()) const l net ir \<noteq> InstructionContinue z) \<and>
     (\<forall>l<k. \<exists>z. program_sem (\<lambda>_. ()) const l net ir = InstructionContinue z)"
  apply(induct_tac const net ir rule: program_sem_t.induct)
  apply(case_tac p)
   apply clarify
   apply(rename_tac c net p inst)
   apply(drule_tac x=inst in meta_spec)
   apply(case_tac "vctx_next_instruction inst c", simp add: vctx_next_instruction_def split:option.splits)
   apply(rename_tac nxt_inst)
   apply(drule_tac x="nxt_inst" in meta_spec)
   apply(erule meta_impE, simp)
   apply(subst program_sem_t.simps)
   apply(simp only: instruction_result.simps)
   apply (drule meta_mp, simp)
   apply simp
   apply(split if_split)
   apply(rule conjI)
    apply clarify
    apply (drule meta_mp, simp)
    apply(split if_split)
    apply(rule conjI)
    apply clarify
    apply(rule exI[where x="Suc 0"])
    apply(simp add: program_sem.simps next_state_def split: if_split)
    apply(drule_tac c=c and net=net in program_sem_no_gas_not_continuing')
    apply fastforce
    apply(rule impI, simp)
    apply(erule exE)
    apply(rule_tac x="k + 1" in exI, clarify)
    apply(simp add: program_sem.simps next_state_def)
    apply(rule conjI)
     apply(rule allI, rule impI)
     apply(case_tac l, simp)
     apply(rename_tac l')
     apply(drule_tac x=l' in spec, drule mp, simp)
     apply(simp add: program_sem.simps next_state_def)
    apply(rule allI, rule impI)
    apply(case_tac l, simp add: program_sem.simps)
    apply(rename_tac l', clarify)
    apply(drule_tac x=l' in spec, drule mp, assumption)
    apply(clarsimp simp: program_sem.simps next_state_def)
   apply(rule impI)
   apply(rule exI[where x="Suc 0"])
   apply(simp add: program_sem.simps next_state_def)
   apply clarify
   apply(case_tac l, simp)
   apply clarify
   apply(simp add: program_sem.simps next_state_def)
  apply(simp add: program_sem_ItoE)
  apply(simp add: program_sem.simps next_state_def)
  apply(simp add: program_sem_ItoE program_sem_t.simps)
  apply fastforce
  done

corollary program_sem_t_fix :
"program_sem (\<lambda>_. ()) const n net (program_sem_t const net ir) =
 program_sem_t const net ir"
  apply(insert program_sem_t_in_program_sem[of const net ir])
  apply clarify
  apply(erule ssubst)
  apply(drule_tac x="k" in spec, drule mp, simp)
  apply(case_tac "program_sem (\<lambda>_. ()) const k net ir")
    apply fastforce
   apply(erule ssubst)
  apply(simp add: program_sem_ItoE)
  done

end


theory Automation_Setup
imports "System_Specification"
begin

lemma add_prop:
  assumes "PROP (T)"
  shows "A ==> PROP (T)"
  using assms .

lemmas exhaust_elim =
   cAct.exhaust[of x, THEN add_prop[where A="a=Cact x"], rotated -1]
   uAct.exhaust[of x, THEN add_prop[where A="a=Uact x"], rotated -1]
   uuAct.exhaust[of x, THEN add_prop[where A="a=UUact x"], rotated -1]
   rAct.exhaust[of x, THEN add_prop[where A="a=Ract x"], rotated -1]
   lAct.exhaust[of x, THEN add_prop[where A="a=Lact x"], rotated -1]
  for x a

lemma Paper_dest_conv:
  "(p =
        Paper title abstract content reviews dis decs) \<longleftrightarrow>
  title = titlePaper p \<and>
  abstract = abstractPaper p \<and>
  content = contentPaper p \<and>
  reviews = reviewsPaper p \<and>
  dis = disPaper p \<and>
  decs = decsPaper p
  "
  by (cases p) auto

end


(*******************************************************************************

  Project: IsaNet

  Author:  Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
  Version: JCSPaper.1.0
  Isabelle Version: Isabelle2021-1

  Copyright (c) 2022 Tobias Klenze
  Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)

*******************************************************************************)

section \<open>EPIC Level 1 in the Basic Attacker Model\<close>
theory EPIC_L1_BA
  imports
    "../Parametrized_Dataplane_3_directed"
    "../infrastructure/Keys"
begin

locale epic_l1_defs = network_assums_direct _ _ _ auth_seg0
  for auth_seg0 :: "(msgterm \<times> ahi list) set"
begin

(******************************************************************************)
subsection \<open>Hop validation check and extract functions\<close>
(******************************************************************************)
type_synonym EPIC_HF = "(unit, msgterm) HF"
type_synonym UINFO = "nat"

text\<open>The predicate @{term "hf_valid"} is given to the concrete parametrized model as a parameter.
It ensures the authenticity of the hop authenticator in the hop field. The predicate takes an authenticated
info field (in this model always a numeric value, hence the matching on Num ts), an unauthenticated
info field uinfo, the hop field to be validated and in some cases the next hop field.

We distinguish if there is a next hop field (this yields the two cases below). If there is not, then
the hop authenticator @{text "\<sigma>"} simply consists of a MAC over the authenticated info field and the local
routing information of the hop, using the key of the hop to which the hop field belongs. If on the
other hand, there is a subsequent hop field, then the uhi field of that hop field is also included
in the MAC computation.

The hop authenticator @{text "\<sigma>"} is used to compute both the hop validation field and the uhi field.
The first is computed as a MAC over the path origin (pair of absolute timestamp ts and the relative
timestamp given in uinfo), using the hop authenticator as a key to the MAC. The hop authenticator
is not secret, and any end host can use it to create a valid hvf. The uhi field, according to the
protocol description, is @{text "\<sigma>"} shortened to a few bytes. We model this as applying the hash on @{text "\<sigma>"}.

The predicate @{term "hf_valid"} checks if the hop authenticator, hvf and uhi field are computed
correctly.\<close>
fun hf_valid :: "msgterm \<Rightarrow> UINFO
    \<Rightarrow> EPIC_HF
    \<Rightarrow> EPIC_HF option \<Rightarrow> bool" where
  "hf_valid (Num ts) tspkt \<lparr>AHI = ahi, UHI = uhi, HVF = x\<rparr> (Some \<lparr>AHI = ahi2, UHI = uhi2, HVF = x2\<rparr>) \<longleftrightarrow>
    (\<exists>\<sigma> upif downif. \<sigma> = Mac[macKey (ASID ahi)] (L [Num ts, upif, downif, uhi2]) \<and>
          ASIF (DownIF ahi) downif \<and> ASIF (UpIF ahi) upif \<and> uhi = Hash \<sigma> \<and> x = Mac[\<sigma>] \<langle>Num ts, Num tspkt\<rangle>)"
| "hf_valid (Num ts) tspkt \<lparr>AHI = ahi, UHI = uhi, HVF = x\<rparr> None \<longleftrightarrow>
    (\<exists>\<sigma> upif downif. \<sigma> = Mac[macKey (ASID ahi)] (L [Num ts, upif, downif]) \<and>
          ASIF (DownIF ahi) downif \<and> ASIF (UpIF ahi) upif \<and> uhi = Hash \<sigma> \<and> x = Mac[\<sigma>] \<langle>Num ts, Num tspkt\<rangle>)"
| "hf_valid _ _ _ _ = False"

definition upd_uinfo :: "nat \<Rightarrow> EPIC_HF \<Rightarrow> nat" where
  "upd_uinfo uinfo hf \<equiv> uinfo"

text\<open>We can extract the entire path from the uhi field, since it includes the hop authenticator,
which includes the local forwarding information as well as, recursively, all upstream hop
authenticators and their hop information.
However, the parametrized model defines the extract function to operate on the hop validation field,
not the uhi field. We therefore define a separate function that extracts the path from a hvf.
We can do so, as both hvf and uhi contain the hop authenticator.
Internally, that function uses @{term "extrUhi"}.\<close>
fun extrUhi :: "msgterm \<Rightarrow> ahi list" where
  "extrUhi (Hash (Mac[macKey asid] (L [ts, upif, downif, uhi2])))
 = \<lparr>UpIF = term2if upif, DownIF = term2if downif, ASID = asid\<rparr> # extrUhi uhi2"
| "extrUhi (Hash (Mac[macKey asid] (L [ts, upif, downif])))
 = [\<lparr>UpIF = term2if upif, DownIF = term2if downif, ASID = asid\<rparr>]"
| "extrUhi _ = []"

text\<open>This function extracts from a hop validation field (HVF hf) the entire path.\<close>
fun extr :: "msgterm \<Rightarrow> ahi list" where
  "extr (Mac[\<sigma>] _) = extrUhi (Hash \<sigma>)"
   | "extr _ = []"

text\<open>Extract the authenticated info field from a hop validation field.\<close>
fun extr_ainfo :: "msgterm \<Rightarrow> msgterm" where
  "extr_ainfo (Mac[Mac[macKey asid] (L (Num ts # xs))] _) = Num ts"
| "extr_ainfo _ = \<epsilon>"

abbreviation term_ainfo :: "msgterm \<Rightarrow> msgterm" where
  "term_ainfo \<equiv> id"

text\<open>When observing a hop field, an attacker learns the HVF and the UHI. The AHI only contains
public information that are not terms.\<close>
fun terms_hf :: "EPIC_HF \<Rightarrow> msgterm set" where
  "terms_hf hf = {HVF hf, UHI hf}"

abbreviation terms_uinfo :: "UINFO \<Rightarrow> msgterm set" where
  "terms_uinfo x \<equiv> {}"

text\<open>An authenticated info field is always a number (corresponding to a timestamp). The
     unauthenticated info field is as well a number, representing combination of timestamp offset
     and SRC address.\<close>
definition auth_restrict where
  "auth_restrict ainfo uinfo l \<equiv> (\<exists>ts. ainfo = Num ts)"

abbreviation no_oracle where "no_oracle \<equiv> (\<lambda> _ _. True)"

text\<open>We now define useful properties of the above definition.\<close>
lemma hf_valid_invert:
  "hf_valid tsn uinfo hf mo \<longleftrightarrow>
   ((\<exists>ahi ahi2 \<sigma> ts upif downif asid x upif2 downif2 asid2 uhi uhi2 x2.
     hf = \<lparr>AHI = ahi, UHI = uhi, HVF = x\<rparr> \<and>
     ASID ahi = asid \<and> ASIF (DownIF ahi) downif \<and> ASIF (UpIF ahi) upif \<and>
     mo = Some \<lparr>AHI = ahi2, UHI = uhi2, HVF = x2\<rparr> \<and>
     ASID ahi2 = asid2 \<and> ASIF (DownIF ahi2) downif2 \<and> ASIF (UpIF ahi2) upif2 \<and>
     \<sigma> = Mac[macKey asid] (L [tsn, upif, downif, uhi2]) \<and>
     tsn = Num ts \<and>
     uhi = Hash \<sigma> \<and>
     x = Mac[\<sigma>] \<langle>tsn, Num uinfo\<rangle>)
 \<or> (\<exists>ahi \<sigma> ts upif downif asid uhi x.
     hf = \<lparr>AHI = ahi, UHI = uhi, HVF = x\<rparr> \<and>
     ASID ahi = asid \<and> ASIF (DownIF ahi) downif \<and> ASIF (UpIF ahi) upif \<and>
     mo = None \<and>
     \<sigma> = Mac[macKey asid] (L [tsn, upif, downif]) \<and>
     tsn = Num ts \<and>
     uhi = Hash \<sigma> \<and>
     x = Mac[\<sigma>] \<langle>tsn, Num uinfo\<rangle>)
    )"
  apply(auto elim!: hf_valid.elims) using option.exhaust ASIF.simps by metis+

lemma hf_valid_auth_restrict[dest]: "hf_valid ainfo uinfo hf z \<Longrightarrow> auth_restrict ainfo uinfo l"
  by(auto simp add: hf_valid_invert auth_restrict_def)

lemma auth_restrict_ainfo[dest]: "auth_restrict ainfo uinfo l \<Longrightarrow> \<exists>ts. ainfo = Num ts"
  by(auto simp add: auth_restrict_def)

lemma info_hvf:
  assumes "hf_valid ainfo uinfo m z" "HVF m = Mac[\<sigma>] \<langle>ainfo', Num uinfo'\<rangle> \<or> hf_valid ainfo' uinfo' m z'"
  shows "uinfo = uinfo'" "ainfo' = ainfo"
  using assms by(auto simp add: hf_valid_invert)

(******************************************************************************)
subsection\<open>Definitions and properties of the added intruder knowledge\<close>
(******************************************************************************)
text\<open>Here we define a sets which are added to the intruder knowledge: @{text "ik_add"}, which contains hop
authenticators.\<close>

print_locale dataplane_3_directed_defs
sublocale dataplane_3_directed_defs _ _ _ auth_seg0 hf_valid auth_restrict extr extr_ainfo term_ainfo
                 terms_hf terms_uinfo upd_uinfo no_oracle
  by unfold_locales

declare TWu.holds_set_list[dest]
declare TWu.holds_takeW_is_identity[simp]
declare parts_singleton[dest]

text\<open>This additional Intruder Knowledge allows us to model the attacker's access not only to the
hop validation fields and segment identifiers of authorized segments (which are already given in
@{text "ik_hfs"}), but to the underlying hop authenticators that are used to create them.\<close>

definition ik_add :: "msgterm set" where
  "ik_add \<equiv> { \<sigma> | ainfo uinfo l hf \<sigma>.
                 (ainfo, l) \<in> auth_seg2 uinfo \<and> hf \<in> set l \<and> HVF hf = Mac[\<sigma>] \<langle>ainfo, Num uinfo\<rangle> }"

lemma ik_addI:
  "\<lbrakk>(ainfo, l) \<in> auth_seg2 uinfo; hf \<in> set l; HVF hf = Mac[\<sigma>] \<langle>ainfo, Num uinfo\<rangle>\<rbrakk> \<Longrightarrow> \<sigma> \<in> ik_add"
  by(auto simp add: ik_add_def)

lemma ik_add_form: "t \<in> ik_add \<Longrightarrow> \<exists> asid l . t = Mac[macKey asid] l"
  by(auto simp add: ik_add_def auth_seg2_def hf_valid_invert dest!: TWu.holds_set_list)

lemma parts_ik_add[simp]: "parts ik_add = ik_add"
  by (auto intro!: parts_Hash dest: ik_add_form)

abbreviation ik_oracle :: "msgterm set" where "ik_oracle \<equiv> {}"

(******************************************************************************)
subsection\<open>Properties of the intruder knowledge, including @{text "ik_add"} and  @{text "ik_oracle"}\<close>
(******************************************************************************)
text\<open>We now instantiate the parametrized model's definition of the intruder knowledge, using the
definitions of @{text "ik_add"} and  @{text "ik_oracle"} from above. We then prove the properties
that we need to instantiate the @{text "dataplane_3_directed"} locale.\<close>
sublocale
  dataplane_3_directed_ik_defs _ _ _ auth_seg0 terms_uinfo no_oracle hf_valid auth_restrict extr extr_ainfo term_ainfo
                  terms_hf upd_uinfo ik_add ik_oracle
  by unfold_locales

lemma ik_hfs_form: "t \<in> parts ik_hfs \<Longrightarrow> \<exists> t' . t = Hash t'"
  by(auto 3 4 simp add: auth_seg2_def hf_valid_invert)

declare ik_hfs_def[simp del]

lemma parts_ik_hfs[simp]: "parts ik_hfs = ik_hfs"
  by (auto intro!: parts_Hash ik_hfs_form)

text\<open>This lemma allows us not only to expand the definition of @{term "ik_hfs"}, but also
to obtain useful properties, such as a term being a Hash, and it being part of a valid hop field.\<close>
lemma ik_hfs_simp:
  "t \<in> ik_hfs \<longleftrightarrow> (\<exists>t' . t = Hash t') \<and> (\<exists>hf . (t = HVF hf \<or> t = UHI hf)
                    \<and> (\<exists>hfs. hf \<in> set hfs \<and> (\<exists>ainfo uinfo. (ainfo, hfs) \<in> auth_seg2 uinfo
                    \<and> (\<exists> nxt. hf_valid ainfo uinfo hf nxt))))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume asm: "?lhs"
  then obtain ainfo uinfo hf hfs where
    dfs: "hf \<in> set hfs" "(ainfo, hfs) \<in> auth_seg2 uinfo" "t = HVF hf \<or> t = UHI hf"
    by(auto simp add: ik_hfs_def)
  then have "hfs_valid_None ainfo uinfo hfs"  "(ainfo, AHIS hfs) \<in> auth_seg0"
    by(auto simp add: auth_seg2_def)
  then show "?rhs" using asm dfs
    using upd_uinfo_def
    by (auto 3 4 simp add: auth_seg2_def intro!: ik_hfs_form exI[of _ hf] exI[of _ hfs]
                     dest: TWu.holds_set_list_no_update)
qed(auto simp add: ik_hfs_def)

(******************************************************************************)
subsubsection \<open>Properties of Intruder Knowledge\<close>
(******************************************************************************)
lemma auth_ainfo[dest]: "\<lbrakk>(ainfo, hfs) \<in> auth_seg2 uinfo\<rbrakk> \<Longrightarrow> \<exists> ts . ainfo = Num ts"
  by(auto simp add: auth_seg2_def)

lemma Num_ik[intro]: "Num ts \<in> ik"
  by(auto simp add: ik_def auth_seg2_def auth_restrict_def TWu.holds.simps intro!: exI[of _ "[]"])

text \<open>There are no ciphertexts (or signatures) in @{term "parts ik"}. Thus, @{term "analz ik"}
and @{term "parts ik"} are identical.\<close>
lemma analz_parts_ik[simp]: "analz ik = parts ik"
  apply(rule no_crypt_analz_is_parts)
  by(auto simp add: ik_def auth_seg2_def)
    (auto 3 4 simp add: ik_add_def auth_seg2_def hf_valid_invert ik_hfs_simp)

lemma parts_ik[simp]: "parts ik = ik"
  by(auto 3 4 simp add: ik_def auth_seg2_def auth_restrict_def dest!: parts_singleton_set)

lemma key_ik_bad: "Key (macK asid) \<in> ik \<Longrightarrow> asid \<in> bad"
  by(auto simp add: ik_def)
    (auto 3 4 simp add: auth_seg2_def ik_hfs_simp ik_add_def hf_valid_invert)

(******************************************************************************)
subsubsection\<open>Hop authenticators are agnostic to uinfo field\<close>
(******************************************************************************)
text\<open>Those hop validation fields contained in @{term "auth_seg2"} or that can be generated from the hop
authenticators in @{text "ik_add"} have the property that they are agnostic about the uinfo field. If a
hop validation field is contained in @{term "auth_seg2"} (resp. derivable from @{text "ik_add"}),
then a field with a different uinfo is also contained (resp. derivable).
To show this, we first define a function that changes uinfo in a hop validation field.\<close>
fun uinfo_change_hf :: "UINFO \<Rightarrow> EPIC_HF \<Rightarrow> EPIC_HF" where
  "uinfo_change_hf new_uinfo hf =
    (case HVF hf of Mac[\<sigma>] \<langle>ainfo, uinfo\<rangle> \<Rightarrow> hf\<lparr>HVF := Mac[\<sigma>] \<langle>ainfo, Num new_uinfo\<rangle>\<rparr> | _ \<Rightarrow> hf)"

fun uinfo_change :: "UINFO \<Rightarrow> EPIC_HF list \<Rightarrow> EPIC_HF list" where
  "uinfo_change new_uinfo hfs = map (uinfo_change_hf new_uinfo) hfs"

lemma uinfo_change_valid:
  "hfs_valid ainfo uinfo l nxt \<Longrightarrow> hfs_valid ainfo new_uinfo (uinfo_change new_uinfo l) nxt"
  apply(induction l nxt rule: TWu.holds.induct[where ?upd=upd_uinfo])
  apply auto
  subgoal for info x y ys nxt
    by(cases "map (uinfo_change_hf new_uinfo) ys")
      (cases info, auto 3 4 simp add: TWu.holds_split_tail hf_valid_invert upd_uinfo_def)+
  by(auto 3 4 simp add: TWu.holds_split_tail hf_valid_invert TWu.holds.simps upd_uinfo_def)

lemma uinfo_change_hf_AHI: "AHI (uinfo_change_hf new_uinfo hf) = AHI hf"
  apply(cases "HVF hf") apply auto
  subgoal for x apply(cases x) apply auto
    subgoal for x1 x2 apply(cases x2) by auto
    done
  done

lemma uinfo_change_hf_AHIS[simp]: "AHIS (map (uinfo_change_hf new_uinfo) l) = AHIS l"
  apply(induction l) using uinfo_change_hf_AHI by auto

lemma uinfo_change_auth_seg2:
  assumes "hf_valid ainfo uinfo m z" "\<sigma> = Mac[Key (macK asid)] j"
          "HVF m = Mac[\<sigma>] \<langle>ainfo, Num uinfo'\<rangle>" "\<sigma> \<in> ik_add"
  shows "\<exists>hfs. m \<in> set hfs \<and> (\<exists>uinfo''. (ainfo, hfs) \<in> auth_seg2 uinfo'')"
proof-
  from assms(4) obtain ainfo_add uinfo_add l_add hf_add where
    "(ainfo_add, l_add) \<in> auth_seg2 uinfo_add" "hf_add \<in> set l_add" "HVF hf_add = Mac[\<sigma>] \<langle>ainfo_add, Num uinfo_add\<rangle>"
    by(auto simp add: ik_add_def)
  then have add: "m \<in> set (uinfo_change uinfo l_add)" "(ainfo_add, (uinfo_change uinfo l_add)) \<in> auth_seg2 uinfo"
    using assms(1-3) apply(auto simp add: auth_seg2_def simp del: AHIS_def)
    apply(auto simp add: hf_valid_invert intro!: image_eqI dest!: TWu.holds_set_list)[1]
    by(auto simp add: auth_restrict_def intro!: exI elim: ahi_eq dest: uinfo_change_valid simp del: AHIS_def)
  then have "ainfo_add = ainfo"
    using assms(1) by(auto simp add: auth_seg2_def dest!: TWu.holds_set_list dest: info_hvf)
  then show ?thesis using add by fastforce
qed

lemma MAC_synth_helper:
"\<lbrakk>hf_valid ainfo uinfo m z;
  HVF m = Mac[\<sigma>] \<langle>ainfo, Num uinfo\<rangle>; \<sigma> = Mac[Key (macK asid)] j; \<sigma> \<in> ik \<or> HVF m \<in> ik\<rbrakk>
       \<Longrightarrow> \<exists>hfs. m \<in> set hfs \<and> (\<exists>uinfo'. (ainfo, hfs) \<in> auth_seg2 uinfo')"
  apply(auto simp add: ik_def ik_hfs_simp dest: ik_add_form)
  prefer 3 subgoal by(auto elim!: uinfo_change_auth_seg2)
  prefer 3 subgoal by(auto elim!: uinfo_change_auth_seg2 intro: ik_addI dest: info_hvf HOL.sym)
  by(auto simp add: hf_valid_invert)

text\<open>This definition helps with the limiting the number of cases generated. We don't require it,
but it is convenient. Given a hop validation field and an asid, return if the hvf has the expected
format.\<close>
definition mac_format :: "msgterm \<Rightarrow> as \<Rightarrow> bool" where
  "mac_format m asid \<equiv> \<exists> j ts uinfo . m = Mac[Mac[macKey asid] j] \<langle>Num ts, uinfo\<rangle>"

text\<open>If a valid hop field is derivable by the attacker, but does not belong to the attacker, then
the hop field is already contained in the set of authorized segments.\<close>
lemma MAC_synth:
  assumes "hf_valid ainfo uinfo m z" "HVF m \<in> synth ik" "mac_format (HVF m) asid"
    "asid \<notin> bad"
  shows "\<exists>hfs . m \<in> set hfs \<and> (\<exists>uinfo'. (ainfo, hfs) \<in> auth_seg2 uinfo')"
  using assms
  apply(auto simp add: mac_format_def elim!: MAC_synth_helper dest!: key_ik_bad)
  apply(auto simp add: ik_def ik_hfs_simp dest: ik_add_form) (* takes a few seconds *)
  using assms(1) by(auto dest: info_hvf simp add: hf_valid_invert)

(******************************************************************************)
subsection\<open>Direct proof goals for interpretation of @{text "dataplane_3_directed"}\<close>
(******************************************************************************)

lemma COND_honest_hf_analz:
  assumes "ASID (AHI hf) \<notin> bad" "hf_valid ainfo uinfo hf nxt" "terms_hf hf \<subseteq> synth (analz ik)"
    "no_oracle ainfo uinfo"
    shows "terms_hf hf \<subseteq> analz ik"
proof-
  let ?asid = "ASID (AHI hf)"
  from assms(3) have hf_synth_ik: "HVF hf \<in> synth ik" "UHI hf \<in> synth ik" by auto
  from assms(2) have "mac_format (HVF hf) ?asid"
    by(auto simp add: mac_format_def hf_valid_invert)
  then obtain hfs uinfo where "hf \<in> set hfs" "(ainfo, hfs) \<in> auth_seg2 uinfo"
    using assms(1,2,4) hf_synth_ik by(auto dest!: MAC_synth)
  then have "HVF hf \<in> ik" "UHI hf \<in> ik"
    using assms(2)
    by(auto simp add: ik_hfs_def intro!: ik_ik_hfs intro!: exI)
  then show ?thesis by auto
qed

lemma COND_terms_hf:
  assumes "hf_valid ainfo uinfo hf z" and "HVF hf \<in> ik" and "no_oracle ainfo uinfo"
  shows "\<exists>hfs. hf \<in> set hfs \<and> (\<exists>uinfo . (ainfo, hfs) \<in> auth_seg2 uinfo)"
proof-
  obtain hfs ainfo where hfs_def: "hf \<in> set hfs" "(ainfo, hfs) \<in> auth_seg2 uinfo"
  using assms by(auto 3 4 simp add: hf_valid_invert ik_hfs_simp ik_def dest: ahi_eq
                             dest!: ik_add_form)
  then obtain hfs ainfo where hfs_def: "hf \<in> set hfs" "(ainfo, hfs) \<in> auth_seg2 uinfo" by auto
  show ?thesis
    using hfs_def apply (auto simp add: auth_seg2_def dest!: TWu.holds_set_list)
    using hfs_def assms(1) by (auto simp add: auth_seg2_def dest: info_hvf)
qed

lemma COND_extr_prefix_path:
  "\<lbrakk>hfs_valid ainfo uinfo l nxt; nxt = None\<rbrakk> \<Longrightarrow> prefix (extr_from_hd l) (AHIS l)"
  by(induction l nxt rule: TWu.holds.induct[where ?upd=upd_uinfo])
    (auto simp add: upd_uinfo_def TWu.holds_split_tail TWu.holds.simps(1) hf_valid_invert,
     auto split: list.split_asm simp add: hf_valid_invert intro!: ahi_eq elim: ASIF.elims)

lemma COND_path_prefix_extr:
  "prefix (AHIS (hfs_valid_prefix ainfo uinfo l nxt))
          (extr_from_hd l)"
  apply(induction l nxt rule: TWu.takeW.induct[where ?Pa="hf_valid ainfo",where ?upd=upd_uinfo])
  by(auto simp add: upd_uinfo_def TWu.takeW_split_tail TWu.takeW.simps(1))
    (auto 3 4 simp add: hf_valid_invert intro!: ahi_eq elim: ASIF.elims)

lemma COND_hf_valid_uinfo:
  "\<lbrakk>hf_valid ainfo uinfo hf nxt; hf_valid ainfo' uinfo' hf nxt'\<rbrakk> \<Longrightarrow> uinfo' = uinfo"
  by(auto dest: info_hvf)

lemma COND_upd_uinfo_ik:
    "\<lbrakk>terms_uinfo uinfo \<subseteq> synth (analz ik); terms_hf hf \<subseteq> synth (analz ik)\<rbrakk>
    \<Longrightarrow> terms_uinfo (upd_uinfo uinfo hf) \<subseteq> synth (analz ik)"
  by (auto simp add: upd_uinfo_def)

lemma COND_upd_uinfo_no_oracle:
  "no_oracle ainfo uinfo \<Longrightarrow> no_oracle ainfo (upd_uinfo uinfo fld)"
  by (auto simp add: upd_uinfo_def)

lemma COND_auth_restrict_upd:
      "auth_restrict ainfo uinfo (x#y#hfs)
   \<Longrightarrow> auth_restrict ainfo (upd_uinfo uinfo y) (y#hfs)"
  by (auto simp add: auth_restrict_def upd_uinfo_def)

(******************************************************************************)
subsection\<open>Instantiation of @{text "dataplane_3_directed"} locale\<close>
(******************************************************************************)
(******************************************************************************)
print_locale dataplane_3_directed
sublocale
  dataplane_3_directed _ _ _ auth_seg0 terms_uinfo terms_hf hf_valid auth_restrict extr extr_ainfo term_ainfo
            upd_uinfo ik_add
            ik_oracle no_oracle
  apply unfold_locales
  using COND_terms_hf COND_honest_hf_analz COND_extr_prefix_path
  COND_path_prefix_extr COND_hf_valid_uinfo COND_upd_uinfo_ik COND_upd_uinfo_no_oracle
  COND_auth_restrict_upd by auto

end
end


theory WordArray_Shallow
  imports Generated_AllRefine

begin

section "Helper Functions and Lemmas"

fun myslice :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
"myslice frm to xs = List.take (to - frm) (List.drop frm xs)"

section "Shallow Word Array Function Definitions"

overloading
  wordarray_put2' \<equiv> wordarray_put2
begin
definition wordarray_put2':
 "wordarray_put2' (x :: ('a WordArray, 32 word, 'a) WordArrayPutP) \<equiv> (WordArrayPutP.arr\<^sub>f x)[unat (WordArrayPutP.idx\<^sub>f x) := WordArrayPutP.val\<^sub>f x]"
end

overloading
  wordarray_length' \<equiv> wordarray_length
begin
definition wordarray_length':
 "wordarray_length' (x :: 'a WordArray) \<equiv> (of_nat (length x) :: 32 word)"
end

overloading
  wordarray_get' \<equiv> wordarray_get
begin
definition wordarray_get':
 "wordarray_get' (x :: (('a::len8) word WordArray, 32 word) T0) \<equiv> (if unat (T0.p2\<^sub>f x) < length (T0.p1\<^sub>f x) then (T0.p1\<^sub>f x) ! unat (T0.p2\<^sub>f x) else 0)"
end

overloading
  wordarray_fold_no_break' \<equiv> wordarray_fold_no_break
begin
definition wordarray_fold_no_break':
 "wordarray_fold_no_break' (x :: ('a WordArray, 32 word, 32 word, ('a, 'acc, 'obsv) ElemAO \<Rightarrow> 'acc, 'acc, 'obsv) WordArrayMapNoBreakP) \<equiv>
    fold (\<lambda>a b. (WordArrayMapNoBreakP.f\<^sub>f x) (ElemAO.make a b (WordArrayMapNoBreakP.obsv\<^sub>f x)))
         (myslice (unat (WordArrayMapNoBreakP.frm\<^sub>f x)) (unat (WordArrayMapNoBreakP.to\<^sub>f x)) (WordArrayMapNoBreakP.arr\<^sub>f x))
         (WordArrayMapNoBreakP.acc\<^sub>f x)"
end

fun mapAccum :: "('a \<Rightarrow> 'b  \<Rightarrow> ('c \<times> 'b)) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> ('c list \<times> 'b)"
  where
"mapAccum _ [] acc = ([], acc)" |
"mapAccum f (x#xs) acc =
  (let (a, b) = f x acc;
       (as, b') = mapAccum f xs b
   in (a#as, b'))"

fun listAccumStep :: "('a \<Rightarrow> 'b  \<Rightarrow> ('c \<times> 'b)) \<Rightarrow> 'a \<Rightarrow> ('c list \<times> 'b) \<Rightarrow> ('c list \<times> 'b)"
  where
"listAccumStep f x (ys, acc) = (let (y, acc') = f x acc in (ys @ [y], acc'))"

lemma mapAccum_step:
  "mapAccum f (xs @ [x]) acc = listAccumStep f x (mapAccum f xs acc)"
  apply (induct arbitrary: x acc rule: list.induct)
   apply clarsimp
  apply (clarsimp split: prod.split)
  done

lemma mapAccum_length:
  "length (prod.fst (mapAccum f xs acc)) = length xs"
  apply (induct arbitrary: acc rule: rev_induct)
   apply simp
  apply (subst mapAccum_step)
  apply clarsimp
  apply (drule_tac x = acc in meta_spec)
  by (metis (no_types, lifting) Product_Type.split_def fst_conv length_append_singleton listAccumStep.simps prod.collapse)

lemma
  "map f xs = prod.fst (mapAccum (\<lambda>a b. (f a, b)) xs ())"
  by (induct xs; clarsimp split: prod.split)

lemma
  "fold f xs acc = prod.snd (mapAccum (\<lambda>a b. (a, f a b)) xs acc)"
  apply (induct rule: rev_induct; clarsimp split: prod.split)
  apply (subst mapAccum_step)
  by (metis (no_types, lifting) case_prod_beta listAccumStep.simps prod.collapse snd_conv)

fun cogent_isa_pair :: "('a, 'b) T0 \<Rightarrow> ('a \<times> 'b)"
  where
"cogent_isa_pair x = (T0.p1\<^sub>f x, T0.p2\<^sub>f x)"

term "mapAccum
          (\<lambda>a b. cogent_isa_pair ((WordArrayMapNoBreakP.f\<^sub>f x) (ElemAO.make a b (WordArrayMapNoBreakP.obsv\<^sub>f x))))
          (myslice (unat (WordArrayMapNoBreakP.frm\<^sub>f x)) (unat (WordArrayMapNoBreakP.to\<^sub>f x)) (WordArrayMapNoBreakP.arr\<^sub>f x))
          (WordArrayMapNoBreakP.acc\<^sub>f x)"
overloading
  wordarray_map_no_break' \<equiv> wordarray_map_no_break
begin
definition wordarray_map_no_break':
 "wordarray_map_no_break' (x :: ('a WordArray, 32 word, 32 word, ('a, 'acc, 'obsv) ElemAO \<Rightarrow> ('a, 'acc) T0, 'acc, 'obsv) WordArrayMapNoBreakP) \<equiv>
    (let xs = List.take (unat (WordArrayMapNoBreakP.frm\<^sub>f x)) (WordArrayMapNoBreakP.arr\<^sub>f x);
         zs = List.drop (unat (WordArrayMapNoBreakP.to\<^sub>f x)) (WordArrayMapNoBreakP.arr\<^sub>f x);
        (ys, acc) = mapAccum
          (\<lambda>a b. cogent_isa_pair ((WordArrayMapNoBreakP.f\<^sub>f x) (ElemAO.make a b (WordArrayMapNoBreakP.obsv\<^sub>f x))))
          (myslice (unat (WordArrayMapNoBreakP.frm\<^sub>f x)) (unat (WordArrayMapNoBreakP.to\<^sub>f x)) (WordArrayMapNoBreakP.arr\<^sub>f x))
          (WordArrayMapNoBreakP.acc\<^sub>f x)
    in (if (WordArrayMapNoBreakP.frm\<^sub>f x) \<le> (WordArrayMapNoBreakP.to\<^sub>f x)
        then T0.make (xs @ ys @ zs) acc
        else T0.make (WordArrayMapNoBreakP.arr\<^sub>f x) acc))"
end

end


theory "CoCallGraph-Nominal"
imports CoCallGraph "Launchbury.Nominal-HOLCF"
begin

instantiation CoCalls :: pt
begin
  lift_definition permute_CoCalls :: "perm \<Rightarrow> CoCalls \<Rightarrow> CoCalls" is "permute"
    by (auto intro!: symI elim: symE simp add: mem_permute_set)
instance
  apply standard
  apply (transfer, simp)+
  done
end

instance CoCalls :: cont_pt
  apply standard
  apply (rule contI2)
  apply (rule monofunI)
  apply transfer
  apply (metis (full_types) True_eqvt subset_eqvt)
  apply (thin_tac "chain _")+
  apply transfer
  apply simp
  done

lemmas lub_eqvt[OF exists_lub, simp, eqvt]

lemma cc_restr_perm:
  fixes G :: CoCalls
  assumes "supp p \<sharp>* S" and [simp]: "finite S"
  shows "cc_restr S (p \<bullet> G) = cc_restr S G"
  using assms
  apply -
  apply transfer
  apply (auto simp add: mem_permute_set)
  apply (subst (asm) perm_supp_eq, simp add: supp_minus_perm, metis (full_types) fresh_def fresh_star_def supp_set_elem_finite)+
  apply assumption
  apply (subst perm_supp_eq, simp add: supp_minus_perm, metis (full_types) fresh_def fresh_star_def supp_set_elem_finite)+
  apply assumption
  done

lemma inCC_eqvt[eqvt]: "\<pi> \<bullet> (x--y\<in>G) = (\<pi>\<bullet>x)--(\<pi>\<bullet>y)\<in>(\<pi>\<bullet>G)"
  by transfer auto
lemma cc_restr_eqvt[eqvt]: "\<pi> \<bullet> cc_restr S G = cc_restr (\<pi> \<bullet> S) (\<pi> \<bullet> G)"
  by transfer (perm_simp, rule)
lemma ccProd_eqvt[eqvt]: "\<pi> \<bullet> ccProd S S' = ccProd (\<pi> \<bullet> S) (\<pi> \<bullet>  S')"
  by transfer (perm_simp, rule)
lemma ccSquare_eqvt[eqvt]: "\<pi> \<bullet> ccSquare S = ccSquare (\<pi> \<bullet> S)"
  unfolding ccSquare_def
  by perm_simp rule
lemma ccNeighbors_eqvt[eqvt]: "\<pi> \<bullet> ccNeighbors S G = ccNeighbors (\<pi> \<bullet> S) (\<pi> \<bullet> G)"
  by transfer (perm_simp, rule)

end