(* Author: Tobias Nipkow *)

theory Abs_Int0
imports Abs_Int_init
begin

subsection "Orderings"

text{* The basic type classes @{class order}, @{class semilattice_sup} and @{class order_top} are
defined in @{theory Main}, more precisely in theories @{theory Orderings} and @{theory Lattices}.
If you view this theory with jedit, just click on the names to get there. *}

class semilattice_sup_top = semilattice_sup + order_top

instance "fun" :: (type, semilattice_sup_top) semilattice_sup_top ..

instantiation option :: (order)order
begin

fun less_eq_option where
"Some x \<le> Some y = (x \<le> y)" |
"None \<le> y = True" |
"Some _ \<le> None = False"

definition less_option where "x < (y::'a option) = (x \<le> y \<and> \<not> y \<le> x)"

lemma le_None[simp]: "(x \<le> None) = (x = None)"
by (cases x) simp_all

lemma Some_le[simp]: "(Some x \<le> u) = (\<exists>y. u = Some y \<and> x \<le> y)"
by (cases u) auto

instance proof
  case goal1 show ?case by(rule less_option_def)
next
  case goal2 show ?case by(cases x, simp_all)
next
  case goal3 thus ?case by(cases z, simp, cases y, simp, cases x, auto)
next
  case goal4 thus ?case by(cases y, simp, cases x, auto)
qed

end

instantiation option :: (sup)sup
begin

fun sup_option where
"Some x \<squnion> Some y = Some(x \<squnion> y)" |
"None \<squnion> y = y" |
"x \<squnion> None = x"

lemma sup_None2[simp]: "x \<squnion> None = x"
by (cases x) simp_all

instance ..

end

instantiation option :: (semilattice_sup_top)semilattice_sup_top
begin

definition top_option where "\<top> = Some \<top>"

instance proof
  case goal4 show ?case by(cases a, simp_all add: top_option_def)
next
  case goal1 thus ?case by(cases x, simp, cases y, simp_all)
next
  case goal2 thus ?case by(cases y, simp, cases x, simp_all)
next
  case goal3 thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
qed

end

instantiation option :: (order)order_bot
begin

definition bot_option :: "'a option" where
"\<bottom> = None"

instance
proof
  case goal1 thus ?case by(auto simp: bot_option_def)
qed

end

definition bot :: "com \<Rightarrow> 'a option acom" where
"bot c = annotate (\<lambda>p. None) c"

lemma bot_least: "strip C = c \<Longrightarrow> bot c \<le> C"
by(auto simp: bot_def less_eq_acom_def)

lemma strip_bot[simp]: "strip(bot c) = c"
by(simp add: bot_def)

subsubsection "Pre-fixpoint iteration"

definition pfp :: "(('a::order) \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"pfp f = while_option (\<lambda>x. \<not> f x \<le> x) f"

lemma pfp_pfp: assumes "pfp f x0 = Some x" shows "f x \<le> x"
using while_option_stop[OF assms[simplified pfp_def]] by simp

lemma while_least:
fixes q :: "'a::order"
assumes "\<forall>x\<in>L.\<forall>y\<in>L. x \<le> y \<longrightarrow> f x \<le> f y" and "\<forall>x. x \<in> L \<longrightarrow> f x \<in> L"
and "\<forall>x \<in> L. b \<le> x" and "b \<in> L" and "f q \<le> q" and "q \<in> L"
and "while_option P f b = Some p"
shows "p \<le> q"
using while_option_rule[OF _  assms(7)[unfolded pfp_def],
                        where P = "%x. x \<in> L \<and> x \<le> q"]
by (metis assms(1-6) order_trans)

lemma pfp_bot_least:
assumes "\<forall>x\<in>{C. strip C = c}.\<forall>y\<in>{C. strip C = c}. x \<le> y \<longrightarrow> f x \<le> f y"
and "\<forall>C. C \<in> {C. strip C = c} \<longrightarrow> f C \<in> {C. strip C = c}"
and "f C' \<le> C'" "strip C' = c" "pfp f (bot c) = Some C"
shows "C \<le> C'"
by(rule while_least[OF assms(1,2) _ _ assms(3) _ assms(5)[unfolded pfp_def]])
  (simp_all add: assms(4) bot_least)

lemma pfp_inv:
  "pfp f x = Some y \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P(f x)) \<Longrightarrow> P x \<Longrightarrow> P y"
unfolding pfp_def by (blast intro: while_option_rule)

lemma strip_pfp:
assumes "\<And>x. g(f x) = g x" and "pfp f x0 = Some x" shows "g x = g x0"
using pfp_inv[OF assms(2), where P = "%x. g x = g x0"] assms(1) by simp

subsection "Abstract Interpretation"

definition \<gamma>_fun :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b)set" where
"\<gamma>_fun \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(F x)}"

fun \<gamma>_option :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a option \<Rightarrow> 'b set" where
"\<gamma>_option \<gamma> None = {}" |
"\<gamma>_option \<gamma> (Some a) = \<gamma> a"

text{* The interface for abstract values: *}

locale Val_semilattice =
fixes \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
  assumes mono_gamma: "a \<le> b \<Longrightarrow> \<gamma> a \<le> \<gamma> b"
  and gamma_Top[simp]: "\<gamma> \<top> = UNIV"
fixes num' :: "val \<Rightarrow> 'av"
and plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av"
  assumes gamma_num': "i \<in> \<gamma>(num' i)"
  and gamma_plus': "i1 \<in> \<gamma> a1 \<Longrightarrow> i2 \<in> \<gamma> a2 \<Longrightarrow> i1+i2 \<in> \<gamma>(plus' a1 a2)"

type_synonym 'av st = "(vname \<Rightarrow> 'av)"

text{* The for-clause (here and elsewhere) only serves the purpose of fixing
the name of the type parameter @{typ 'av} which would otherwise be renamed to
@{typ 'a}. *}

locale Abs_Int_fun = Val_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N i) S = num' i" |
"aval' (V x) S = S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

definition "asem x e S = (case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(S(x := aval' e S)))"

definition "step' = Step asem (\<lambda>b S. S)"

lemma strip_step'[simp]: "strip(step' S C) = strip C"
by(simp add: step'_def)

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>s == \<gamma>_fun \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_s_Top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
by(simp add: top_fun_def \<gamma>_fun_def)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
by (simp add: top_option_def)

lemma mono_gamma_s: "f1 \<le> f2 \<Longrightarrow> \<gamma>\<^sub>s f1 \<subseteq> \<gamma>\<^sub>s f2"
by(auto simp: le_fun_def \<gamma>_fun_def dest: mono_gamma)

lemma mono_gamma_o:
  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)

lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])

text{* Correctness: *}

lemma aval'_correct: "s : \<gamma>\<^sub>s S \<Longrightarrow> aval a s : \<gamma>(aval' a S)"
by (induct a) (auto simp: gamma_num' gamma_plus' \<gamma>_fun_def)

lemma in_gamma_update: "\<lbrakk> s : \<gamma>\<^sub>s S; i : \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) : \<gamma>\<^sub>s(S(x := a))"
by(simp add: \<gamma>_fun_def)

lemma gamma_Step_subcomm:
  assumes "!!x e S. f1 x e (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (f2 x e S)"  "!!b S. g1 b (\<gamma>\<^sub>o S) \<subseteq> \<gamma>\<^sub>o (g2 b S)"
  shows "Step f1 g1 (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (Step f2 g2 S C)"
by (induction C arbitrary: S) (auto simp: mono_gamma_o assms)

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: aval'_correct in_gamma_update asem_def split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  --"transfer the pfp'"
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_fun_mono = Abs_Int_fun +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
begin

lemma mono_aval': "S \<le> S' \<Longrightarrow> aval' e S \<le> aval' e S'"
by(induction e)(auto simp: le_fun_def mono_plus')

lemma mono_update: "a \<le> a' \<Longrightarrow> S \<le> S' \<Longrightarrow> S(x := a) \<le> S'(x := a')"
by(simp add: le_fun_def)

lemma mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step)
  (auto simp: mono_update mono_aval' asem_def split: option.split)

lemma mono_step'_top: "C \<le> C' \<Longrightarrow> step' \<top> C \<le> step' \<top> C'"
by (metis mono_step' order_refl)

lemma AI_least_pfp: assumes "AI c = Some C" "step' \<top> C' \<le> C'" "strip C' = c"
shows "C \<le> C'"
by(rule pfp_bot_least[OF _ _ assms(2,3) assms(1)[unfolded AI_def]])
  (simp_all add: mono_step'_top)

end

instantiation acom :: (type) vars
begin

definition "vars_acom = vars o strip"

instance ..

end

lemma finite_Cvars: "finite(vars(C::'a acom))"
by(simp add: vars_acom_def)

subsubsection "Termination"

lemma pfp_termination:
fixes x0 :: "'a::order" and m :: "'a \<Rightarrow> nat"
assumes mono: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
and m: "\<And>x y. I x \<Longrightarrow> I y \<Longrightarrow> x < y \<Longrightarrow> m x > m y"
and I: "\<And>x y. I x \<Longrightarrow> I(f x)" and "I x0" and "x0 \<le> f x0"
shows "\<exists>x. pfp f x0 = Some x"
proof(simp add: pfp_def, rule wf_while_option_Some[where P = "%x. I x & x \<le> f x"])
  show "wf {(y,x). ((I x \<and> x \<le> f x) \<and> \<not> f x \<le> x) \<and> y = f x}"
    by(rule wf_subset[OF wf_measure[of m]]) (auto simp: m I)
next
  show "I x0 \<and> x0 \<le> f x0" using `I x0` `x0 \<le> f x0` by blast
next
  fix x assume "I x \<and> x \<le> f x" thus "I(f x) \<and> f x \<le> f(f x)"
    by (blast intro: I mono)
qed

lemma le_iff_le_annos: "C1 \<le> C2 \<longleftrightarrow>
  strip C1 = strip C2 \<and> (\<forall> i<size(annos C1). annos C1 ! i \<le> annos C2 ! i)"
by(simp add: less_eq_acom_def anno_def)

locale Measure1_fun =
fixes m :: "'av::top \<Rightarrow> nat"
fixes h :: "nat"
assumes h: "m x \<le> h"
begin

definition m_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>s") where
"m_s S X = (\<Sum> x \<in> X. m(S x))"

lemma m_s_h: "finite X \<Longrightarrow> m_s S X \<le> h * card X"
by(simp add: m_s_def) (metis mult.commute of_nat_id setsum_bounded[OF h])

fun m_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("m\<^sub>o") where
"m_o (Some S) X = m_s S X" |
"m_o None X = h * card X + 1"

lemma m_o_h: "finite X \<Longrightarrow> m_o opt X \<le> (h*card X + 1)"
by(cases opt)(auto simp add: m_s_h le_SucI dest: m_s_h)

definition m_c :: "'av st option acom \<Rightarrow> nat" ("m\<^sub>c") where
"m_c C = listsum (map (\<lambda>a. m_o a (vars C)) (annos C))"

text{* Upper complexity bound: *}
lemma m_c_h: "m_c C \<le> size(annos C) * (h * card(vars C) + 1)"
proof-
  let ?X = "vars C" let ?n = "card ?X" let ?a = "size(annos C)"
  have "m_c C = (\<Sum>i<?a. m_o (annos C ! i) ?X)"
    by(simp add: m_c_def listsum_setsum_nth atLeast0LessThan)
  also have "\<dots> \<le> (\<Sum>i<?a. h * ?n + 1)"
    apply(rule setsum_mono) using m_o_h[OF finite_Cvars] by simp
  also have "\<dots> = ?a * (h * ?n + 1)" by simp
  finally show ?thesis .
qed

end

locale Measure_fun = Measure1_fun where m=m
  for m :: "'av::semilattice_sup_top \<Rightarrow> nat" +
assumes m2: "x < y \<Longrightarrow> m x > m y"
begin

text{* The predicates @{text "top_on_ty a X"} that follow describe that any abstract
state in @{text a} maps all variables in @{text X} to @{term \<top>}.
This is an important invariant for the termination proof where we argue that only
the finitely many variables in the program change. That the others do not change
follows because they remain @{term \<top>}. *}

fun top_on_st :: "'av st \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>s") where
"top_on_st S X = (\<forall>x\<in>X. S x = \<top>)"

fun top_on_opt :: "'av st option \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>o") where
"top_on_opt (Some S) X = top_on_st S X" |
"top_on_opt None X = True"

definition top_on_acom :: "'av st option acom \<Rightarrow> vname set \<Rightarrow> bool" ("top'_on\<^sub>c") where
"top_on_acom C X = (\<forall>a \<in> set(annos C). top_on_opt a X)"

lemma top_on_top: "top_on_opt \<top> X"
by(auto simp: top_option_def)

lemma top_on_bot: "top_on_acom (bot c) X"
by(auto simp add: top_on_acom_def bot_def)

lemma top_on_post: "top_on_acom C X \<Longrightarrow> top_on_opt (post C) X"
by(simp add: top_on_acom_def post_in_annos)

lemma top_on_acom_simps:
  "top_on_acom (SKIP {Q}) X = top_on_opt Q X"
  "top_on_acom (x ::= e {Q}) X = top_on_opt Q X"
  "top_on_acom (C1;;C2) X = (top_on_acom C1 X \<and> top_on_acom C2 X)"
  "top_on_acom (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) X =
   (top_on_opt P1 X \<and> top_on_acom C1 X \<and> top_on_opt P2 X \<and> top_on_acom C2 X \<and> top_on_opt Q X)"
  "top_on_acom ({I} WHILE b DO {P} C {Q}) X =
   (top_on_opt I X \<and> top_on_acom C X \<and> top_on_opt P X \<and> top_on_opt Q X)"
by(auto simp add: top_on_acom_def)

lemma top_on_sup:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<squnion> o2) X"
apply(induction o1 o2 rule: sup_option.induct)
apply(auto)
done

lemma top_on_Step: fixes C :: "'av st option acom"
assumes "!!x e S. \<lbrakk>top_on_opt S X; x \<notin> X; vars e \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (f x e S) X"
        "!!b S. top_on_opt S X \<Longrightarrow> vars b \<subseteq> -X \<Longrightarrow> top_on_opt (g b S) X"
shows "\<lbrakk> vars C \<subseteq> -X; top_on_opt S X; top_on_acom C X \<rbrakk> \<Longrightarrow> top_on_acom (Step f g S C) X"
proof(induction C arbitrary: S)
qed (auto simp: top_on_acom_simps vars_acom_def top_on_post top_on_sup assms)

lemma m1: "x \<le> y \<Longrightarrow> m x \<ge> m y"
by(auto simp: le_less m2)

lemma m_s2_rep: assumes "finite(X)" and "S1 = S2 on -X" and "\<forall>x. S1 x \<le> S2 x" and "S1 \<noteq> S2"
shows "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
proof-
  from assms(3) have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S2 x)" by (simp add: m1)
  from assms(2,3,4) have "EX x:X. S1 x < S2 x"
    by(simp add: fun_eq_iff) (metis Compl_iff le_neq_trans)
  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S2 x)" by (metis m2)
  from setsum_strict_mono_ex1[OF `finite X` 1 2]
  show "(\<Sum>x\<in>X. m (S2 x)) < (\<Sum>x\<in>X. m (S1 x))" .
qed

lemma m_s2: "finite(X) \<Longrightarrow> S1 = S2 on -X \<Longrightarrow> S1 < S2 \<Longrightarrow> m_s S1 X > m_s S2 X"
apply(auto simp add: less_fun_def m_s_def)
apply(simp add: m_s2_rep le_fun_def)
done

lemma m_o2: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 < o2 \<Longrightarrow> m_o o1 X > m_o o2 X"
proof(induction o1 o2 rule: less_eq_option.induct)
  case 1 thus ?case by (auto simp: m_s2 less_option_def)
next
  case 2 thus ?case by(auto simp: less_option_def le_imp_less_Suc m_s_h)
next
  case 3 thus ?case by (auto simp: less_option_def)
qed

lemma m_o1: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
by(auto simp: le_less m_o2)

lemma m_c2: "top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2) \<Longrightarrow>
  C1 < C2 \<Longrightarrow> m_c C1 > m_c C2"
proof(auto simp add: le_iff_le_annos size_annos_same[of C1 C2] vars_acom_def less_acom_def)
  let ?X = "vars(strip C2)"
  assume top: "top_on_acom C1 (- vars(strip C2))"  "top_on_acom C2 (- vars(strip C2))"
  and strip_eq: "strip C1 = strip C2"
  and 0: "\<forall>i<size(annos C2). annos C1 ! i \<le> annos C2 ! i"
  hence 1: "\<forall>i<size(annos C2). m_o (annos C1 ! i) ?X \<ge> m_o (annos C2 ! i) ?X"
    apply (auto simp: all_set_conv_all_nth vars_acom_def top_on_acom_def)
    by (metis (lifting, no_types) finite_cvars m_o1 size_annos_same2)
  fix i assume i: "i < size(annos C2)" "\<not> annos C2 ! i \<le> annos C1 ! i"
  have topo1: "top_on_opt (annos C1 ! i) (- ?X)"
    using i(1) top(1) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  have topo2: "top_on_opt (annos C2 ! i) (- ?X)"
    using i(1) top(2) by(simp add: top_on_acom_def size_annos_same[OF strip_eq])
  from i have "m_o (annos C1 ! i) ?X > m_o (annos C2 ! i) ?X" (is "?P i")
    by (metis 0 less_option_def m_o2[OF finite_cvars topo1] topo2)
  hence 2: "\<exists>i < size(annos C2). ?P i" using `i < size(annos C2)` by blast
  have "(\<Sum>i<size(annos C2). m_o (annos C2 ! i) ?X)
         < (\<Sum>i<size(annos C2). m_o (annos C1 ! i) ?X)"
    apply(rule setsum_strict_mono_ex1) using 1 2 by (auto)
  thus ?thesis
    by(simp add: m_c_def vars_acom_def strip_eq listsum_setsum_nth atLeast0LessThan size_annos_same[OF strip_eq])
qed

end

locale Abs_Int_fun_measure =
  Abs_Int_fun_mono where \<gamma>=\<gamma> + Measure_fun where m=m
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"
begin

lemma top_on_step': "top_on_acom C (-vars C) \<Longrightarrow> top_on_acom (step' \<top> C) (-vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_option_def asem_def split: option.splits)

lemma AI_Some_measure: "\<exists>C. AI c = Some C"
unfolding AI_def
apply(rule pfp_termination[where I = "\<lambda>C. top_on_acom C (- vars C)" and m="m_c"])
apply(simp_all add: m_c2 mono_step'_top bot_least top_on_bot)
using top_on_step' apply(auto simp add: vars_acom_def)
done

end

text{* Problem: not executable because of the comparison of abstract states,
i.e. functions, in the pre-fixpoint computation. *}

end


theory L4_Protocol_Flags
imports Simple_Firewall.L4_Protocol
begin

section\<open>Matching TCP Flags\<close>
  (*man iptables-extensions, [!] --tcp-flags mask comp*)
  datatype ipt_tcp_flags = TCP_Flags "tcp_flag set" \<comment> \<open>mask\<close>
                                     "tcp_flag set" \<comment> \<open>comp\<close>

  (*--syn: Only match TCP packets with the SYN bit set and the ACK,RST and FIN bits cleared. [...] It is equivalent to --tcp-flags SYN,RST,ACK,FIN SYN.*)
  definition ipt_tcp_syn :: "ipt_tcp_flags" where
    "ipt_tcp_syn \<equiv> TCP_Flags {TCP_SYN,TCP_RST,TCP_ACK,TCP_FIN} {TCP_SYN}"

  fun match_tcp_flags :: "ipt_tcp_flags \<Rightarrow> tcp_flag set \<Rightarrow> bool" where
     "match_tcp_flags (TCP_Flags fmask c) flags \<longleftrightarrow> (flags \<inter> fmask) = c"

  lemma "match_tcp_flags ipt_tcp_syn {TCP_SYN, TCP_URG, TCP_PSH}" by eval

  lemma match_tcp_flags_nomatch: "\<not> c \<subseteq> fmask \<Longrightarrow> \<not> match_tcp_flags (TCP_Flags fmask c) pkt" by auto

  definition ipt_tcp_flags_NoMatch :: "ipt_tcp_flags" where
    "ipt_tcp_flags_NoMatch \<equiv> TCP_Flags {} {TCP_SYN}"
  lemma ipt_tcp_flags_NoMatch: "\<not> match_tcp_flags ipt_tcp_flags_NoMatch pkt" by(simp add: ipt_tcp_flags_NoMatch_def)

  definition ipt_tcp_flags_Any :: ipt_tcp_flags where
    "ipt_tcp_flags_Any \<equiv> TCP_Flags {} {}"

  lemma ipt_tcp_flags_Any_isUNIV: "fmask = {} \<and> c = {} \<longleftrightarrow> (\<forall>pkt. match_tcp_flags (TCP_Flags fmask c) pkt)" by auto

  fun match_tcp_flags_conjunct :: "ipt_tcp_flags \<Rightarrow> ipt_tcp_flags \<Rightarrow> ipt_tcp_flags" where
    "match_tcp_flags_conjunct (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
          if c1 \<subseteq> fmask1 \<and> c2 \<subseteq> fmask2 \<and> fmask1 \<inter> fmask2 \<inter> c1 = fmask1 \<inter> fmask2 \<inter> c2
          then (TCP_Flags (fmask1 \<union> fmask2) (c1 \<union> c2))
          else ipt_tcp_flags_NoMatch)"

  lemma match_tcp_flags_conjunct: "match_tcp_flags (match_tcp_flags_conjunct f1 f2) pkt \<longleftrightarrow> match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt"
    apply(cases f1, cases f2, simp)
    apply(rename_tac fmask1 c1 fmask2 c2)
    apply(intro conjI impI)
     apply(elim conjE)
     apply blast
    apply(simp add: ipt_tcp_flags_NoMatch)
    apply fast
    done
  declare match_tcp_flags_conjunct.simps[simp del]

  text\<open>Same as @{const match_tcp_flags_conjunct}, but returns @{const None} if result cannot match anyway\<close>
  definition match_tcp_flags_conjunct_option :: "ipt_tcp_flags \<Rightarrow> ipt_tcp_flags \<Rightarrow> ipt_tcp_flags option" where
    "match_tcp_flags_conjunct_option f1 f2 = (case match_tcp_flags_conjunct f1 f2 of (TCP_Flags fmask c) \<Rightarrow> if c \<subseteq> fmask then Some (TCP_Flags fmask c) else None)"

  lemma "match_tcp_flags_conjunct_option ipt_tcp_syn (TCP_Flags {TCP_RST,TCP_ACK} {TCP_RST}) = None" by eval

  lemma match_tcp_flags_conjunct_option_Some: "match_tcp_flags_conjunct_option f1 f2 = Some f3 \<Longrightarrow>
      match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt \<longleftrightarrow> match_tcp_flags f3 pkt"
    apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
    using match_tcp_flags_conjunct by blast
  lemma match_tcp_flags_conjunct_option_None: "match_tcp_flags_conjunct_option f1 f2 = None \<Longrightarrow>
      \<not>(match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt)"
    apply(simp add: match_tcp_flags_conjunct_option_def split: ipt_tcp_flags.split_asm if_split_asm)
    using match_tcp_flags_conjunct match_tcp_flags_nomatch by metis

  lemma match_tcp_flags_conjunct_option: "(case match_tcp_flags_conjunct_option f1 f2 of None \<Rightarrow> False | Some f3 \<Rightarrow> match_tcp_flags f3 pkt) \<longleftrightarrow> match_tcp_flags f1 pkt \<and> match_tcp_flags f2 pkt"
    apply(simp split: option.split)
    using match_tcp_flags_conjunct_option_Some match_tcp_flags_conjunct_option_None by blast

  fun ipt_tcp_flags_equal :: "ipt_tcp_flags \<Rightarrow> ipt_tcp_flags \<Rightarrow> bool" where
    "ipt_tcp_flags_equal (TCP_Flags fmask1 c1) (TCP_Flags fmask2 c2) = (
          if c1 \<subseteq> fmask1 \<and> c2 \<subseteq> fmask2
          then c1 = c2 \<and> fmask1 = fmask2
          else  (\<not> c1 \<subseteq> fmask1) \<and> (\<not> c2 \<subseteq> fmask2))"
  context
  begin
    private lemma funny_set_falg_fmask_helper: "c2 \<subseteq> fmask2 \<Longrightarrow> (c1 = c2 \<and> fmask1 = fmask2) = (\<forall>pkt. (pkt \<inter> fmask1 = c1) = (pkt \<inter> fmask2 = c2))"
    apply rule
     apply presburger
    apply(subgoal_tac "fmask1 = fmask2")
     apply blast
    (*"e": Try this: by (metis Diff_Compl Diff_eq Int_lower2 Un_Diff_Int compl_sup disjoint_eq_subset_Compl inf_assoc inf_commute inf_sup_absorb) (> 1.0 s, timed out).
      Isar proof (300 ms):*)
    proof -
      assume a1: "c2 \<subseteq> fmask2"
      assume a2: "\<forall>pkt. (pkt \<inter> fmask1 = c1) = (pkt \<inter> fmask2 = c2)"
      have f3: "\<And>A Aa. (A::'a set) - - Aa = Aa - - A"
        by (simp add: inf_commute)
      have f4: "\<And>A Aa. (A::'a set) - - (- Aa) = A - Aa"
        by simp
      have f5: "\<And>A Aa Ab. (A::'a set) - - Aa - - Ab = A - - (Aa - - Ab)"
        by blast
      have f6: "\<And>A Aa. (A::'a set) - (- A - Aa) = A"
        by fastforce
      have f7: "\<And>A Aa. - (A::'a set) - - Aa = Aa - A"
        using f4 f3 by presburger
      have f8: "\<And>A Aa. - (A::'a set) = - (A - Aa) - (A - - Aa)"
        by blast
      have f9: "c1 = - (- c1)"
        by blast
      have f10: "\<And>A. A - c1 - c1 = A - c1"
        by blast
      have "\<And>A. A - - (fmask1 - - fmask2) = c2 \<or> A - - fmask1 \<noteq> c1"
        using f6 f5 a2 by (metis (no_types) Diff_Compl)
      hence f11: "\<And>A. - A - - (fmask1 - - fmask2) = c2 \<or> fmask1 - A \<noteq> c1"
        using f7 by meson
      have "c2 - fmask2 = {}"
        using a1 by force
      hence f12: "- c2 - (fmask2 - c2) = - fmask2"
        by blast
      hence "fmask2 - - c2 = c2"
        by blast
      hence f13: "fmask1 - - c2 = c1"
        using f3 a2 by simp
      hence f14: "c1 = c2"
        using f11 by blast
      hence f15: "fmask2 - (fmask1 - c1) = c1"
        using f13 f10 f9 f8 f7 f3 a2 by (metis Diff_Compl)
      have "fmask1 - (fmask2 - c1) = c1"
        using f14 f12 f10 f9 f8 f4 f3 a2 by (metis Diff_Compl)
      thus "fmask1 = fmask2"
        using f15 by blast
    qed

    lemma ipt_tcp_flags_equal: "ipt_tcp_flags_equal f1 f2 \<longleftrightarrow> (\<forall>pkt. match_tcp_flags f1 pkt = match_tcp_flags f2 pkt)"
      apply(cases f1, cases f2, simp)
      apply(rename_tac fmask1 c1 fmask2 c2)
      apply(intro conjI impI)
       using funny_set_falg_fmask_helper apply metis
      apply blast
     done
  end
  declare ipt_tcp_flags_equal.simps[simp del]
end


theory prop_43
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun takeWhile :: "('a => bool) => 'a list => 'a list" where
  "takeWhile x (Nil2) = Nil2"
  | "takeWhile x (Cons2 z xs) =
       (if x z then Cons2 z (takeWhile x xs) else Nil2)"
  fun dropWhile :: "('a => bool) => 'a list => 'a list" where
  "dropWhile x (Nil2) = Nil2"
  | "dropWhile x (Cons2 z xs) =
       (if x z then dropWhile x xs else Cons2 z xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster takeWhile dropWhile append *)
  theorem x0 :
    "(append (takeWhile p xs) (dropWhile p xs)) = xs"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Monotonicity\<close>
theory Transport_Compositions_Generic_Monotone
  imports
    Transport_Compositions_Generic_Base
begin

context transport_comp
begin

lemma mono_wrt_rel_leftI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and inflationary_unit2: "inflationary_on (in_codom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>) \<eta>\<^sub>2"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>))"
  and "in_codom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_codom (\<le>\<^bsub>L2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
proof (rule dep_mono_wrt_relI)
  fix x x' assume "x \<le>\<^bsub>L\<^esub> x'"
  then show "l x \<le>\<^bsub>R\<^esub> l x'"
  proof (rule right_rel_if_left_relI)
    fix y' assume "l1 x \<le>\<^bsub>L2\<^esub> y'"
    with \<open>((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2\<close> show "l x \<le>\<^bsub>R2\<^esub> l2 y'" by auto
  next
    assume "in_codom (\<le>\<^bsub>L2\<^esub>) (l1 x')"
    with inflationary_unit2 show "l1 x' \<le>\<^bsub>L2\<^esub> r2 (l x')" by auto
    from \<open>in_codom (\<le>\<^bsub>L2\<^esub>) (l1 x')\<close> \<open>((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2\<close>
      show "in_codom (\<le>\<^bsub>R2\<^esub>) (l x')" by auto
  qed (insert assms, auto)
qed

lemma mono_wrt_rel_leftI':
  assumes "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>L2\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and refl_L2: "reflexive_on (in_dom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>))"
  and "in_dom ((\<le>\<^bsub>R1\<^esub>) \<circ>\<circ> (\<le>\<^bsub>L2\<^esub>) \<circ>\<circ> (\<le>\<^bsub>R1\<^esub>)) \<le> in_dom (\<le>\<^bsub>L2\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
proof (rule dep_mono_wrt_relI)
  fix x x' assume "x \<le>\<^bsub>L\<^esub> x'"
  then show "l x \<le>\<^bsub>R\<^esub> l x'"
  proof (rule right_rel_if_left_relI')
    fix y' assume "y' \<le>\<^bsub>L2\<^esub> l1 x'"
    moreover with \<open>((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2\<close> have "l2 y' \<le>\<^bsub>R2\<^esub> l x'" by auto
    ultimately show "in_codom (\<le>\<^bsub>R2\<^esub>) (l x')" "y' \<le>\<^bsub>L2\<^esub> r2 (l x')"
      using \<open>((\<le>\<^bsub>L2\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2\<^esub>)) l2 r2\<close> by auto
  next
    assume "in_dom (\<le>\<^bsub>L2\<^esub>) (l1 x)"
    with refl_L2 \<open>((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2\<close> show "l x \<le>\<^bsub>R2\<^esub> l2 (l1 x)" by auto
  qed (insert assms, auto)
qed

end

end


theory "HOLCF-Fix-Join"
  imports "HOLCF-Set" "HOLCF-Join"
begin

subsubsection {* A carrier set for fixed points of binary joins *}

text {* @{term fix_join_compat} is a set in which the join operation is always defined, and can
serve as carrier sets for the various HOLCF-Set operations. *}

definition fix_join_compat where
  "fix_join_compat (\<rho>::'a::{Bounded_Nonempty_Meet_cpo,subpcpo_partition})  F = {\<rho>'. \<rho>' \<sqsubseteq> fix_on' (to_bot \<rho>) (\<lambda> \<rho>'. \<rho> \<squnion> F \<rho>')}"

lemma fjc_iff[iff]:
  "\<rho>' \<in> fix_join_compat \<rho> F \<longleftrightarrow> \<rho>' \<sqsubseteq> fix_on' (to_bot \<rho>) (\<lambda> \<rho>'. \<rho> \<squnion> F \<rho>')"
  unfolding fix_join_compat_def by auto

lemma subcpo_fjc: "subcpo (fix_join_compat \<rho> F)"
  unfolding fix_join_compat_def by (rule subcpo_cone_below)

lemma subpcpo_fjc: "subpcpo (fix_join_compat \<rho> F)"
  unfolding fix_join_compat_def by (rule subpcpo_cone_below)

lemma subpcpo_bot_fjc: "subpcpo_bot (fix_join_compat \<rho> F) (to_bot \<rho>)"
  apply (rule subpcpo_botI)
  apply (metis subcpo.cpo subcpo_fjc)
  apply (auto)
  by (metis to_bot_fix_on to_bot_minimal unrelated)

lemma bottom_of_fjc: "bottom_of (fix_join_compat \<rho> F) = to_bot \<rho>"
  by (rule bottom_of_subpcpo_bot[OF subpcpo_bot_fjc])

lemma down_closed_fjc: "\<And>x y. x \<in> fix_join_compat \<rho> F \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> y \<in> fix_join_compat \<rho> F"
  by (auto dest:below_trans)

lemma compat_fjc: "x \<in> fix_join_compat \<rho> F \<Longrightarrow> y \<in> fix_join_compat \<rho> F \<Longrightarrow> compatible x y"
  by (auto elim:ub_implies_compatible)

lemma join_fjc: "x \<in> fix_join_compat \<rho> F \<Longrightarrow> y \<in> fix_join_compat \<rho> F \<Longrightarrow> x \<squnion> y \<in> fix_join_compat \<rho> F"
  by (rule, metis join_below[OF compat_fjc] fjc_iff)

lemma closed_on_join_fjc: "closed_on (fix_join_compat \<rho> F) G \<Longrightarrow> closed_on (fix_join_compat \<rho> F) H \<Longrightarrow> closed_on (fix_join_compat \<rho> F) (\<lambda> x. G x \<squnion> H x)"
  apply (rule closed_onI)
  apply (rule join_fjc)
  apply (erule (1) closed_onE)+
  done

lemma cont_on_join_fjc:
  assumes "closed_on (fix_join_compat \<rho> F) G"
  assumes "closed_on (fix_join_compat \<rho> F) H"
  assumes "cont_on  (fix_join_compat \<rho> F) G"
  assumes "cont_on  (fix_join_compat \<rho> F) H"
  shows "cont_on (fix_join_compat \<rho> F) (\<lambda> x. G x \<squnion> H x)"
  proof(rule subpcpo.cont_onI2[OF subpcpo_fjc])
  case goal1
  show ?case
    proof(rule monofun_onI)
    case (goal1 x y)
      hence "compatible (G x) (H x)" and "compatible (G y) (H y)"
        by -(rule compat_fjc[OF closed_onE[OF assms(1)] closed_onE[OF assms(2)]], assumption+)+
      moreover
      from goal1
      have "G x \<sqsubseteq> G y"
        by (rule monofun_onE[OF cont_on2mono_on[OF assms(3)]])
      moreover
      from goal1
      have "H x \<sqsubseteq> H y"
        by (rule monofun_onE[OF cont_on2mono_on[OF assms(4)]])
      ultimately
      show ?case
        by (rule join_mono)
    qed
  next
  case (goal2 Y)
    have "G (\<Squnion> i. Y i) \<squnion> H (\<Squnion> i. Y i) = (\<Squnion> i. G (Y i)) \<squnion> (\<Squnion> i. H (Y i))"
      by (simp add: cont_on2contlubE[OF assms(3) goal2(1)]  cont_on2contlubE[OF assms(4) goal2(1)])
    also
    have "... = (\<Squnion> i. G (Y i) \<squnion> H (Y i))"
      apply (rule join_cont12)
      apply (rule chain_on_is_chain[OF ch2ch_cont_on'[OF assms(3) goal2(1) assms(1)]])
      apply (rule chain_on_is_chain[OF ch2ch_cont_on'[OF assms(4) goal2(1) assms(2)]])
      apply (rule compat_fjc[OF closed_onE[OF assms(1) chain_on_is_on[OF goal2(1)]] closed_onE[OF assms(2) chain_on_is_on[OF goal2(1)]]])
      done
   finally show ?case by (rule eq_imp_below)
qed

subsubsection {* Conditions for the existence of the fixed point of binary joins *}

inductive fix_join_cond
  where fix_join_condI:
  "cont F \<Longrightarrow>
   (\<And> i. compatible \<rho> (F (((\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>')^^i) (to_bot \<rho>)))) \<Longrightarrow> fix_join_cond \<rho> F "

context
  fixes \<rho> :: "'a::{Bounded_Nonempty_Meet_cpo,subpcpo_partition}" and S and F
  assumes "fix_join_cond \<rho> F"
begin
  lemma cont_F_fjc: "cont F"
    by (rule fix_join_cond.induct[OF `fix_join_cond _ _`])

  lemma chain_compat_fjc: "compatible \<rho> (F (((\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>')^^i) (to_bot \<rho>)))"
    by (rule fix_join_cond.induct[OF `fix_join_cond _ _`])

  lemma chain_fjc: "chain (\<lambda>i. ((\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>')^^i) (to_bot \<rho>))"
  proof(rule chainI, induct_tac i, simp_all)
    have "to_bot \<rho> \<sqsubseteq> \<rho>"
      by (rule to_bot_minimal)
    also have "\<rho> \<sqsubseteq> \<rho> \<squnion> F (to_bot \<rho>)"
      by (rule join_above1[OF chain_compat_fjc[of 0, simplified]])
    finally
    show "to_bot \<rho> \<sqsubseteq> \<rho> \<squnion> F (to_bot \<rho>)".

    fix n
    assume "((\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>') ^^ n) (to_bot \<rho>) \<sqsubseteq> \<rho> \<squnion> F (((\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>') ^^ n) (to_bot \<rho>))"
    thus "\<rho> \<squnion> F (((\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>') ^^ n) (to_bot \<rho>)) \<sqsubseteq> \<rho> \<squnion> F (\<rho> \<squnion> F (((\<lambda>\<rho>'. \<rho> \<squnion> F \<rho>') ^^ n) (to_bot \<rho>)))"
      by (rule join_mono[OF chain_compat_fjc chain_compat_fjc[of "Suc n", simplified] below_refl cont2monofunE[OF `cont F`]])
  qed

  lemma rho_fjc: "\<rho> \<in> fix_join_compat \<rho> F"
    apply auto
    apply (subst fix_on_def, subst if_P[OF chain_fjc])
    apply (rule below_trans[OF _ is_ub_thelub[of _ 1, OF chain_fjc]])
    apply (simp del: funpow.simps(1))
    apply (rule join_above1)
    apply (rule fix_join_cond.induct[OF `fix_join_cond _ _`])
    apply assumption
    done

  lemma F_pres_compat'': "x \<in> fix_join_compat \<rho> F \<Longrightarrow> F x \<in> fix_join_compat \<rho> F"
    apply auto
    apply (drule cont2monofunE[OF cont_F_fjc])
    apply (erule below_trans)
    apply (subst (1 2) fix_on_def, subst (1 2) if_P[OF chain_fjc])
    apply (subst cont2contlubE[OF cont_F_fjc chain_fjc])
    apply (subst lub_range_shift[symmetric, OF chain_fjc, of 1])
    apply (rule lub_mono[OF ch2ch_cont[OF cont_F_fjc chain_fjc] chain_shift[OF chain_fjc]])
    apply simp
    apply (rule join_above2[OF chain_compat_fjc])
    done

  lemma rho_F_compat_fjc: "x \<in> fix_join_compat \<rho> F \<Longrightarrow> compatible \<rho> (F x)"
    by (rule compat_fjc[OF rho_fjc F_pres_compat''])

  lemma F_closed_on_fjc: "closed_on (fix_join_compat \<rho> F) F"
    by (rule, rule F_pres_compat'')

  lemma closed_fjc: "x \<in> fix_join_compat \<rho> F \<Longrightarrow> \<rho> \<squnion> F x \<in> fix_join_compat \<rho> F"
    by (metis F_pres_compat'' rho_fjc join_fjc)

  lemma closed_on_fjc: "closed_on (fix_join_compat \<rho> F) (\<lambda> x. \<rho> \<squnion> F x)"
    by (rule closed_onI, rule closed_fjc)

  lemma cont_on_fjc: "cont_on (fix_join_compat \<rho> F) (\<lambda> x. \<rho> \<squnion> F x)"
    by (rule cont_on_join_fjc[OF const_closed_on[OF rho_fjc] F_closed_on_fjc cont_is_cont_on[OF cont_const] cont_is_cont_on[OF `cont F`]])

  lemma fix_on_cond_fjc:
    "fix_on_cond (fix_join_compat \<rho> F) (bottom_of (fix_join_compat \<rho> F)) (\<lambda>x. \<rho> \<squnion> F x)"
    apply (subst bottom_of_fjc)
    by (rule fix_on_condI[OF subpcpo_fjc bottom_of_fjc closed_on_fjc cont_on_fjc])

  lemma fix_on_fjc_ind:
    assumes "adm_on (fix_join_compat \<rho> F) P"
    assumes "P (bottom_of (fix_join_compat \<rho> F))"
    assumes "\<And> y. y \<in> fix_join_compat \<rho> F \<Longrightarrow> P y \<Longrightarrow> P (\<rho> \<squnion> F y)"
    shows "P (fix_on (fix_join_compat \<rho> F) (\<lambda> x. \<rho> \<squnion> F x))"
      by (rule fix_on_ind[OF fix_on_cond_fjc assms])

  lemma fix_on_fjc_eq:
    shows "fix_on (fix_join_compat \<rho> F) (\<lambda> x. \<rho> \<squnion> F x) = \<rho> \<squnion> F (fix_on (fix_join_compat \<rho> F) (\<lambda> x. \<rho> \<squnion> F x))"
    by (rule fix_on_eq[OF fix_on_cond_fjc])
end

subsubsection {* Continutiy of the fixed point of joins *}

lemma fix_on_join_cont_general:
  fixes F :: "'a::Bounded_Nonempty_Meet_cpo \<Rightarrow> 'a"
  assumes "subpcpo S'"
  assumes pcpo_i: "\<And> i. subpcpo (S i)"
  assumes down_closed: "\<And>x y. x \<in> S' \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> y \<in> S'"
  assumes same_bottoms: "\<And> i j. bottom_of (S i) = bottom_of (S j)"
  assumes same_bottoms'[simp]: "\<And> i. bottom_of (S i) = bottom_of S'"
  assumes "chain Y"
  assumes "cont F"
  assumes compat: "\<And> i x. x \<in> S i \<Longrightarrow> compatible (Y i) (F x)"
  assumes compat': "\<And> x. x \<in> S' \<Longrightarrow> compatible (\<Squnion> i. Y i) (F x)"
  assumes cl: "\<And> i. closed_on (S i) (\<lambda>x. Y i \<squnion> F x)"
  assumes cl': "\<And> i. closed_on S' (\<lambda>x. (\<Squnion>i. Y i) \<squnion> F x)"

  shows "fix_on S' (\<lambda> x. (\<Squnion>i. Y i) \<squnion> F x) = (\<Squnion> i. (fix_on (S i) (\<lambda> x. Y i \<squnion> F x)))"
    (is "fix_on _ _ = Lub ?F")
proof-
  interpret subpcpo S' by fact

  have coF: "cont_on S' F" by (rule cont_is_cont_on[OF `cont F`])

  have co: "\<And> i. cont_on (S i) (\<lambda>x. Y i \<squnion> F x)"
  proof(rule subpcpo.cont_onI2[OF pcpo_i])
  case goal1 show ?case
    by (rule monofun_onI, erule (2) join_mono[OF compat compat below_refl cont2monofunE[OF `cont F`]])
  next
  case (goal2 i Y)
    hence "chain Y" by (metis chain_on_is_chain)
    show ?case
      apply (rule subst[OF cont2contlubE[OF `cont F` `chain Y`, symmetric]])
      apply (subst join_cont2[OF ch2ch_cont[OF `cont F` `chain Y`] compat[OF chain_on_is_on[OF goal2(1)]]])
      apply (rule below_refl)
    done
  qed

  have co': "cont_on S' (\<lambda>x. (\<Squnion> i. Y i) \<squnion> F x)"
  proof(rule cont_onI2)
  case goal1 show ?case
    by (rule monofun_onI, rule join_mono[OF compat' compat' below_refl cont2monofunE[OF `cont F`]])
  next
  case (goal2 Y)
    hence "chain Y" by (metis chain_on_is_chain)
    show ?case
      apply (rule subst[OF cont2contlubE[OF `cont F` `chain Y`, symmetric]])
      apply (subst join_cont2[OF ch2ch_cont[OF `cont F` `chain Y`] compat'[OF chain_on_is_on[OF goal2(1)]]])
      apply (rule below_refl)
    done
  qed

  have foc': "fix_on_cond S' (bottom_of S') (\<lambda>x. (\<Squnion>i. Y i) \<squnion> F x)"
    by (rule fix_on_condI[OF subpcpo_axioms refl cl' co'])
  have foc: "\<And> i. fix_on_cond (S i) (bottom_of (S i)) (\<lambda>x. Y i \<squnion> F x)"
    by (rule fix_on_condI[OF pcpo_i refl cl co])

  { fix i j
    have  "compatible (Y j) (F (?F i))"
    proof(cases "i \<le> j")
    case True show ?thesis
      apply (rule compatible_down_closed2)
      apply (rule compat[OF fix_on_there[OF foc]])
      apply (rule cont2monofunE[OF `cont F`])
      apply (rule fix_on_mono2[OF foc foc eq_imp_below[OF same_bottoms]])
      apply (erule (2) join_mono[OF compat compat chain_mono[OF `chain Y` True] cont2monofunE[OF `cont F`] ])
      done
   next
   case False
     hence "j \<le> i" by (metis nat_le_linear)
     thus ?thesis
       by (rule compatible_down_closed[OF compat[OF fix_on_there[OF foc]] chain_mono[OF `chain Y`]])
   qed
  } note compat'' = this

  have  "fix_on S' (\<lambda>x. (Lub Y) \<squnion> F x) \<in> S'"
    by (rule fix_on_there[OF foc'])
  moreover
  have "\<And> i. fix_on (S i) (\<lambda>x. Y i \<squnion> F x) \<sqsubseteq> fix_on S' (\<lambda>x. (Lub Y) \<squnion> F x)"
    apply (rule fix_on_mono2[OF foc foc'])
    apply simp
    apply (erule (2) join_mono[OF
        compat
        compat'
        is_ub_thelub[OF `chain Y`]
        cont2monofunE[OF `cont F`]])
    done
  ultimately
  have F_in_S: "\<And> i. fix_on (S i) (\<lambda>x. Y i \<squnion> F x) \<in> S'"
    by (rule down_closed)

  have chF: "chain ?F"
    apply (rule chainI)
    apply (rule fix_on_mono2[OF foc foc])
    apply simp
    by (rule join_mono[OF compat compat chainE[OF `chain Y`] cont2monofunE[OF `cont F`]])
  have cho: "chain_on S' ?F"
    apply (rule chain_onI[OF _ F_in_S])
    apply (rule chainE[OF chF])
    done

  have c1: "\<And> j. chain (\<lambda>i. Y i \<squnion> F (?F j))"
    by (rule chainI, rule join_mono[OF compat'' compat'' chainE[OF `chain Y`] below_refl])
  have c2: "\<And> i. chain (\<lambda>j. Y i \<squnion> F (?F j))"
    by (rule chainI, rule join_mono[OF compat'' compat'' below_refl cont2monofunE[OF `cont F` chainE[OF chF]]])
  have c3: "chain (\<lambda>i. F (?F i))"
    by (rule ch2ch_cont[OF `cont F` chF])

  have "(\<Squnion> i. ?F i) \<in> S'"
    by (rule chain_on_lub_on[OF cho])
  moreover
  {
  have "(\<Squnion> i. Y i) \<squnion> F (\<Squnion> i. fix_on (S i) (\<lambda>x. Y i \<squnion> F x))
    = (\<Squnion> i. Y i) \<squnion> (\<Squnion> i. F (fix_on (S i) (\<lambda>x. Y i \<squnion> F x)))"
    by (subst cont_on2contlubE[OF coF cho], rule)
  also have " ... = (\<Squnion> i. Y i \<squnion> (\<Squnion> i. F (fix_on (S i) (\<lambda>x. Y i \<squnion> F x))))"
    by (rule join_cont1[OF `chain Y` admD[OF compatible_adm2 c3 compat'']])
  also have " ... = (\<Squnion> i j. Y i \<squnion> F (fix_on (S j) (\<lambda>x. Y j \<squnion> F x)))"
    by (subst join_cont2[OF c3 compat''], rule)
  also have " ... = (\<Squnion> i. Y i \<squnion> F (fix_on (S i) (\<lambda>x. Y i \<squnion> F x)))"
    by (rule diag_lub[OF c1 c2])
  also have " ... = (\<Squnion> i. fix_on (S i) (\<lambda>x. Y i \<squnion> F x))"
    by (subst fix_on_eq[symmetric, OF foc], rule)
  also note calculation
  }
  hence "(\<Squnion> i. Y i) \<squnion> F (\<Squnion> i. fix_on (S i) (\<lambda>x. Y i \<squnion> F x)) \<sqsubseteq> (\<Squnion> i. fix_on (S i) (\<lambda>x. Y i \<squnion> F x))"
    by (rule eq_imp_below)
  ultimately
  have "fix_on S' (\<lambda> x. (\<Squnion>i. Y i) \<squnion> F x) \<sqsubseteq> (\<Squnion> i. (fix_on (S i) (\<lambda> x. Y i \<squnion> F x)))"
    by (rule fix_on_least_below[OF foc'])
  moreover
  have  "(\<Squnion> i. (fix_on (S i) (\<lambda> x. Y i \<squnion> F x))) \<sqsubseteq> fix_on S' (\<lambda> x. (\<Squnion>i. Y i) \<squnion> F x)"
  proof (rule lub_below[OF chF])
    fix i
    show "(fix_on (S i) (\<lambda> x. Y i \<squnion> F x)) \<sqsubseteq> fix_on S' (\<lambda> x. (\<Squnion>i. Y i) \<squnion> F x)"
      apply (rule fix_on_mono2[OF foc foc' eq_imp_below[OF same_bottoms']])
      by (rule join_mono[OF compat compat' is_ub_thelub[OF `chain Y`] cont2monofunE[OF `cont F`]])
  qed
  finally
  show ?thesis.
qed

lemma fix_on_join_cont:
  fixes Y :: "nat \<Rightarrow> 'a::{Bounded_Nonempty_Meet_cpo, subpcpo_partition}"
  assumes "chain Y"
  assumes focj: "\<And>i. fix_join_cond (Y i) F"
  assumes focj': "fix_join_cond (\<Squnion> i. Y i) F"

  shows "fix_on (fix_join_compat (\<Squnion> i. Y i) F) (\<lambda> x. (\<Squnion>i. Y i) \<squnion> F x) = (\<Squnion> i. (fix_on (fix_join_compat (Y i) F) (\<lambda> x. Y i \<squnion> F x)))"
proof(rule fix_on_join_cont_general)
  fix i
  show "\<And> j. bottom_of (fix_join_compat (Y i) F) = bottom_of (fix_join_compat (Y j) F)"
    apply (simp add: bottom_of_fjc)
    by (metis linorder_linear unrelated[OF chain_mono[OF `chain Y`]])
  next
  fix i
  show "bottom_of (fix_join_compat (Y i) F) = bottom_of (fix_join_compat (\<Squnion> i. Y i) F)"
    apply (simp add: bottom_of_fjc)
    by (rule unrelated[OF is_ub_thelub[OF `chain Y`]])
  next
  show "cont F"
    by (rule cont_F_fjc[OF focj])
  next
  fix i x
  assume "x \<in> fix_join_compat (Y i) F"
  thus "compatible (Y i) (F x)"
    by (rule rho_F_compat_fjc[OF focj])
  next
  fix x
  assume "x \<in> fix_join_compat (\<Squnion> i. Y i) F"
  thus "compatible (\<Squnion> i. Y i) (F x)"
    by (rule rho_F_compat_fjc[OF focj'])
  next
  fix i
  show "closed_on (fix_join_compat (Y i) F) (\<lambda>x. Y i \<squnion> F x)"
    by (rule closed_on_fjc[OF focj])
  next
  fix i
  show "closed_on (fix_join_compat (\<Squnion> i. Y i) F) (\<lambda>x. (\<Squnion> i. Y i) \<squnion> F x)"
    by (rule closed_on_fjc[OF focj'])
  next
  fix x y
  assume "x \<in> fix_join_compat (\<Squnion> i. Y i) F" and "y \<sqsubseteq> x"
  thus "y \<in> fix_join_compat (\<Squnion> i. Y i) F"
    by (rule down_closed_fjc)
qed (intro subpcpo_fjc  rho_F_compat_fjc closed_on_fjc assms)+

end


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

section{*The Otway-Rees Protocol: The Faulty BAN Version*}

theory OtwayRees_Bad imports Public begin

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

This file illustrates the consequences of such errors.  We can still prove
impressive-looking properties such as @{text Spy_not_see_encrypted_key}, yet
the protocol is open to a middleperson attack.  Attempting to prove some key
lemmas indicates the possibility of this attack.*}

inductive_set otway :: "event list set"
  where
   Nil: --{*The empty trace*}
        "[] \<in> otway"

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

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

 | OR1:  --{*Alice initiates a protocol run*}
         "[| evs1 \<in> otway;  Nonce NA \<notin> used evs1 |]
          ==> Says A B {|Nonce NA, Agent A, Agent B,
                         Crypt (shrK A) {|Nonce NA, Agent A, Agent B|} |}
                 # evs1 \<in> otway"

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

 | OR3:  --{*The Server receives Bob's message and checks that the three NAs
           match.  Then he sends a new session key to Bob with a packet for
           forwarding to Alice.*}
         "[| evs3 \<in> otway;  Key KAB \<notin> used evs3;
             Gets Server
                  {|Nonce NA, Agent A, Agent B,
                    Crypt (shrK A) {|Nonce NA, Agent A, Agent B|},
                    Nonce NB,
                    Crypt (shrK B) {|Nonce NA, Agent A, Agent B|}|}
               \<in> set evs3 |]
          ==> Says Server B
                  {|Nonce NA,
                    Crypt (shrK A) {|Nonce NA, Key KAB|},
                    Crypt (shrK B) {|Nonce NB, Key KAB|}|}
                 # evs3 \<in> otway"

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

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

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

text{*A "possibility property": there are traces that reach the end*}
lemma "[| B \<noteq> Server; Key K \<notin> used [] |]
      ==> \<exists>NA. \<exists>evs \<in> otway.
            Says B A {|Nonce NA, Crypt (shrK A) {|Nonce NA, Key K|}|}
              \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] otway.Nil
                    [THEN otway.OR1, THEN otway.Reception,
                     THEN otway.OR2, THEN otway.Reception,
                     THEN otway.OR3, THEN otway.Reception, THEN otway.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says [dest!]:
     "[| Gets B X \<in> set evs; evs \<in> otway |] ==> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

subsection{*For reasoning about the encrypted portion of messages *}

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

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

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

text{*Forwarding lemma: see comments in OtwayRees.thy*}
lemmas OR2_parts_knows_Spy =
    OR2_analz_knows_Spy [THEN analz_into_parts]

text{*Theorems of the form @{term "X \<notin> parts (spies evs)"} imply that
NOBODY sends messages containing X! *}

text{*Spy never sees a good agent's shared key!*}
lemma Spy_see_shrK [simp]:
     "evs \<in> otway ==> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> otway ==> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

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

subsection{*Proofs involving analz *}

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

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

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
  Key K \<in> analz (knows Spy evs)

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

text{*Session keys are not used to encrypt other session keys*}

text{*The equality makes the induction hypothesis easier to apply*}
lemma analz_image_freshK [rule_format]:
 "evs \<in> otway ==>
   \<forall>K KK. KK <= -(range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule otway.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] OR4_analz_knows_Spy)
apply (drule_tac [5] OR2_analz_knows_Spy, analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
  "[| evs \<in> otway;  KAB \<notin> range shrK |] ==>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text{*The Key K uniquely identifies the Server's  message. *}
lemma unique_session_keys:
     "[| Says Server B {|NA, X, Crypt (shrK B) {|NB, K|}|}   \<in> set evs;
         Says Server B' {|NA',X',Crypt (shrK B') {|NB',K|}|} \<in> set evs;
         evs \<in> otway |] ==> X=X' & B=B' & NA=NA' & NB=NB'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
apply blast+  --{*OR3 and OR4*}
done

text{*Crucial secrecy property: Spy does not see the keys sent in msg OR3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having @{term "A=Spy"} *}
lemma secrecy_lemma:
 "[| A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
  ==> Says Server B
        {|NA, Crypt (shrK A) {|NA, Key K|},
          Crypt (shrK B) {|NB, Key K|}|} \<in> set evs -->
      Notes Spy {|NA, NB, Key K|} \<notin> set evs -->
      Key K \<notin> analz (knows Spy evs)"
apply (erule otway.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (drule_tac [6] OR4_analz_knows_Spy)
apply (drule_tac [4] OR2_analz_knows_Spy)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes)
apply spy_analz  --{*Fake*}
apply (blast dest: unique_session_keys)+  --{*OR3, OR4, Oops*}
done

lemma Spy_not_see_encrypted_key:
     "[| Says Server B
          {|NA, Crypt (shrK A) {|NA, Key K|},
                Crypt (shrK B) {|NB, Key K|}|} \<in> set evs;
         Notes Spy {|NA, NB, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: Says_Server_message_form secrecy_lemma)

subsection{*Attempting to prove stronger properties *}

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

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

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

end