(*
    File:        OccGraft.thy
    Time-stamp:  <2015-12-25T10:47:28Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory OccGraft imports SubOcc begin

definition lists_subtree :: "[i, i] => i" where
"lists_subtree(b, W) == {z. y: W, y = Cons(b, z)}"

definition Occ_Shift :: "[i, i] => i" where
"Occ_Shift(m, X) == {z. y: X, EX l T. z = <m@l, T> & y = <l, T>}"

definition Incomparable :: "i=>o" where
"Incomparable(W) == ALL l: W. ALL m: W.
           initseg(nat, l, m) | initseg(nat, m, l) --> l = m"

definition Occ_Graft1 :: "[i, i, i] => i" where
"Occ_Graft1(X, l, Y) == (X - {u: X. EX m T. u = <m, T> &
                                       initseg(nat, l, m)}) Un
                         Occ_Shift(l, Y)"

definition Occ_Graft :: "[i, i, i] => i" where
"Occ_Graft(X, W, Y)  == (X - (UN l: W. {u: X. EX m T. u = <m, T> &
                                                initseg(nat, l, m)}))
                       Un (UN l: W. Occ_Shift(l, Y))"

(** lists_subtree **)
lemma lists_subtreeI:
  "Cons(b, l): X ==> l: lists_subtree(b, X)"
apply (unfold lists_subtree_def)
apply (rule ReplaceI)
prefer 2 apply assumption
apply (rule refl)
apply simp
done

lemma lists_subtreeD:
  "l: lists_subtree(b, X) ==> Cons(b, l): X"
apply (unfold lists_subtree_def)
apply blast
done

lemma lists_subtreeE:
  "[| l: lists_subtree(b, X);
      Cons(b, l): X ==> R |] ==> R"
apply (unfold lists_subtree_def)
apply blast
done

lemma lists_subtree_domain_eq:
  "lists_subtree(b, domain(X)) = domain(Occ_subtree(b, X))"
apply (rule equalityI)
apply (blast intro: Occ_subtreeI lists_subtreeI
         elim!: Occ_subtreeE lists_subtreeE)+
done

lemma lists_subtree_mono:
  "X <= W ==> lists_subtree(b, X) <= lists_subtree(b, W)"
apply (blast intro: lists_subtreeI elim!: lists_subtreeE)
done

(** Occ_Shift **)
lemma Occ_ShiftI:
  "<l, T>: X ==> <m@l, T>: Occ_Shift(m, X)"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_ShiftD:
  "[| <m@l, T>: Occ_Shift(m, X); m: list(A) |] ==> <l, T>: X"
apply (unfold Occ_Shift_def)
apply (elim ReplaceE exE conjE)
apply simp
done

lemma Occ_ShiftE:
  "[| x: Occ_Shift(m, X);
      !!l T. [| x = <m@l, T>; <l, T>: X |] ==> R
   |]==> R"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_ShiftE2:
  "[| <n, T>: Occ_Shift(m, X);
      !!l. [| n = m@l; <l, T>: X |] ==> R
   |]==> R"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_Shift_0:
  "Occ_Shift(m, 0) = 0"
apply (unfold Occ_Shift_def)
apply blast
done

lemma Occ_Shift_Nil:
  "X <= A * B ==> Occ_Shift([], X) = X"
apply (unfold Occ_Shift_def)
apply simp
apply blast
done

lemma Occ_Shift_Cons:
  "Occ_Shift(Cons(a, l), X) = Occ_shift(a, Occ_Shift(l, X))"
apply (rule equalityI)
apply (safe elim!: Occ_shiftE Occ_ShiftE)
apply simp
apply (blast intro: Occ_shiftI Occ_ShiftI)
apply (simp del: app_Cons add: app_Cons [THEN sym])
apply (rule Occ_ShiftI)
apply assumption
done

lemma Occ_Shift_domain:
  "[| X <= list(A) * B; m: list(A) |] ==> Occ_Shift(m, X) <= list(A) * B"
apply (blast intro: app_type elim!: Occ_ShiftE)
done

lemma Occ_Shift_app:
  assumes prem1: "l: list(A)"
  and prem2: "m: list(B)"
  and prem3: "X <= list(B) * D"
  shows "Occ_Shift(l@m, X) = Occ_Shift(l, Occ_Shift(m, X))"
apply (rule prem3 [THEN rev_mp])
apply (rule_tac x="X" in spec)
apply (rule prem1 [THEN list.induct])
apply (intro impI allI)
apply (drule Occ_Shift_domain)
apply (rule prem2)
apply (simp_all add: Occ_Shift_Nil Occ_Shift_Cons)
done

(** Incomparable **)
lemma IncomparableI:
  "[| !!l m. [| l: W; m: W; initseg(nat, l, m) |] ==> l = m |]
     ==> Incomparable(W)"
apply (unfold Incomparable_def)
apply blast
done

lemma IncomparableD:
  "[| Incomparable(W);
      initseg(nat, l, m);
      l: W; m: W |] ==> l = m"
apply (unfold Incomparable_def)
apply blast
done

lemma Incomparable_lists_subtree:
  assumes major: "Incomparable(W)"
  and prem: "a: nat"
  shows "Incomparable(lists_subtree(a, W))"
apply (rule IncomparableI)
apply (elim lists_subtreeE)
apply (drule prem [THEN initseg_ConsI])
apply (drule major [THEN IncomparableD])
apply assumption+
apply simp
done

lemma Incomparable_subset:
  assumes major: "Incomparable(W)"
  and prem: "X <= W"
  shows "Incomparable(X)"
apply (rule IncomparableI)
apply (erule major [THEN IncomparableD])
apply (erule prem [THEN subsetD])+
done

lemma Incomparable_CorrectArity_0_lemma:
  assumes major: "initseg(nat, l, m)"
  and prem1: "<l, T>: X"
  and prem2: "<m, U>: X"
  and hierX: "DenseTree(X)"
  and corrT: "CorrectArity(X, T, 0)"
  and m_list: "m: list(nat)"
  shows "l = m"
apply (rule prem2 [THEN rev_mp])
apply (rule prem1 [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule_tac x="U" in spec)
apply (rule m_list [THEN list_append_induct])
apply (intro allI impI)
apply (erule initseg_NilE)
apply assumption
apply (intro allI impI)
apply (erule  initseg_right_appE)
apply assumption
apply (rule corrT [THEN CorrectArityD2, THEN notE])
apply assumption
apply (erule nat_into_Ord [THEN Ord_0_le])
apply (rule hierX [THEN DenseTreeE])
apply (rule_tac [2] initseg_appI1)
apply assumption+
apply (drule spec)
apply (drule mp, assumption)+
apply hypsubst
apply (erule exI)
apply (rename_tac m n)
apply (erule_tac a="m" in list.cases)
apply hypsubst
apply simp
apply (rule corrT [THEN CorrectArityD2, THEN notE])
apply (rule_tac [3] exI)
apply (erule_tac [2] nat_into_Ord [THEN Ord_0_le])
apply assumption
apply hypsubst
apply assumption
apply simp
done

lemma Incomparable_CorrectArity_0:
  assumes domX: "X <= list(nat)* B"
  and hierX: "DenseTree(X)"
  shows "Incomparable(domain({<l, T>: X. CorrectArity(X, T, 0)}))"
apply (rule IncomparableI)
apply (elim domainE CollectE)
apply simp
apply (erule Incomparable_CorrectArity_0_lemma)
apply (erule_tac [5] domX [THEN subsetD, THEN SigmaD1])
apply (assumption | rule hierX)+
done

(** Occ_Graft1 **)
lemma Occ_Graft1I1:
  "[| <l, T>: X; ~initseg(nat, m, l) |]
      ==> <l, T>: Occ_Graft1(X, m, Y)"
apply (unfold Occ_Graft1_def)
apply blast
done

lemma Occ_Graft1I2:
  "<l, T>: Occ_Shift(m, Y) ==> <l, T>: Occ_Graft1(X, m, Y)"
apply (unfold Occ_Graft1_def)
apply blast
done

lemma Occ_Graft1E:
  "[| x: Occ_Graft1(X, m, Y);
      X <= A * B;
      !! l T. [| x = <l, T>; <l, T>: X; l: A; T: B;
                ~initseg(nat, m, l) |] ==> R;
      x: Occ_Shift(m, Y) ==> R
   |] ==> R"
apply (unfold Occ_Graft1_def)
apply blast
done

lemma Occ_Graft1_domain:
  assumes domX: "X <= list(A) * B"
  and domY: "Y <= list(A) * B"
  and m_list: "m: list(A)"
  shows "Occ_Graft1(X, m, Y) <= list(A) * B"
apply (rule subsetI)
apply (erule Occ_Graft1E)
apply (rule domX)
apply (erule_tac [2] Occ_Shift_domain [OF domY m_list, THEN subsetD])
apply blast
done

lemma Occ_Graft1_Nil:
  assumes prem1: "X <= list(nat) * B"
  and prem2: "Y <= list(nat) * D"
  shows "Occ_Graft1(X, [], Y) = Y"
apply (rule equalityI)
apply (safe elim!: prem1 [THEN [2] Occ_Graft1E] Occ_ShiftE)
prefer 2 apply simp
apply (erule notE)
apply (erule initseg_NilI)
apply (frule prem2 [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (rule Occ_Graft1I2)
apply (rule_tac P="%x. <x, y>: Occ_Shift([], Y)"
        in app_Nil [THEN subst])
apply (erule Occ_ShiftI)
done

lemma Occ_Graft1_Occ_cons_Cons:
  "[| T: Tag; l: list(Pow(list(nat)*Tag)); m: list(nat);
      a: length(l) |] ==>
    Occ_Graft1(Occ_cons(T, l), Cons(a, m), Y) =
        Occ_cons(T, mapnth(%x r. if(a = x, Occ_Graft1(r, m, Y), r), l))"
apply (rule equalityI)
apply (safe elim!: Occ_cons_type [THEN [2] Occ_Graft1E]
           Occ_ShiftE Occ_consE)
apply assumption+
apply (rule Occ_consI1)
prefer 3
apply (rule Occ_Graft1I1)
apply (rule Occ_consI1)
apply (rule notI)
apply (erule initseg_NilE)
apply simp
apply (rule Occ_consI2)
apply (simp add: length_mapnth)
apply (simp add: nth_mapnth)
apply (rule impI)
apply hypsubst
apply (rule Occ_Graft1I1)
apply assumption
apply (rule notI)
apply (erule notE)
apply (rule initseg_ConsI)
apply (erule mem_nat_in_nat)
apply (erule length_type)
apply assumption
apply simp
apply (rule Occ_consI2)
apply (simp add: length_mapnth)
apply (simp add: nth_mapnth)
apply (rule Occ_Graft1I2)
apply (rule Occ_ShiftI)
apply assumption
apply (simp add: length_mapnth nth_mapnth)
apply (rename_tac b n U)
apply (case_tac "a = b")
apply simp_all
apply (safe elim!: Occ_Graft1E Occ_ShiftE)
apply (frule nth_type2)
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
apply (drule PowD)
apply (drule subsetD)
apply assumption+
apply (rule Occ_Graft1I1)
apply (rule Occ_consI2)
apply assumption+
apply (rule notI)
apply (erule notE)
apply (erule initseg_ConsE)
apply simp
apply simp
apply (rule Occ_Graft1I2)
apply (simp add: Occ_Shift_Cons)
apply (rule Occ_shiftI)
apply (erule Occ_ShiftI)
apply (rule Occ_Graft1I1)
apply (rule Occ_consI2)
apply assumption+
apply (rule notI)
apply (erule initseg_ConsE)
apply simp_all
done

(** Occ_Graft **)
lemma Occ_GraftI1:
  "[| <l, T>: X; ~(EX m: W. initseg(nat, m, l)) |]
      ==> <l, T>: Occ_Graft(X, W, Y)"
apply (unfold Occ_Graft_def)
apply blast
done

lemma Occ_GraftI2:
  "[| m: W; <l, T>: Occ_Shift(m, Y) |]
           ==> <l, T>: Occ_Graft(X, W, Y)"
apply (unfold Occ_Graft_def)
apply blast
done

lemma Occ_GraftE:
  assumes major: "x: Occ_Graft(X, W, Y)"
  and prem: "X <= A * B"
  and prem1:
     "!! l T. [| x = <l, T>; <l, T>: X; l: A; T: B;
                ~(EX m: W. initseg(nat, m, l)) |] ==> R"
  and prem2:
     "!! m. [| m: W; x: Occ_Shift(m, Y) |] ==> R"
  shows "R"
apply (rule major [unfolded Occ_Graft_def, THEN UnE])
apply (erule_tac [2] UN_E)
apply (rule_tac [2] prem2)
apply (erule DiffE)
apply (frule prem [THEN subsetD])
apply (erule SigmaE)
apply (rule prem1)
prefer 2 apply hypsubst
apply (rule_tac [5] notI)
apply (erule_tac [5] notE)
apply (erule_tac [5] bexE)
apply (assumption | rule UN_I CollectI exI conjI)+
done

lemma Occ_Graft_domain:
  assumes domX: "X <= list(A) * B"
  and domY: "Y <= list(A) * B"
  and domW: "W <= domain(X)"
  shows "Occ_Graft(X, W, Y) <= list(A) * B"
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule domX)
apply blast
apply (rule domY [THEN Occ_Shift_domain, THEN subsetD])
apply (drule domW [THEN subsetD])
apply (erule domainE)
apply (drule domX [THEN subsetD])
apply (erule SigmaD1)
apply assumption
done

lemma Occ_Graft_0:
  "Occ_Graft(X, 0, Y) = X"
apply (unfold Occ_Graft_def)
apply simp
done

lemma Occ_Graft_cons:
  assumes prem: "Incomparable(cons(a, W))"
  and domW: "cons(a, W) <= domain(X)"
  and domX: "X <= list(nat) * Tag"
  and domY: "Y <= list(nat) * Tag"
  shows "Occ_Graft(X, cons(a, W), Y) =
               Occ_Graft1(Occ_Graft(X, W - {a}, Y), a, Y)"
apply (rule equalityI)
apply (rule_tac [2] subsetI)
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule domX)
apply (erule_tac [2] Occ_ShiftE)
apply (erule_tac [3] Occ_Graft1E)
apply (rule_tac [3] Occ_Graft_domain)
apply (rule_tac [5] domW [THEN [2] subset_trans])
prefer 3 apply (rule domX)
prefer 3 apply (rule domY)
prefer 3 apply blast
apply (erule_tac [3] Occ_GraftE)
apply (rule_tac [3] domX)
apply (erule_tac [5] Occ_ShiftE)
apply (erule_tac [4] Occ_ShiftE2)
prefer 5
apply hypsubst
apply (rule Occ_GraftI2)
prefer 2 apply (rule Occ_ShiftI)
apply assumption
apply (rule consI1)
prefer 4
apply hypsubst
apply (rule Occ_GraftI2)
prefer 2 apply (rule Occ_ShiftI)
apply assumption
apply blast
prefer 3
apply hypsubst
apply (rule Occ_GraftI1)
apply simp
apply blast
apply hypsubst
apply (rule Occ_Graft1I1)
apply (rule Occ_GraftI1)
apply assumption
apply blast
apply blast

apply (case_tac "m = a")
apply hypsubst
apply (rule Occ_Graft1I2)
apply (erule Occ_ShiftI)
apply hypsubst
apply (rule Occ_Graft1I1)
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply blast

apply assumption
apply (rule notI)
apply (erule initseg_right_appE)
apply (drule domW [THEN subsetD])
apply (erule domainE)
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (drule_tac [2] prem [THEN IncomparableD])
apply (drule_tac [1] prem [THEN IncomparableD])
defer 3
apply (assumption | rule consI1)+
apply blast+
done

lemma Occ_Graft_cons2:
  assumes prem: "Incomparable(cons(a, W))"
  and domW: "cons(a, W) <= domain(X)"
  and domX: "X <= list(nat) * Tag"
  and domY: "Y <= list(nat) * Tag"
  shows "Occ_Graft(X, cons(a, W), Y) =
               Occ_Graft(Occ_Graft1(X, a, Y), W - {a}, Y)"
apply (rule equalityI)
apply (rule_tac [2] subsetI)
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule domX)
apply (erule_tac [2] Occ_ShiftE)
apply (erule_tac [3] Occ_GraftE)
apply (rule_tac [3] Occ_Graft1_domain)
apply (insert consI1 [THEN domW [THEN subsetD]])
apply (erule_tac [5] domainE)
apply (erule_tac [5] domX [THEN subsetD, THEN SigmaD1])
apply (rule_tac [3] domX domY)+
apply (erule_tac [3] Occ_Graft1E)
apply (rule_tac [3] domX)
apply (erule_tac [5] Occ_ShiftE)
apply (erule_tac [4]  Occ_ShiftE2)
apply (simp_all del: cons_iff)
apply (rule_tac [5] Occ_GraftI2)
apply (rule_tac [4] Occ_GraftI2)
apply (rule_tac [7] Occ_ShiftI)
apply (rule_tac [5] Occ_ShiftI)
prefer 7 apply assumption
prefer 6 apply (erule conjE, erule consI2)
prefer 5 apply assumption
prefer 4 apply (rule consI1)
apply (erule conjE)
apply (rule Occ_GraftI1)
apply (rule Occ_Graft1I1)
apply assumption+
apply blast
apply (case_tac "m = a")
apply hypsubst
apply (rule Occ_GraftI1)
apply (rule Occ_Graft1I2)
apply (erule Occ_ShiftI)
apply (rule notI)
apply clarify
apply (erule initseg_right_appE)
apply (rule consI1 [THEN domW [THEN subsetD], THEN domainE])
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (rule prem [THEN IncomparableD])
apply (assumption | (erule consI2) | (rule consI1))+
apply (rule prem [THEN IncomparableD, THEN sym])
apply (assumption | (erule consI2) | (rule consI1))+
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply blast
apply assumption
apply (rule Occ_GraftI1)
apply assumption
apply blast
done

lemma Occ_Graft_Nil:
  "[| X <= list(nat) * Tag; Y <= A * B |] ==>
      Occ_Graft(X, {[]}, Y) = Y"
apply (unfold Occ_Graft_def)
apply (rule equalityI)
apply safe
apply (erule notE)
apply (rule singletonI [THEN UN_I])
apply (blast intro: initseg_NilI)
apply (simp add: Occ_Shift_Nil)
apply (erule notE)
apply (rule singletonI [THEN UN_I])
apply (simp add: Occ_Shift_Nil)
apply (erule notE)
apply (rule singletonI [THEN UN_I])
apply (simp add: Occ_Shift_Nil)
done

lemma Incomparable_Nil_lemma:
  assumes major: "Incomparable(W)"
  and prem: "[]: W"
  and domW: "W <= list(nat)"
  shows "W = {[]}"
apply (insert prem)
apply (rule equalityI)
prefer 2 apply blast
apply (rule subsetI)
apply (rule_tac P="%x. x: {[]}" in
     major [THEN prem [THEN [3] IncomparableD], THEN subst])
apply (drule_tac c="x" in domW [THEN subsetD])
apply (assumption | rule initseg_NilI singletonI)+
done

lemma Occ_Graft_Occ_cons:
  assumes major: "W ~= {[]}"
  and prem: "Incomparable(W)"
  and domW: "W <= domain(Occ_cons(T, l))"
  and t_tag: "T: Tag"
  and l_list: "l: list(Pow(list(nat)*Tag))"
  and domY: "Y <= list(nat) * Tag"
  shows "Occ_Graft(Occ_cons(T, l), W, Y) =
          Occ_cons(T, mapnth(%z r. Occ_Graft(r, lists_subtree(z, W), Y), l))"
apply (insert t_tag l_list)
apply (subgoal_tac "W <= list(nat)")
prefer 2
apply (insert domW Occ_cons_type [OF t_tag l_list])
apply blast
apply (rule equalityI)
apply (rule_tac [2] subsetI)
apply (rule subsetI)
apply (erule Occ_GraftE)
apply (rule Occ_cons_type [OF t_tag l_list])
apply (erule_tac [3] Occ_consE)
apply (erule_tac [2] Occ_ShiftE)
apply hypsubst
apply (erule Occ_consE)
apply safe
apply (frule_tac [3] domW [THEN subsetD])
apply (safe elim!: Occ_consE)
apply (erule_tac [3]  prem [THEN Incomparable_Nil_lemma,
                       THEN major [THEN notE]])
prefer 3 apply assumption
prefer 3 apply simp
apply (rule Occ_consI2)
apply (simp add: nth_mapnth length_mapnth)
prefer 2 apply (rule Occ_consI1)
prefer 2 apply (rule Occ_consI2)
apply (simp_all add: nth_mapnth length_mapnth)
apply (rule Occ_GraftI1)
apply assumption
apply (rule notI)
apply (elim conjE bexE lists_subtreeE)
apply (drule bspec, assumption)
apply (erule notE)
apply (erule initseg_ConsI, assumption)
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply (erule lists_subtreeI)
apply assumption
apply (rule Occ_GraftI1)
apply (rule Occ_consI1)
apply (rule notI)
apply (erule bexE)
apply (erule initseg_NilE)
apply hypsubst
apply (erule prem [THEN Incomparable_Nil_lemma,
                   THEN major [THEN notE]])
apply assumption
apply (erule Occ_GraftE)
apply (rule nth_type2 [THEN PowD], assumption)
apply (erule nat_ltI)
apply (erule length_type)
apply (rule Occ_GraftI1)
apply (erule Occ_consI2)
apply simp
apply (rule notI)
apply (erule bexE)
apply (erule initseg_ConsE)
apply hypsubst
apply (erule prem [THEN Incomparable_Nil_lemma,
                   THEN major [THEN notE]])
apply assumption
apply simp
apply (blast intro: lists_subtreeI)
apply (safe elim!: Occ_ShiftE lists_subtreeE)
apply (simp del: app_Cons add: app_Cons [THEN sym])
apply (rule Occ_GraftI2)
apply (rule_tac [2] Occ_ShiftI)
apply assumption+
done

(** Occ_Graft1 in Occ_range **)
lemma Occ_Graft1_preserves_functionality:
  assumes funcX: "functional(X)"
  and funcY: "functional(Y)"
  and domX: "X <= list(nat)*B"
  and l_list: "l: list(nat)"
  shows "functional(Occ_Graft1(X, l, Y))"
apply (rule functionalI)
apply (erule Occ_Graft1E)
apply (rule domX)
apply (erule_tac [2] Occ_Graft1E)
apply (rule_tac [2] domX)
apply (erule_tac Occ_Graft1E)
apply (rule_tac domX)
apply (safe elim!: Occ_ShiftE)
prefer 4
apply (drule l_list [THEN app_right_inj_iff, THEN iffD1])
apply hypsubst
apply (erule funcY [THEN functionalD])
apply assumption
apply (erule funcX [THEN functionalD])
apply assumption
apply (erule notE)
apply (rule l_list [THEN initseg_appI1])
apply (erule l_list [THEN [2] app_typeD])
apply (erule notE)
apply (rule l_list [THEN initseg_appI1])
apply (erule l_list [THEN [2] app_typeD])
done

lemma Occ_Graft1_preserves_DenseTree:
  assumes hierX: "DenseTree(X)"
  and hierY: "DenseTree(Y)"
  and domX: "X <= list(nat)*B"
  and l_list: "l: domain(X)"
  shows "DenseTree(Occ_Graft1(X, l, Y))"
apply (rule DenseTreeI)
apply (safe elim!: Occ_Graft1E Occ_ShiftE)
apply (erule domX [THEN subsetD])
apply (rule hierX [THEN DenseTreeE])
apply assumption+
apply (rule exI)
apply (erule Occ_Graft1I1)
apply (rule notI)
apply (erule notE)
apply (erule initseg_trans, assumption)
apply (rule l_list [THEN domainE])
apply (erule initseg_right_appE)
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (rule hierX [THEN DenseTreeE])
apply assumption+
apply (case_tac "m = l")
prefer 2
apply (rule exI)
apply (rule Occ_Graft1I1)
apply assumption
apply (rule notI)
apply (drule initseg_antisym, assumption)
apply (erule notE, assumption)
apply hypsubst
apply (erule hierY [THEN DenseTreeE])
apply (erule initseg_NilI)
apply (rename_tac C)
apply (rule_tac x="C" in exI)
apply (rule_tac P="%x. <x, C>: Occ_Graft1(X, l, Y)" in
         app_right_Nil [THEN subst])
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])
apply hypsubst
apply (erule hierY [THEN DenseTreeE])
apply (erule initseg_appI1)
apply assumption
apply (rule exI)
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])
done

lemma Occ_Graft1_preserves_CorrectArity:
  assumes corrX: "CorrectArity(X, T, n)"
  and corrY: "CorrectArity(Y, T, n)"
  and domX: "X <= list(nat)*B"
  and l_list: "l: domain(X)"
  and domY: "Y <= list(nat)*B"
  and hierY: "DenseTree(Y)"
  and not_emptyY: "Y ~= 0"
  shows "CorrectArity(Occ_Graft1(X, l, Y), T, n)"
apply (subgoal_tac "l: list(nat)")
prefer 2
apply (rule l_list [THEN domainE])
apply (erule domX [THEN subsetD, THEN SigmaD1])
apply (rule CorrectArityI)
apply (erule_tac [2] Occ_Graft1E)
apply (rule_tac [2] domX)
apply (erule Occ_Graft1E)
apply (rule domX)
apply (safe elim!: Occ_ShiftE)
apply (rename_tac l' U)
apply (case_tac "l' @ [m] = l")

prefer 5
apply (frule corrY [THEN CorrectArityD2])
apply assumption
apply (erule notE)
apply (erule Occ_Graft1E)
apply (rule domX)
apply clarify
apply (erule notE)
apply (simp add: app_assoc)
apply (rule initseg_appI1)
apply assumption
apply (erule app_typeD)
apply assumption
apply (erule Occ_ShiftE2)
apply (simp only: app_assoc app_right_inj_iff)
apply (erule exI)

prefer 4
apply (erule Occ_Graft1E)
apply (rule domX)
prefer 2
apply (erule_tac [1] Occ_ShiftE2)
apply (rule_tac [1] app_appE_lemma [THEN bspec, THEN mp, THEN disjE])
prefer 3 apply assumption
apply assumption+
apply (rule l_list [THEN domainE])
apply (erule exE)
apply hypsubst
apply (simp only: app_assoc app_right_inj_iff)
apply (drule app_typeD)
apply assumption
apply (erule_tac a="z" in list.cases)
apply (erule notE)
apply simp
apply (erule initseg_refl)
apply hypsubst
apply simp
apply clarify
apply (erule corrX [THEN CorrectArityD2, THEN notE])
apply assumption
apply (erule exI)
apply (erule exE)
apply hypsubst
apply (erule notE)
apply (drule app_typeD)
apply assumption
apply (erule initseg_appI1)
apply assumption

apply clarify
apply (erule corrX [THEN CorrectArityD2, THEN notE])
apply assumption
apply (erule exI)

prefer 3
apply (erule corrY [THEN CorrectArityD1, THEN exE])
apply assumption
apply (rule exI)
apply (simp add: app_assoc)
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])

prefer 1
apply (rule not_emptyY [THEN not_emptyE])
apply (frule domY [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (erule hierY [THEN DenseTreeE])
apply (erule initseg_NilI)
apply (rename_tac C)
apply (rule_tac x="C" in exI)
apply (erule_tac P="%x. <x, C>: Occ_Graft1(X, l' @ [m], Y)"
        in app_right_Nil [THEN subst])
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])

apply (rule corrX [THEN CorrectArityD1, THEN exE])
apply assumption+
apply (rule exI)
apply (erule Occ_Graft1I1)
apply (rule notI)
apply (erule notE)
apply (erule initseg_right_appE)
apply assumption+
apply (rename_tac m' y)
apply (erule_tac a="m'" in list.cases)
apply simp
apply simp
done

lemma Occ_shift_in_fin_bnd_set:
  assumes prem1: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem2: "b: nat"
  shows "Occ_shift(b, X) : fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (rule Occ_fbs_op_bnd_mono [THEN fin_bnd_set_succI])
apply (rule_tac [2] prem1)
apply (insert prem1 [THEN fin_bnd_set_domain [THEN subsetD], THEN PowD])
apply (unfold Occ_fbs_op_def Occ_fbs_dom_def list_dom_def list_op_def)
apply (rule subsetI)
apply (erule Occ_shiftE)
apply hypsubst
apply (drule subsetD, assumption)
apply (erule SigmaE2)
apply (rule SigmaI)
prefer 2 apply assumption
apply (rule CollectI)
prefer 2 apply (rule disjI2)
apply (intro exI conjI)
apply (rule refl)
apply (rule prem2)
apply (erule domainI)
apply (unfold list.con_defs)
apply (erule prem2 [THEN A_subset_univ [THEN subsetD],
                    THEN Pair_in_univ, THEN Inr_in_univ])
done

lemma Occ_Shift_in_fin_bnd_set:
  assumes prem1: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem2: "l: list(nat)"
  shows "Occ_Shift(l, X) : fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (unfold Occ_fbs_dom_def)
apply (rule prem2 [THEN list.induct])
apply (rule prem1 [unfolded Occ_fbs_dom_def,
                   THEN fin_bnd_set_domain [THEN subsetD],
                   THEN PowD, THEN Occ_Shift_Nil, THEN ssubst])
apply (rule prem1 [unfolded Occ_fbs_dom_def])
apply (simp add: Occ_Shift_Cons)
apply (fold Occ_fbs_dom_def)
apply (erule Occ_shift_in_fin_bnd_set)
apply assumption
done

lemma Occ_Graft1_in_fin_bnd_set:
  assumes prem1: "X: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and prem2: "Y: fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
  and l_list: "l: list(nat)"
  shows "Occ_Graft1(X, l, Y):
                 fin_bnd_set(Occ_fbs_dom(Tag), Occ_fbs_op(Tag))"
apply (unfold Occ_Graft1_def)
apply (rule Occ_fbs_op_bnd_mono [THEN fin_bnd_set_UnI])
apply (rule fin_bnd_set_subsetI
        [OF Occ_fbs_op_bnd_mono Diff_subset prem1])
apply (rule Occ_Shift_in_fin_bnd_set [OF prem2 l_list])
done

lemma Occ_Graft1_not_empty:
  assumes domY: "Y <= list(nat) * B"
  and not_emptyY: "Y ~= 0"
  shows "Occ_Graft1(X, l, Y) ~= 0"
apply (rule not_emptyY [THEN not_emptyE])
apply (frule domY [THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply (rule not_emptyI)
apply (erule Occ_ShiftI [THEN Occ_Graft1I2])
done

lemma Occ_Graft1_in_Occ_range:
  assumes domX: "X: Occ_range(Tag, Arity)"
  and domY: "Y: Occ_range(Tag, Arity)"
  and l_list: "l: domain(X)"
  shows "Occ_Graft1(X, l, Y): Occ_range(Tag, Arity)"
apply (subgoal_tac "X <= list(nat) * Tag"
                   "Y <= list(nat) * Tag" "l: list(nat)")
prefer 2
apply (rule l_list [THEN domainE])
apply (erule subsetD [THEN SigmaD1])
apply assumption
prefer 2
apply (rule domY [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)
prefer 2
apply (rule domX [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)

apply (rule domX [THEN Occ_rangeE])
apply (rule domY [THEN Occ_rangeE])
apply (insert l_list)
apply (rule Occ_rangeI)
apply (rule_tac [5] ballI)
apply (drule_tac [5] bspec)
apply (drule_tac [6] bspec)
apply (assumption
       | rule Occ_Graft1_in_fin_bnd_set
              Occ_Graft1_not_empty
              Occ_Graft1_preserves_functionality
              Occ_Graft1_preserves_DenseTree
              Occ_Graft1_preserves_CorrectArity)+
done

lemma Occ_Graft_in_Occ_range:
  assumes finW: "W: Fin(list(nat))"
  and prem: "Incomparable(W)"
  and domW: "W <= domain(X)"
  and domX: "X: Occ_range(Tag, Arity)"
  and domY: "Y: Occ_range(Tag, Arity)"
  shows "Occ_Graft(X, W, Y): Occ_range(Tag, Arity)"
apply (rule domW [THEN rev_mp])
apply (rule prem [THEN rev_mp])
apply (rule finW [THEN Fin_induct])
apply (intro impI)
apply (rule Occ_Graft_0 [THEN ssubst])
apply (rule domX)

apply (intro impI)
apply (rule Occ_Graft_cons [THEN ssubst])
prefer 5
apply (rule Occ_Graft1_in_Occ_range)
apply (subgoal_tac "x ~: y ==> y - {x} = y")
prefer 2 apply blast
apply simp
apply (erule mp)
apply (erule Incomparable_subset)
apply blast
apply (rule domY)

apply (erule cons_subsetE)
apply (erule domainE)
apply (rule domainI)
apply (rule Occ_GraftI1)
apply assumption
apply (rule notI)
apply (erule bexE)
apply (erule DiffE)
apply (drule IncomparableD)
apply assumption
apply (erule consI2)
apply (rule consI1)
apply hypsubst
apply (erule singletonI [THEN [2] notE])

apply assumption+
apply (rule domX [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)
apply (rule domY [THEN Occ_rangeE])
apply (erule Occ_fbs_op_lfp_lowerbound)
done

lemma Occ_Graft_in_Occ_range2:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and prem: "Incomparable(W)"
  and domW: "W <= domain(X)"
  and domX: "X: Occ_range(Tag, Arity)"
  and domY: "Y: Occ_range(Tag, Arity)"
  shows "Occ_Graft(X, W, Y): Occ_range(Tag, Arity)"
apply (rule Occ_Graft_in_Occ_range)
apply (rule domW [THEN Fin_subset])
apply (rule Fin_domainI)
apply (rule Occ_range_convert_lemma [OF hcons domX])
apply (erule hind [THEN Occ_ind_cond_Occ_FinI])
apply (assumption | rule prem domW domX domY)+
done

(** subst **)
lemma def_graft_type:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  shows
   "[|
        M: Terms; N: Terms;
        Incomparable(W); W <= domain(Occ(M))
    |] ==> graft(M, W, N): Terms"
apply (unfold hsubst)
apply (rule def_Occinv_type [OF hcons hind hinv])
apply (rule Occ_Graft_in_Occ_range2 [OF hcons hind])
apply (assumption | rule hind [THEN Occ_ind_cond_Occ_in_Occ_range])+
done

lemma def_graft_0:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  and prem: "M: Terms"
  shows "graft(M, 0, N) = M"
apply (unfold hsubst)
apply (insert prem)
apply (simp only: def_Occinv_Occ [OF hcons hind hinv] Occ_Graft_0)
done

lemma def_graft_Nil:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  shows
   "[| M: Terms; N: Terms
    |] ==> graft(M, {[]}, N) = N"
apply (unfold hsubst)
apply (subgoal_tac "Occ(M) <= list(nat) * Tag"
                   "Occ(N) <= list(nat) * Tag")
apply (simp only: def_Occinv_Occ [OF hcons hind hinv] Occ_Graft_Nil)
apply (assumption | rule hind [THEN Occ_ind_cond_Occ_domain])+
done

lemma def_graft:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsubst: "!!x W y. graft(x, W, y) == Occinv(Occ_Graft(Occ(x), W, Occ(y)))"
  shows
   "[|
        Term_cons(T, l): Terms;
        T: Tag; l: list(Terms); Arity(T) = length(l); y: Terms;
        W ~= {[]}; Incomparable(W);
        W <= domain(Occ(Term_cons(T, l)))
    |] ==> graft(Term_cons(T, l), W, y) =
         Term_cons(T, mapnth(%z r. graft(r, lists_subtree(z, W), y), l))"
apply (unfold hsubst)
apply (subgoal_tac "map(Occ, l): list(Pow(list(nat) * Tag))"
                   "Arity(T) = length(map(Occ, l))"
                   "Occ(y) <= list(nat) * Tag"
                   "Occ_Graft(Occ(Term_cons(T, l)), W, Occ(y))
                       : Occ_range(Tag, Arity)")
apply (simp add: Occ_Term_cons [OF hind hinj]
           Occ_Graft_Occ_cons mapnth_map)
apply (rule def_Occinv2 [OF hcons hind hinv, THEN trans])
prefer 5 apply (simp add: map_mapnth)
prefer 4 apply (simp add: length_mapnth)
prefer 6 apply simp
prefer 3
apply (rule nth_convert_list_type)
apply (erule mapnth_type2)
apply (simp add: nth_mapnth length_mapnth)
apply (rule ballI)
apply (rule Occ_Graft_domain)
apply (rule hind [THEN Occ_ind_cond_Occ_domain])
apply simp
apply assumption

prefer 5 apply (erule hind [THEN Occ_ind_cond_Occ_domain])
prefer 3 apply assumption
prefer 4 apply (erule map_type)
apply (erule hind [THEN Occ_ind_cond_Occ_domain, THEN PowI])
prefer 3 apply (rule Occ_Graft_in_Occ_range2 [OF hcons hind])
apply assumption+
apply (erule hind [THEN Occ_ind_cond_Occ_in_Occ_range])+
prefer 2 apply simp

apply (rule_tac P="%x. lists_subtree(z, W) <= x" in subst)
apply (erule_tac [2] lists_subtree_mono)
apply (simp add: lists_subtree_domain_eq Occ_subtree_Occ_cons nth_map)
done

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005 (modified)    |
            |                 August 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |               December 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_traces
imports  CSP_T_semantics
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*********************************************************
                        DomT
 *********************************************************)

(*--------------------------------*
 |             STOP               |
 *--------------------------------*)

lemma in_traces_STOP: "(t :t traces(STOP) M) = (t = <>)"
by (simp add: traces_iff)

(*--------------------------------*
 |             SKIP               |
 *--------------------------------*)

lemma in_traces_SKIP: "(t :t traces(SKIP) M) = (t = <> | t = <Tick>)"
by (simp add: traces_iff)

(*--------------------------------*
 |              DIV               |
 *--------------------------------*)

(*** DIV ***)

lemma in_traces_DIV: "(t :t traces(DIV) M) = (t = <>)"
by (simp add: traces_iff)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

(*** Act_prefix_domT ***)

lemma Act_prefix_domT:
  "{t. t = <> | (EX s. t = <Ev a> ^^^ s & s :t T)} : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI, simp)

apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (elim conjE exE)

apply (erule disjE, simp)    (* <> *)

apply (elim conjE exE, simp)
apply (erule disjE, simp)    (* <> *)

apply (elim conjE exE, simp)
apply (rule memT_prefix_closed)
by (simp_all)

(*** Act_prefix ***)

lemma in_traces_Act_prefix:
  "t :t traces(a -> P) M = (t = <> | (EX s. t = <Ev a> ^^^ s & s :t traces(P) M))"
apply (simp add: traces_iff)
by (simp add: CollectT_open_memT Act_prefix_domT)

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

(*** Ext_pre_choice_domT ***)

lemma Ext_pre_choice_domT:
  "{t. t = <> |
       (EX a s. t = <Ev a> ^^^ s & s :t Tf a & a : X) } : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI, simp)

apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (elim conjE exE)

apply (erule disjE, simp)    (* <> *)

apply (elim conjE exE, simp)
apply (erule disjE, simp)    (* <> *)

apply (elim conjE exE, simp)
apply (rule memT_prefix_closed)
by (simp_all)

(*** Ext_pre_choice ***)

lemma in_traces_Ext_pre_choice:
  "(t :t traces(? :X -> Pf) M) =
   (t = <> | (EX a s. t = <Ev a> ^^^ s & s :t traces(Pf a) M & a : X))"
apply (simp add: traces_iff)
by (simp add: CollectT_open_memT Ext_pre_choice_domT)

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

(*** Ext_choice_memT ***)

lemma in_traces_Ext_choice:
  "(t :t traces(P [+] Q) M) = (t :t traces(P) M | t :t traces(Q) M)"
by (simp add: traces_iff)

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

(*** Int_choice_memT ***)

lemma in_traces_Int_choice:
  "(t :t traces(P |~| Q) M) = (t :t traces(P) M| t :t traces(Q) M)"
by (simp add: traces_iff)

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

(*** Rep_int_choice_domT ***)

lemma Rep_int_choice_domT:
  "{t. t = <> | (EX a:X. t :t Tf a) } : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI, simp)

apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (elim conjE exE)

apply (erule disjE, simp)    (* <> *)

apply (elim conjE bexE)
apply (rule disjI2)
apply (rule_tac x="a" in bexI)
apply (rule memT_prefix_closed)
by (simp_all)

(*** Union_proc ***)

lemma in_traces_Union_proc:
   "(t :t {t. t = <> | (EX a:X. t :t Tf a)}t)
  = (t = <> | (EX a:X. t :t Tf a))"
apply (insert Rep_int_choice_domT[of X Tf])
apply (simp add: CollectT_open_memT)
done

lemma in_traces_UNIV_Union_proc:
   "(t :t {t. EX a. t :t Tf a}t)
  = (EX a. t :t Tf a)"
apply (insert in_traces_Union_proc[of t UNIV Tf])
apply (simp)
apply (subgoal_tac "{t. t = <> | (EX a. t :t Tf a)}
                  = {t. EX a. t :t Tf a}")
by (auto)

(*** Rep_int_choice ***)

lemma in_traces_Rep_int_choice_sum:
   "(t :t traces(!! :C .. Pf) M) =
    (t = <> | (EX c: sumset C. t :t traces(Pf c) M))"
apply (simp add: traces_iff)
apply (simp add: in_traces_Union_proc)
done

lemma in_traces_Rep_int_choice_nat:
   "(t :t traces(!nat :N .. Pf) M) = (t = <> | (EX n:N. t :t traces(Pf n) M))"
by (simp add: Rep_int_choice_ss_def in_traces_Rep_int_choice_sum)

lemma in_traces_Rep_int_choice_set:
   "(t :t traces(!set :Xs .. Pf) M) = (t = <> | (EX X:Xs. t :t traces(Pf X) M))"
by (simp add: Rep_int_choice_ss_def in_traces_Rep_int_choice_sum)

lemma in_traces_Rep_int_choice_com:
   "(t :t traces(! :X .. Pf) M) = (t = <> | (EX a:X. t :t traces(Pf a) M))"
apply (simp add: traces_iff)
apply (simp add: in_traces_Union_proc)
done

lemma in_traces_Rep_int_choice_f:
   "inj f ==> (t :t traces(!<f> :X .. Pf) M) = (t = <> | (EX a:X. t :t traces(Pf a) M))"
apply (simp add: traces_iff)
apply (simp add: in_traces_Union_proc)
done

lemmas in_traces_Rep_int_choice = in_traces_Rep_int_choice_sum
                                  in_traces_Rep_int_choice_set
                                  in_traces_Rep_int_choice_nat
                                  in_traces_Rep_int_choice_com
                                  in_traces_Rep_int_choice_f

(*--------------------------------*
 |               IF               |
 *--------------------------------*)

(*** IF ***)

lemma in_traces_IF:
  "(t :t traces(IF b THEN P ELSE Q) M)
 = (if b then t :t traces(P) M else t :t traces(Q) M)"
by (simp add: traces_iff)

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

(*** Parallel_domT ***)

lemma Parallel_domT :
  "{u. EX s t. u : s |[X]|tr t & s :t T & t :t S} : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI, simp)

(* prefix closed *)
apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (elim conjE exE)
apply (erule par_tr_prefixE, simp)
apply (rule_tac x="s'" in exI)
apply (rule_tac x="t'" in exI)
apply (simp)

apply (rule conjI)
by (rule memT_prefix_closed, simp_all)+

(*** Parallel ***)

lemma in_traces_Parallel:
  "(u :t traces(P |[X]| Q) M) =
   (EX s t. u : s |[X]|tr t & s :t traces(P) M & t :t traces(Q) M)"
apply (simp add: traces_iff)
by (simp add: CollectT_open_memT Parallel_domT)

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

(*** Hiding_domT ***)

lemma Hiding_domT :
  "{t. EX s. t = s --tr X & s :t T } : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI, simp)

(* prefix closed *)
apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp add: hide_tr_prefix)
apply (elim conjE exE)
apply (rule_tac x="ta" in exI)
apply (simp)
apply (rule memT_prefix_closed)
by (simp_all)

(*** Hiding ***)

lemma in_traces_Hiding:
  "(t :t traces(P -- X) M) =
   (EX s. t = s --tr X & s :t traces(P) M)"
apply (simp add: traces_iff)
by (simp add: CollectT_open_memT Hiding_domT)

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

(*** Renaming_domT ***)

lemma Renaming_domT : "{t. EX s. s [[r]]* t & s :t T } : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI, simp)

(* prefix closed *)
apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (elim conjE exE)
apply (erule ren_tr_prefixE, simp)
apply (rule_tac x="ta" in exI)
apply (simp)
apply (rule memT_prefix_closed)
by (simp_all)

(*** Renaming ***)

lemma in_traces_Renaming:
  "(t :t traces(P [[r]]) M) = (EX s. s [[r]]* t & s :t traces(P) M)"
apply (simp add: traces_iff)
by (simp add: CollectT_open_memT Renaming_domT)

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

(*** Seq_compo_domT ***)

lemma Seq_compo_domT :
  "{u. (EX s. u = rmTick s & s :t S ) |
       (EX s t. u = s ^^^ t & s ^^^ <Tick> :t S & t :t T & noTick s ) } : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (rule_tac x="<>" in exI)
apply (rule disjI1)
apply (rule_tac x="<>" in exI, simp)

(* prefix closed *)
apply (simp add: prefix_closed_def)

 apply (intro allI impI)
 apply (elim conjE exE)
 apply (erule disjE)

  (* case 1 *)
  apply (elim conjE exE)
  apply (rule disjI1)
  apply (simp add: rmTick_prefix)
  apply (elim conjE exE)
  apply (rule_tac x="u" in exI, simp)
  apply (rule memT_prefix_closed, simp_all)

  (* case 2 *)
  apply (elim conjE exE)
  apply (simp add: prefix_def)
  apply (elim exE conjE)
  apply (simp add: appt_decompo)

   apply (erule disjE)
   (* long case *)
   apply (elim conjE exE)
   apply (rule disjI2)
   apply (rule_tac x="sa" in exI, simp)
   apply (rule_tac x="ua" in exI, simp)
   apply (subgoal_tac "prefix ua (ua ^^^ u)")
    apply (rule memT_prefix_closed, simp_all)
   apply (simp)

   (* short case *)
   apply (elim conjE exE)
   apply (rule disjI1)
   apply (rule_tac x="s" in exI)
   apply (case_tac "~ noTick s", simp)
   apply (simp)
   apply (subgoal_tac "prefix s (s ^^^ ua ^^^ <Tick>)")
    apply (rule memT_prefix_closed, simp_all)
   apply (simp)
done

(*** Seq_compo ***)

lemma in_traces_Seq_compo:
  "(u :t traces(P ;; Q) M) =
   ((EX s. u = rmTick s & s :t traces(P) M) |
    (EX s t. u = s ^^^ t & s ^^^ <Tick> :t traces(P) M & t :t traces(Q) M & noTick s))"
apply (simp add: traces_iff)
by (simp add: CollectT_open_memT Seq_compo_domT)

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

(*** Depth_rest ***)

lemma in_traces_Depth_rest:
  "(t :t traces(P |. n) M) = (t :t traces(P) M & (lengtht t) <= n)"
apply (simp add: traces_iff)
apply (simp add: in_rest_domT)
done

(*--------------------------------*
 |          Proc_name             |
 *--------------------------------*)

(*** Proc_name ***)

lemma in_traces_Proc_name:
  "(t :t traces($p) M) = (t :t M p)"
apply (simp add: traces_iff)
done

(*--------------------------------*
 |             alias              |
 *--------------------------------*)

lemmas traces_domT = Act_prefix_domT     Ext_pre_choice_domT
                     Rep_int_choice_domT Parallel_domT
                     Hiding_domT         Renaming_domT
                     Seq_compo_domT

lemmas in_traces = in_traces_STOP  in_traces_SKIP  in_traces_DIV
                   in_traces_Act_prefix     in_traces_Ext_pre_choice
                   in_traces_Ext_choice     in_traces_Int_choice
                   in_traces_Rep_int_choice in_traces_IF
                   in_traces_Parallel       in_traces_Hiding
                   in_traces_Renaming       in_traces_Seq_compo
                   in_traces_Union_proc     in_traces_UNIV_Union_proc
                   in_traces_Depth_rest     in_traces_Proc_name

(*--------------------------------*
 |            Timeout             |
 *--------------------------------*)

(*** Timemout ***)

lemma in_traces_Timeout1:
  "(t :t traces(P [> Q) M) = (t :t traces(P) M | t :t traces(Q) M)"
apply (simp add: traces_iff)
done

lemma in_traces_Timeout2:
  "(t :t traces(P [>def Q) M) = (t :t traces(P) M | t :t traces(Q) M)"
apply (simp add: Timeout_def traces_iff)
done

lemmas in_traces_Timeout = in_traces_Timeout1 in_traces_Timeout2

(****************** to add them again ******************)

declare disj_not1   [simp]

end


section\<open>Inductive Study of Confidentiality against Dolev-Yao\<close>

theory ConfidentialityDY imports NS_Public_Bad begin

section\<open>Existing study - fully spelled out\<close>

text\<open>In order not to leave hidden anything of the line of reasoning, we cancel some relevant lemmas that were installed previously\<close>

declare Spy_see_priEK [simp del]
        Spy_analz_priEK [simp del]
        analz_into_parts [rule del]

subsection\<open>On static secrets\<close>

lemma Spy_see_priEK:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> parts (spies evs)) = (A \<in> bad)"
apply (erule ns_public.induct, simp_all)
(*Fake: screenshot1*)
apply (cases "A:bad")
thm ccontr
(*apply (rule ccontr) apply simp*)
apply blast (*Spy knows bad agents' keys since start*)
apply clarify (*screenshot2*)
thm Fake_parts_insert [THEN subsetD]
apply (drule Fake_parts_insert [THEN subsetD], simp)(*screenshot3*)
apply (blast dest: analz_into_parts)
done

lemma Spy_analz_priEK:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> analz (spies evs)) = (A \<in> bad)"
(*apply (auto simp: Spy_see_priEK dest: analz_into_parts)*)
apply (erule ns_public.induct, simp_all)
(*Nil*)
thm analz_image_freshK_simps
apply (simp add: analz_image_freshK_simps)
(*Fake*)
(*apply spy_analz would close, alternatively:*)
apply (cases "A:bad")
apply clarify apply simp
apply blast (*Spy knows bad agents' keys since start*)
apply clarsimp
apply (drule Fake_analz_insert [THEN subsetD], simp)
apply clarsimp
done

subsection\<open>On dynamic secrets\<close>

lemma Spy_not_see_NA:
"\<lbrakk>Says A B (Crypt(pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs;
  A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
  \<Longrightarrow> Nonce NA \<notin> analz (spies evs)"
apply (erule rev_mp, erule ns_public.induct)
apply (simp_all add: Spy_analz_priEK)
(*screenshot1*)
thm conjI
apply (rule conjI)
apply clarify
apply clarify
(*screenshot2*)
apply (drule Fake_analz_insert [THEN subsetD], simp)
(*screenshot3*)
apply simp
apply (blast dest: unique_NA analz_into_parts intro: no_nonce_NS1_NS2)+
done

lemma Spy_not_see_NB:
"\<lbrakk>Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
 \<forall>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<notin> set evs;
 A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
 \<Longrightarrow> Nonce NB \<notin> analz (spies evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule ns_public.induct)
apply (simp_all add: Spy_analz_priEK)
txt\<open>apply @{term spy_analz}
   is replaced here with the following list...\<close>
apply (rule ccontr)
apply clarsimp
apply (erule disjE)
apply simp
apply simp
apply clarify
apply (drule Fake_analz_insert [THEN subsetD], simp)
apply simp
txt\<open>...of commands!\<close>
apply (simp_all add: all_conj_distrib) txt\<open>speeds up next\<close>
apply (blast dest: analz_into_parts intro: no_nonce_NS1_NS2)+
done

section\<open>Novel study\<close>

text\<open>Generalising over all initial secrets the existing treatment, which is limited to private encryption keys\<close>

definition staticSecret :: "agent \<Rightarrow> msg set" where
 [simp]: "staticSecret A \<equiv> {Key (priEK A), Key (priSK A), Key (shrK A)}"

subsection\<open>Protocol independent study\<close>

text\<open>Converse doesn't hold because something that is said or noted is not necessarily an initial secret\<close>
lemma staticSecret_parts_Spy:
"\<lbrakk>m \<in> parts (knows Spy evs); m \<in> staticSecret A\<rbrakk>  \<Longrightarrow>
 A \<in> bad \<or>
 (\<exists>C B X. Says C B X \<in> set evs \<and> m \<in> parts{X}) \<or>
 (\<exists>C Y. Notes C Y \<in> set evs \<and> C \<in> bad \<and> m \<in> parts{Y})"
apply (erule rev_mp)
apply (induct_tac "evs")
apply force
apply (induct_tac "a")
txt\<open>Says\<close>
txt\<open>@{subgoals [display,indent=1]}\<close>
apply (rule impI)
apply simp
txt\<open>@{subgoals [display,indent=1]}\<close>
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
txt\<open>@{subgoals [display,indent=1]}\<close>
apply blast
txt\<open>Gets\<close>
apply simp
txt\<open>Notes\<close>
apply (rule impI)
apply simp
apply (rename_tac agent msg)
apply (case_tac "agent\<notin>bad")
apply simp apply blast
apply simp
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
apply blast
done

lemma staticSecret_analz_Spy:
"\<lbrakk>m \<in> analz (knows Spy evs); m \<in> staticSecret A\<rbrakk>  \<Longrightarrow>
 A \<in> bad \<or>
 (\<exists>C B X. Says C B X \<in> set evs \<and> m \<in> parts{X}) \<or>
 (\<exists>C Y. Notes C Y \<in> set evs \<and> C \<in> bad \<and> m \<in> parts{Y})"
by (drule analz_into_parts [THEN staticSecret_parts_Spy])

lemma secret_parts_Spy:
"m \<in> parts (knows Spy evs)  \<Longrightarrow>
 m \<in> initState Spy \<or>
 (\<exists>C B X. Says C B X \<in> set evs \<and> m \<in> parts{X}) \<or>
 (\<exists>C Y. Notes C Y \<in> set evs \<and> C \<in> bad \<and> m \<in> parts{Y})"
apply (erule rev_mp)
apply (induct_tac "evs")
apply simp
apply (induct_tac "a")
txt\<open>Says\<close>
apply (rule impI)
apply (simp del: initState_Spy)
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
apply (simp only: Un_iff)
apply blast
txt\<open>Gets\<close>
apply simp
txt\<open>Notes\<close>
apply (rule impI)
apply (simp del: initState_Spy)
apply (rename_tac agent msg)
apply (case_tac "agent\<notin>bad")
apply (simp del: initState_Spy)
apply blast
apply (simp del: initState_Spy)
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
apply blast
done

lemma secret_parts_Spy_converse:
" m \<in> initState Spy \<or>
 (\<exists>C B X. Says C B X \<in> set evs \<and> m \<in> parts{X}) \<or>
 (\<exists>C Y. Notes C Y \<in> set evs \<and> C \<in> bad \<and> m \<in> parts{Y})
 \<Longrightarrow> m \<in> parts(knows Spy evs)"
apply (erule disjE)
apply force
apply (erule disjE)
apply (blast dest: Says_imp_knows_Spy [THEN parts.Inj] parts_trans)
 apply (blast dest: Notes_imp_knows_Spy [THEN parts.Inj] parts_trans)
done

lemma secret_analz_Spy:
"m \<in> analz (knows Spy evs)  \<Longrightarrow>
 m \<in> initState Spy \<or>
 (\<exists>C B X. Says C B X \<in> set evs \<and> m \<in> parts{X}) \<or>
 (\<exists>C Y. Notes C Y \<in> set evs \<and> C \<in> bad \<and> m \<in> parts{Y})"
by (blast dest: analz_into_parts secret_parts_Spy)

subsection\<open>Protocol-dependent study\<close>

text\<open>Proving generalised version of @{thm Spy_see_priEK} using same strategy, the "direct" strategy\<close>

lemma NS_Spy_see_staticSecret:
 "\<lbrakk>m \<in> staticSecret A; evs \<in> ns_public\<rbrakk> \<Longrightarrow>
   m \<in> parts(knows Spy evs) = (A \<in> bad)"
apply (erule ns_public.induct)
apply simp_all
prefer 2
apply (cases "A:bad")
apply blast (*Spy knows bad agents' keys since start*)
apply clarify
apply (drule Fake_parts_insert [THEN subsetD], simp)
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (blast dest: analz_into_parts)
apply force+
done

text\<open>Seeking a proof of @{thm NS_Spy_see_staticSecret} using an alternative, "specialisation" strategy\<close>

lemma NS_no_Notes:
 "evs \<in> ns_public \<Longrightarrow> Notes A X \<notin> set evs"
apply (erule ns_public.induct)
apply simp_all
done

lemma NS_staticSecret_parts_Spy_weak:
"\<lbrakk>m \<in> parts (knows Spy evs); m \<in> staticSecret A;
  evs \<in> ns_public\<rbrakk> \<Longrightarrow> A \<in> bad \<or>
 (\<exists>C B X. Says C B X \<in> set evs \<and> m \<in> parts{X})"
apply (blast dest: staticSecret_parts_Spy NS_no_Notes)
done

lemma NS_Says_staticSecret:
 "\<lbrakk>Says A B X \<in> set evs; m \<in> staticSecret C; m \<in> parts{X};
   evs \<in> ns_public\<rbrakk> \<Longrightarrow> A=Spy"
apply (erule rev_mp)
apply (erule ns_public.induct)
apply force+
done

text\<open>This generalises @{thm Key_synth_eq}\<close>
lemma staticSecret_synth_eq:
"m \<in> staticSecret A \<Longrightarrow> (m \<in> synth H) = (m \<in> H)"
apply force
done

lemma NS_Says_Spy_staticSecret:
 "\<lbrakk>Says Spy B X \<in> set evs; m \<in> parts{X};
   m \<in> staticSecret A; evs \<in> ns_public\<rbrakk> \<Longrightarrow> A \<in> bad"
(*
txt{*Alternative start to appreciate that it reduces to @{thm NS_Spy_see_staticSecret}*}
apply (erule rev_mp, erule ns_public.induct)
apply (simp_all del: staticSecret_def)
apply clarify
txt{*@{subgoals [display,indent=1,goals_limit=1]}*}
apply (drule Fake_parts_sing [THEN subsetD], simp)
txt{*@{subgoals [display,indent=1,goals_limit=1]}*}
apply (simp del: staticSecret_def add: staticSecret_synth_eq)
txt{*@{subgoals [display,indent=1,goals_limit=1]}*}
oops
*)
apply (drule Says_imp_knows_Spy [THEN parts.Inj])
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (drule parts_trans, simp)
apply (rotate_tac -1)
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (erule rev_mp)
apply (erule ns_public.induct)
apply simp_all
prefer 2
apply (cases "A:bad")
apply blast (*Spy knows bad agents' keys since start*)
apply clarsimp
apply (drule Fake_parts_insert [THEN subsetD], simp)
apply (blast dest: analz_into_parts)
apply force+
done

text\<open>Here's the specialised version of @{thm staticSecret_parts_Spy}\<close>
lemma NS_staticSecret_parts_Spy:
"\<lbrakk>m \<in> parts (knows Spy evs); m \<in> staticSecret A;
  evs \<in> ns_public\<rbrakk> \<Longrightarrow> A \<in> bad"
apply (drule staticSecret_parts_Spy)
apply assumption
txt\<open>@{subgoals  [display,indent=1]}\<close>
apply (erule disjE)
(*Case A bad*)
apply assumption
apply (erule disjE)
(*Case: Says*)
apply (erule exE)+
txt\<open>@{subgoals  [display,indent=1]}\<close>
apply (case_tac "C=Spy")
apply (blast dest: NS_Says_Spy_staticSecret)
apply (blast dest: NS_Says_staticSecret)
apply (blast dest: NS_no_Notes)
done

text\<open>Concluding the specialisation proof strategy...\<close>
lemma NS_Spy_see_staticSecret_spec:
"\<lbrakk>m \<in> staticSecret A; evs \<in> ns_public\<rbrakk> \<Longrightarrow>
 m \<in> parts (knows Spy evs) = (A \<in> bad)"
txt\<open>one line proof:
apply (force dest: @{term NS_staticSecret_parts_Spy})
\<close>
apply safe
apply (blast dest: NS_staticSecret_parts_Spy)
txt\<open>one line proof: force\<close>
apply simp
apply (erule disjE)
apply clarify
apply (drule_tac b=Encryption and evs=evs in Spy_spies_bad_privateKey)
apply (drule parts.Inj, assumption)
apply (erule disjE)
apply clarify
apply (drule_tac b=Signature and evs=evs in Spy_spies_bad_privateKey)
apply (drule parts.Inj, assumption)
apply clarify
apply (drule_tac evs=evs in Spy_spies_bad_shrK)
apply (drule parts.Inj, assumption)
done

lemma NS_staticSecret_subset_parts_knows_Spy:
"evs \<in> ns_public \<Longrightarrow>
 staticSecret A \<subseteq> parts (knows Spy evs) = (A \<in> bad)"
apply (force dest: NS_staticSecret_parts_Spy)
done

lemma NS_staticSecret_subset_analz_knows_Spy:
"evs \<in> ns_public \<Longrightarrow>
 staticSecret A \<subseteq> analz (knows Spy evs) = (A \<in> bad)"
apply (force dest: analz_into_parts NS_staticSecret_parts_Spy)
done

end


section \<open>Dynamic data dependence\<close>

theory DynDataDependence imports CFG_wf begin

context CFG_wf begin

definition dyn_data_dependence ::
  "'node \<Rightarrow> 'var \<Rightarrow> 'node \<Rightarrow> 'edge list \<Rightarrow> bool" ("_ influences _ in _ via _" [51,0,0])
where "n influences V in n' via as \<equiv>
    ((V \<in> Def n) \<and> (V \<in> Use n') \<and> (n -as\<rightarrow>* n') \<and>
     (\<exists>a' as'. (as = a'#as') \<and> (\<forall>n'' \<in> set (sourcenodes as'). V \<notin> Def n'')))"

lemma dyn_influence_Cons_source:
  "n influences V in n' via a#as \<Longrightarrow> sourcenode a = n"
  by(simp add:dyn_data_dependence_def,auto elim:path.cases)

lemma dyn_influence_source_notin_tl_edges:
  assumes "n influences V in n' via a#as"
  shows "n \<notin> set (sourcenodes as)"
proof(rule ccontr)
  assume "\<not> n \<notin> set (sourcenodes as)"
  hence "n \<in> set (sourcenodes as)" by simp
  from \<open>n influences V in n' via a#as\<close> have "\<forall>n'' \<in> set (sourcenodes as). V \<notin> Def n''"
    and "V \<in> Def n" by(simp_all add:dyn_data_dependence_def)
  from \<open>\<forall>n'' \<in> set (sourcenodes as). V \<notin> Def n''\<close>
    \<open>n \<in> set (sourcenodes as)\<close> have "V \<notin> Def n" by simp
  with \<open>V \<in> Def n\<close> show False by simp
qed

lemma dyn_influence_only_first_edge:
  assumes "n influences V in n' via a#as" and "preds (kinds (a#as)) s"
  shows "state_val (transfers (kinds (a#as)) s) V =
         state_val (transfer (kind a) s) V"
proof -
  from \<open>preds (kinds (a#as)) s\<close> have "preds (kinds as) (transfer (kind a) s)"
    by(simp add:kinds_def)
  from \<open>n influences V in n' via a#as\<close> have "n -a#as\<rightarrow>* n'"
    and "\<forall>n'' \<in> set (sourcenodes as). V \<notin> Def n''"
    by(simp_all add:dyn_data_dependence_def)
  from \<open>n -a#as\<rightarrow>* n'\<close> have "n = sourcenode a" and "targetnode a -as\<rightarrow>* n'"
    by(auto elim:path_split_Cons)
  from \<open>n influences V in n' via a#as\<close> \<open>n = sourcenode a\<close>
  have "sourcenode a \<notin> set (sourcenodes as)"
    by(fastforce intro!:dyn_influence_source_notin_tl_edges)
  { fix n'' assume "n'' \<in> set (sourcenodes as)"
    with \<open>sourcenode a \<notin> set (sourcenodes as)\<close> \<open>n = sourcenode a\<close>
    have "n'' \<noteq> n" by(fastforce simp:sourcenodes_def)
    with \<open>\<forall>n'' \<in> set (sourcenodes as). V \<notin> Def n''\<close> \<open>n'' \<in> set (sourcenodes as)\<close>
    have "V \<notin> Def n''" by(auto simp:sourcenodes_def) }
  hence "\<forall>n'' \<in> set (sourcenodes as). V \<notin> Def n''" by simp
  with \<open>targetnode a -as\<rightarrow>* n'\<close> \<open>preds (kinds as) (transfer (kind a) s)\<close>
  have "state_val (transfers (kinds as) (transfer (kind a) s)) V =
        state_val (transfer (kind a) s) V"
    by -(rule CFG_path_no_Def_equal)
  thus ?thesis by(auto simp:kinds_def)
qed

end

end


theory LR3_Standard
  imports Compressed_Oracles.CO_Invariants Misc_Luby_Rackoff General_Luby_Rackoff
begin

(* U_UP,i, using standard queries *)
definition UP :: \<open>(whole \<times> whole \<times> db) ell2 \<Rightarrow>\<^sub>C\<^sub>L (whole \<times> whole \<times> db) ell2\<close> where \<open>UP =
  (reg_1_3 o Fst; reg_2_3 o Snd) cnot o\<^sub>C\<^sub>L
  (reg_1_3 o Snd; reg_2_3 o Fst) cnot o\<^sub>C\<^sub>L
  (reg_1_3 o Fst; (reg_2_3 o Fst; reg_3_3)) standard_query\<close>

lemma l1: \<open>(reg_1_3 \<circ> Fst; (reg_2_3 \<circ> Fst; reg_3_3)) standard_query *\<^sub>V ket ((xL, xR), (yL, yR), d)
     = ket ((xL, xR), (yL + the_default 0 (d xL), yR), d)\<close>
  for xL xR yL yR :: half and d :: db
proof -
  have \<open>(reg_1_3 \<circ> Fst; (reg_2_3 \<circ> Fst; reg_3_3)) standard_query *\<^sub>V ket ((xL, xR), (yL, yR), d)
      = (\<Sum>(x, y, d')\<in>UNIV.
           (reg_1_3 \<circ> Fst) (selfbutterket x) *\<^sub>V
           (reg_2_3 \<circ> Fst; reg_3_3) (butterket (y + the_default 0 (d' x), d') (y,d')) *\<^sub>V
           ket ((xL, xR), (yL, yR), d))\<close>
    apply (subst explicit_pair)
      apply simp
     apply (subst standard_query_apply')
     apply simp
    by (simp add: case_prod_beta)
  also have \<open>\<dots> = ket ((xL, xR), (yL + the_default 0 (d xL), yR), d)\<close>
    apply (simp add: register_pair_apply reg_1_3_def reg_2_3_def reg_3_3_def Fst_def Snd_def
        tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1
        flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
    apply (subst sum_single[where i=\<open>(xL,yL,d)\<close>])
    by auto
  finally show ?thesis
    by -
qed

lemma l2: \<open>(reg_1_3 \<circ> Snd;reg_2_3 \<circ> Fst) cnot *\<^sub>V ket ((xL, xR), (yL, yR), d) = ket ((xL, xR), (yL + xR, yR), d)\<close>
  apply (subst explicit_pair)
    apply simp
   apply (subst cnot_apply)
   apply simp
  apply (simp add: register_pair_apply reg_1_3_def reg_2_3_def reg_3_3_def Fst_def Snd_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>(xR,yL)\<close>])
  by auto

lemma l3: \<open>(reg_1_3 \<circ> Fst;reg_2_3 \<circ> Snd) cnot *\<^sub>V ket ((xL, xR), (yL, yR), d) = ket ((xL, xR), (yL, yR + xL), d)\<close>
  apply (subst explicit_pair)
    apply simp
   apply (subst cnot_apply)
   apply simp
  apply (simp add: register_pair_apply reg_1_3_def reg_2_3_def reg_3_3_def Fst_def Snd_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>(xL,yR)\<close>])
  by auto

lemma UP_apply: \<open>UP *\<^sub>V ket ((xL,xR), (yL,yR), d) = ket ((xL, xR), (yL + the_default 0 (d xL) + xR, yR + xL), d)\<close>
  by (simp add: UP_def l1 l2 l3)

lemma UP_apply': \<open>UP *\<^sub>V ket state = (case state of ((xL,xR), (yL,yR), d) \<Rightarrow> ket ((xL, xR), (yL + the_default 0 (d xL) + xR, yR + xL), d))\<close>
  apply (cases state, hypsubst_thin, case_tac c, hypsubst_thin)
  by (simp add: UP_apply)

definition LR3 where \<open>LR3 =
  (X;(X1;D1)) UP o\<^sub>C\<^sub>L (X1;(X2;D2)) UP o\<^sub>C\<^sub>L (X2;(Y;D3)) UP o\<^sub>C\<^sub>L (X1;(X2;D2)) UP o\<^sub>C\<^sub>L (X;(X1;D1)) UP\<close>

lemma up1: \<open>(X;(X1;D1)) UP *\<^sub>V ket ((xL,xR), (x1L,x1R), (x2L,x2R), (yL,yR), d1, d2, d3)
      = ket ((xL, xR), (x1L + the_default 0 (d1 xL) + xR, x1R + xL), (x2L,x2R), (yL,yR), d1, d2, d3)\<close>
  apply (subst explicit_pair)
    apply simp
   apply (subst UP_apply')
   apply (simp add: case_prod_beta split del: split_of_bool)
  apply (simp add: register_pair_apply reg_1_3_def reg_2_3_def reg_3_3_def Fst_def Snd_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1 tensor_ell2_ket_split
      X_def X1_def D1_def
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>((xL, xR), (x1L, x1R), d1)\<close>])
  by auto

lemma up2: \<open>(X1;(X2;D2)) UP *\<^sub>V ket ((xL,xR), (x1L,x1R), (x2L,x2R), (yL,yR), d1, d2, d3)
      = ket ((xL, xR), (x1L, x1R), (x2L + the_default 0 (d2 x1L) + x1R, x2R + x1L), (yL, yR), d1, d2, d3)\<close>
  apply (subst explicit_pair)
    apply simp
   apply (subst UP_apply')
   apply (simp add: case_prod_beta split del: split_of_bool)
  apply (simp add: register_pair_apply reg_1_3_def reg_2_3_def reg_3_3_def Fst_def Snd_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1 tensor_ell2_ket_split
      X_def X1_def D1_def D3_def X2_def D2_def
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>((x1L, x1R), (x2L, x2R), d2)\<close>])
  by auto

lemma up3: \<open>(X2;(Y;D3)) UP *\<^sub>V ket ((xL,xR), (x1L,x1R), (x2L,x2R), (yL,yR), d1, d2, d3)
      = ket ((xL, xR), (x1L, x1R), (x2L, x2R), (yL + the_default 0 (d3 x2L) + x2R, yR + x2L), d1, d2, d3)\<close>
  apply (subst explicit_pair)
    apply simp
   apply (subst UP_apply')
   apply (simp add: case_prod_beta split del: split_of_bool)
  apply (simp add: register_pair_apply reg_1_3_def reg_2_3_def reg_3_3_def Fst_def Snd_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1 tensor_ell2_ket_split
      X_def X1_def D1_def D3_def X2_def D2_def Y_def
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>((x2L, x2R), (yL, yR), d3)\<close>])
  by auto

lemma test:
  shows \<open>LR3 *\<^sub>V ket ((xL,xR), 0, 0, 0, Some o d1, Some o d2, Some o d3) = ket ((xL,xR), 0, 0,
      (d3 (d2 (d1 xL + xR) + xL) + d1 xL + xR, d2 (d1 xL + xR) + xL),
    Some o d1, Some o d2, Some o d3)\<close>
  by (simp add: LR3_def zero_prod_def up1 up2 up3 add.commute add.left_commute)

end


(*  Title:      HOL/Auth/NS_Shared.thy
    Author:     Lawrence C Paulson and Giampaolo Bella
    Copyright   1996  University of Cambridge
*)

section\<open>Needham-Schroeder Shared-Key Protocol and the Issues Property\<close>

theory NS_Shared imports Public begin

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

definition
 (* A is the true creator of X if she has sent X and X never appeared on
    the trace before this event. Recall that traces grow from head. *)
  Issues :: "[agent, agent, msg, event list] \<Rightarrow> bool"
             ("_ Issues _ with _ on _") where
   "A Issues B with X on evs =
      (\<exists>Y. Says A B Y \<in> set evs \<and> X \<in> parts {Y} \<and>
        X \<notin> parts (spies (takeWhile (\<lambda>z. z  \<noteq> Says A B Y) (rev evs))))"

inductive_set ns_shared :: "event list set"
 where
        (*Initial trace is empty*)
  Nil:  "[] \<in> ns_shared"
        (*The spy MAY say anything he CAN say.  We do not expect him to
          invent new nonces here, but he can also use NS1.  Common to
          all similar protocols.*)
| Fake: "\<lbrakk>evsf \<in> ns_shared;  X \<in> synth (analz (spies evsf))\<rbrakk>
         \<Longrightarrow> Says Spy B X # evsf \<in> ns_shared"

        (*Alice initiates a protocol run, requesting to talk to any B*)
| NS1:  "\<lbrakk>evs1 \<in> ns_shared;  Nonce NA \<notin> used evs1\<rbrakk>
         \<Longrightarrow> Says A Server \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> # evs1  \<in>  ns_shared"

        (*Server's response to Alice's message.
          !! It may respond more than once to A's request !!
          Server doesn't know who the true sender is, hence the A' in
              the sender field.*)
| NS2:  "\<lbrakk>evs2 \<in> ns_shared;  Key KAB \<notin> used evs2;  KAB \<in> symKeys;
          Says A' Server \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> \<in> set evs2\<rbrakk>
         \<Longrightarrow> Says Server A
               (Crypt (shrK A)
                  \<lbrace>Nonce NA, Agent B, Key KAB,
                    (Crypt (shrK B) \<lbrace>Key KAB, Agent A\<rbrace>)\<rbrace>)
               # evs2 \<in> ns_shared"

         (*We can't assume S=Server.  Agent A "remembers" her nonce.
           Need A \<noteq> Server because we allow messages to self.*)
| NS3:  "\<lbrakk>evs3 \<in> ns_shared;  A \<noteq> Server;
          Says S A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs3;
          Says A Server \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> \<in> set evs3\<rbrakk>
         \<Longrightarrow> Says A B X # evs3 \<in> ns_shared"

        (*Bob's nonce exchange.  He does not know who the message came
          from, but responds to A because she is mentioned inside.*)
| NS4:  "\<lbrakk>evs4 \<in> ns_shared;  Nonce NB \<notin> used evs4;  K \<in> symKeys;
          Says A' B (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>) \<in> set evs4\<rbrakk>
         \<Longrightarrow> Says B A (Crypt K (Nonce NB)) # evs4 \<in> ns_shared"

        (*Alice responds with Nonce NB if she has seen the key before.
          Maybe should somehow check Nonce NA again.
          We do NOT send NB-1 or similar as the Spy cannot spoof such things.
          Letting the Spy add or subtract 1 lets him send all nonces.
          Instead we distinguish the messages by sending the nonce twice.*)
| NS5:  "\<lbrakk>evs5 \<in> ns_shared;  K \<in> symKeys;
          Says B' A (Crypt K (Nonce NB)) \<in> set evs5;
          Says S  A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>)
            \<in> set evs5\<rbrakk>
         \<Longrightarrow> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) # evs5 \<in> ns_shared"

        (*This message models possible leaks of session keys.
          The two Nonces identify the protocol run: the rule insists upon
          the true senders in order to make them accurate.*)
| Oops: "\<lbrakk>evso \<in> ns_shared;  Says B A (Crypt K (Nonce NB)) \<in> set evso;
          Says Server A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>)
              \<in> set evso\<rbrakk>
         \<Longrightarrow> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> ns_shared"

declare Says_imp_knows_Spy [THEN parts.Inj, dest]
declare parts.Body  [dest]
declare Fake_parts_insert_in_Un  [dest]
declare analz_into_parts [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "[| A \<noteq> Server; Key K \<notin> used []; K \<in> symKeys |]
       ==> \<exists>N. \<exists>evs \<in> ns_shared.
                    Says A B (Crypt K \<lbrace>Nonce N, Nonce N\<rbrace>) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] ns_shared.Nil
       [THEN ns_shared.NS1, THEN ns_shared.NS2, THEN ns_shared.NS3,
        THEN ns_shared.NS4, THEN ns_shared.NS5])
apply (possibility, simp add: used_Cons)
done

(*This version is similar, while instantiating ?K and ?N to epsilon-terms
lemma "A \<noteq> Server \<Longrightarrow> \<exists>evs \<in> ns_shared.
                Says A B (Crypt ?K \<lbrace>Nonce ?N, Nonce ?N\<rbrace>) \<in> set evs"
*)

subsection\<open>Inductive proofs about \<^term>\<open>ns_shared\<close>\<close>

subsubsection\<open>Forwarding lemmas, to aid simplification\<close>

text\<open>For reasoning about the encrypted portion of message NS3\<close>
lemma NS3_msg_in_parts_spies:
     "Says S A (Crypt KA \<lbrace>N, B, K, X\<rbrace>) \<in> set evs \<Longrightarrow> X \<in> parts (spies evs)"
by blast

text\<open>For reasoning about the Oops message\<close>
lemma Oops_parts_spies:
     "Says Server A (Crypt (shrK A) \<lbrace>NA, B, K, X\<rbrace>) \<in> set evs
            \<Longrightarrow> K \<in> parts (spies evs)"
by blast

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

text\<open>Spy never sees another agent's shared key! (unless it's bad at start)\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> ns_shared \<Longrightarrow> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, simp_all, blast+)
done

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

text\<open>Nobody can have used non-existent keys!\<close>
lemma new_keys_not_used [simp]:
    "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> ns_shared|]
     ==> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, simp_all)
txt\<open>Fake, NS2, NS4, NS5\<close>
apply (force dest!: keysFor_parts_insert, blast+)
done

subsubsection\<open>Lemmas concerning the form of items passed in messages\<close>

text\<open>Describes the form of K, X and K' when the Server sends this message.\<close>
lemma Says_Server_message_form:
     "\<lbrakk>Says Server A (Crypt K' \<lbrace>N, Agent B, Key K, X\<rbrace>) \<in> set evs;
       evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK \<and>
          X = (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>) \<and>
          K' = shrK A"
by (erule rev_mp, erule ns_shared.induct, auto)

text\<open>If the encrypted message appears then it originated with the Server\<close>
lemma A_trusts_NS2:
     "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       A \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs"
apply (erule rev_mp)
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, auto)
done

lemma cert_A_form:
     "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       A \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK \<and>  X = (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>)"
by (blast dest!: A_trusts_NS2 Says_Server_message_form)

text\<open>EITHER describes the form of X when the following message is sent,
  OR     reduces it to the Fake case.
  Use \<open>Says_Server_message_form\<close> if applicable.\<close>
lemma Says_S_message_form:
     "\<lbrakk>Says S A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
       evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> (K \<notin> range shrK \<and> X = (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>))
          \<or> X \<in> analz (spies evs)"
by (blast dest: Says_imp_knows_Spy analz_shrK_Decrypt cert_A_form analz.Inj)

(*Alternative version also provable
lemma Says_S_message_form2:
  "\<lbrakk>Says S A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
    evs \<in> ns_shared\<rbrakk>
   \<Longrightarrow> Says Server A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs
       \<or> X \<in> analz (spies evs)"
apply (case_tac "A \<in> bad")
apply (force dest!: Says_imp_knows_Spy [THEN analz.Inj])
by (blast dest!: A_trusts_NS2 Says_Server_message_form)
*)

(****
 SESSION KEY COMPROMISE THEOREM.  To prove theorems of the form

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

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

text\<open>NOT useful in this form, but it says that session keys are not used
  to encrypt messages containing other keys, in the actual protocol.
  We require that agents should behave like this subsequently also.\<close>
lemma  "\<lbrakk>evs \<in> ns_shared;  Kab \<notin> range shrK\<rbrakk> \<Longrightarrow>
         (Crypt KAB X) \<in> parts (spies evs) \<and>
         Key K \<in> parts {X} \<longrightarrow> Key K \<in> parts (spies evs)"
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, simp_all)
txt\<open>Fake\<close>
apply (blast dest: parts_insert_subset_Un)
txt\<open>Base, NS4 and NS5\<close>
apply auto
done

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

text\<open>The equality makes the induction hypothesis easier to apply\<close>

lemma analz_image_freshK [rule_format]:
 "evs \<in> ns_shared \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
             (Key K \<in> analz (Key`KK \<union> (spies evs))) =
             (K \<in> KK \<or> Key K \<in> analz (spies evs))"
apply (erule ns_shared.induct)
apply (drule_tac [8] Says_Server_message_form)
apply (erule_tac [5] Says_S_message_form [THEN disjE], analz_freshK, spy_analz)
txt\<open>NS2, NS3\<close>
apply blast+
done

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

subsubsection\<open>The session key K uniquely identifies the message\<close>

text\<open>In messages of this form, the session key uniquely identifies the rest\<close>
lemma unique_session_keys:
     "\<lbrakk>Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
       Says Server A' (Crypt (shrK A') \<lbrace>NA', Agent B', Key K, X'\<rbrace>) \<in> set evs;
       evs \<in> ns_shared\<rbrakk> \<Longrightarrow> A=A' \<and> NA=NA' \<and> B=B' \<and> X = X'"
by (erule rev_mp, erule rev_mp, erule ns_shared.induct, simp_all, blast+)

subsubsection\<open>Crucial secrecy property: Spy doesn't see the keys sent in NS2\<close>

text\<open>Beware of \<open>[rule_format]\<close> and the universal quantifier!\<close>
lemma secrecy_lemma:
     "\<lbrakk>Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K,
                                      Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>\<rbrace>)
              \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> (\<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs) \<longrightarrow>
         Key K \<notin> analz (spies evs)"
apply (erule rev_mp)
apply (erule ns_shared.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (frule_tac [4] Says_S_message_form)
apply (erule_tac [5] disjE)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes split_ifs, spy_analz)
txt\<open>NS2\<close>
apply blast
txt\<open>NS3\<close>
apply (blast dest!: Crypt_Spy_analz_bad A_trusts_NS2
             dest:  Says_imp_knows_Spy analz.Inj unique_session_keys)
txt\<open>Oops\<close>
apply (blast dest: unique_session_keys)
done

text\<open>Final version: Server's message in the most abstract form\<close>
lemma Spy_not_see_encrypted_key:
     "\<lbrakk>Says Server A (Crypt K' \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
       \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (spies evs)"
by (blast dest: Says_Server_message_form secrecy_lemma)

subsection\<open>Guarantees available at various stages of protocol\<close>

text\<open>If the encrypted message appears then it originated with the Server\<close>
lemma B_trusts_NS3:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace> \<in> parts (spies evs);
       B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> \<exists>NA. Says Server A
               (Crypt (shrK A) \<lbrace>NA, Agent B, Key K,
                                 Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>\<rbrace>)
              \<in> set evs"
apply (erule rev_mp)
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, auto)
done

lemma A_trusts_NS4_lemma [rule_format]:
   "evs \<in> ns_shared \<Longrightarrow>
      Key K \<notin> analz (spies evs) \<longrightarrow>
      Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs \<longrightarrow>
      Crypt K (Nonce NB) \<in> parts (spies evs) \<longrightarrow>
      Says B A (Crypt K (Nonce NB)) \<in> set evs"
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies)
apply (analz_mono_contra, simp_all, blast)
txt\<open>NS2: contradiction from the assumptions \<^term>\<open>Key K \<notin> used evs2\<close> and
    \<^term>\<open>Crypt K (Nonce NB) \<in> parts (spies evs2)\<close>\<close>
apply (force dest!: Crypt_imp_keysFor)
txt\<open>NS4\<close>
apply (metis B_trusts_NS3 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst unique_session_keys)
done

text\<open>This version no longer assumes that K is secure\<close>
lemma A_trusts_NS4:
     "\<lbrakk>Crypt K (Nonce NB) \<in> parts (spies evs);
       Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Nonce NB)) \<in> set evs"
by (blast intro: A_trusts_NS4_lemma
          dest: A_trusts_NS2 Spy_not_see_encrypted_key)

text\<open>If the session key has been used in NS4 then somebody has forwarded
  component X in some instance of NS4.  Perhaps an interesting property,
  but not needed (after all) for the proofs below.\<close>
theorem NS4_implies_NS3 [rule_format]:
  "evs \<in> ns_shared \<Longrightarrow>
     Key K \<notin> analz (spies evs) \<longrightarrow>
     Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs \<longrightarrow>
     Crypt K (Nonce NB) \<in> parts (spies evs) \<longrightarrow>
     (\<exists>A'. Says A' B X \<in> set evs)"
apply (erule ns_shared.induct, force)
apply (drule_tac [4] NS3_msg_in_parts_spies)
apply analz_mono_contra
apply (simp_all add: ex_disj_distrib, blast)
txt\<open>NS2\<close>
apply (blast dest!: new_keys_not_used Crypt_imp_keysFor)
txt\<open>NS4\<close>
apply (metis B_trusts_NS3 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst unique_session_keys)
done

lemma B_trusts_NS5_lemma [rule_format]:
  "\<lbrakk>B \<notin> bad;  evs \<in> ns_shared\<rbrakk> \<Longrightarrow>
     Key K \<notin> analz (spies evs) \<longrightarrow>
     Says Server A
          (Crypt (shrK A) \<lbrace>NA, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>\<rbrace>) \<in> set evs \<longrightarrow>
     Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts (spies evs) \<longrightarrow>
     Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs"
apply (erule ns_shared.induct, force)
apply (drule_tac [4] NS3_msg_in_parts_spies)
apply (analz_mono_contra, simp_all, blast)
txt\<open>NS2\<close>
apply (blast dest!: new_keys_not_used Crypt_imp_keysFor)
txt\<open>NS5\<close>
apply (blast dest!: A_trusts_NS2
             dest: Says_imp_knows_Spy [THEN analz.Inj]
                   unique_session_keys Crypt_Spy_analz_bad)
done

text\<open>Very strong Oops condition reveals protocol's weakness\<close>
lemma B_trusts_NS5:
     "\<lbrakk>Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts (spies evs);
       Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace> \<in> parts (spies evs);
       \<forall>NA NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs"
by (blast intro: B_trusts_NS5_lemma
          dest: B_trusts_NS3 Spy_not_see_encrypted_key)

text\<open>Unaltered so far wrt original version\<close>

subsection\<open>Lemmas for reasoning about predicate "Issues"\<close>

lemma spies_Says_rev: "spies (evs @ [Says A B X]) = insert X (spies evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_Gets_rev: "spies (evs @ [Gets A X]) = spies evs"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_Notes_rev: "spies (evs @ [Notes A X]) =
          (if A\<in>bad then insert X (spies evs) else spies evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_evs_rev: "spies evs = spies (rev evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a")
apply (simp_all (no_asm_simp) add: spies_Says_rev spies_Gets_rev spies_Notes_rev)
done

lemmas parts_spies_evs_revD2 = spies_evs_rev [THEN equalityD2, THEN parts_mono]

lemma spies_takeWhile: "spies (takeWhile P evs) \<subseteq> spies evs"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
txt\<open>Resembles \<open>used_subset_append\<close> in theory Event.\<close>
done

lemmas parts_spies_takeWhile_mono = spies_takeWhile [THEN parts_mono]

subsection\<open>Guarantees of non-injective agreement on the session key, and
of key distribution. They also express forms of freshness of certain messages,
namely that agents were alive after something happened.\<close>

lemma B_Issues_A:
     "\<lbrakk> Says B A (Crypt K (Nonce Nb)) \<in> set evs;
         Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad; evs \<in> ns_shared \<rbrakk>
      \<Longrightarrow> B Issues A with (Crypt K (Nonce Nb)) on evs"
apply (simp (no_asm) add: Issues_def)
apply (rule exI)
apply (rule conjI, assumption)
apply (simp (no_asm))
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule ns_shared.induct, analz_mono_contra)
apply (simp_all)
txt\<open>fake\<close>
apply blast
apply (simp_all add: takeWhile_tail)
txt\<open>NS3 remains by pure coincidence!\<close>
apply (force dest!: A_trusts_NS2 Says_Server_message_form)
txt\<open>NS4 would be the non-trivial case can be solved by Nb being used\<close>
apply (blast dest: parts_spies_takeWhile_mono [THEN subsetD]
                   parts_spies_evs_revD2 [THEN subsetD])
done

text\<open>Tells A that B was alive after she sent him the session key.  The
session key must be assumed confidential for this deduction to be meaningful,
but that assumption can be relaxed by the appropriate argument.

Precisely, the theorem guarantees (to A) key distribution of the session key
to B. It also guarantees (to A) non-injective agreement of B with A on the
session key. Both goals are available to A in the sense of Goal Availability.
\<close>
lemma A_authenticates_and_keydist_to_B:
     "\<lbrakk>Crypt K (Nonce NB) \<in> parts (spies evs);
       Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       Key K \<notin> analz(knows Spy evs);
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> B Issues A with (Crypt K (Nonce NB)) on evs"
by (blast intro: A_trusts_NS4_lemma B_Issues_A dest: A_trusts_NS2)

lemma A_trusts_NS5:
  "\<lbrakk> Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts(spies evs);
     Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace> \<in> parts(spies evs);
     Key K \<notin> analz (spies evs);
     A \<notin> bad; B \<notin> bad; evs \<in> ns_shared \<rbrakk>
 \<Longrightarrow> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule ns_shared.induct, analz_mono_contra)
apply (simp_all)
txt\<open>Fake\<close>
apply blast
txt\<open>NS2\<close>
apply (force dest!: Crypt_imp_keysFor)
txt\<open>NS3\<close>
apply (metis NS3_msg_in_parts_spies parts_cut_eq)
txt\<open>NS5, the most important case, can be solved by unicity\<close>
apply (metis A_trusts_NS2 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst analz.Snd unique_session_keys)
done

lemma A_Issues_B:
     "\<lbrakk> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs;
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad; evs \<in> ns_shared \<rbrakk>
    \<Longrightarrow> A Issues B with (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) on evs"
apply (simp (no_asm) add: Issues_def)
apply (rule exI)
apply (rule conjI, assumption)
apply (simp (no_asm))
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule ns_shared.induct, analz_mono_contra)
apply (simp_all)
txt\<open>fake\<close>
apply blast
apply (simp_all add: takeWhile_tail)
txt\<open>NS3 remains by pure coincidence!\<close>
apply (force dest!: A_trusts_NS2 Says_Server_message_form)
txt\<open>NS5 is the non-trivial case and cannot be solved as in \<^term>\<open>B_Issues_A\<close>! because NB is not fresh. We need \<^term>\<open>A_trusts_NS5\<close>, proved for this very purpose\<close>
apply (blast dest: A_trusts_NS5 parts_spies_takeWhile_mono [THEN subsetD]
        parts_spies_evs_revD2 [THEN subsetD])
done

text\<open>Tells B that A was alive after B issued NB.

Precisely, the theorem guarantees (to B) key distribution of the session key to A. It also guarantees (to B) non-injective agreement of A with B on the session key. Both goals are available to B in the sense of Goal Availability.
\<close>
lemma B_authenticates_and_keydist_to_A:
     "\<lbrakk>Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts (spies evs);
       Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace> \<in> parts (spies evs);
       Key K \<notin> analz (spies evs);
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
   \<Longrightarrow> A Issues B with (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) on evs"
by (blast intro: A_Issues_B B_trusts_NS5_lemma dest: B_trusts_NS3)

end