theory Auditors
  imports Main
begin

datatype status = busy | available

datatype auditor = auditor (firstName: string)
                           (secondName:string)
                           (currentStatus:status)

definition knowCurrentStatus :: "auditor \<Rightarrow> status" where
          "knowCurrentStatus x = currentStatus x"

fun removAuditor :: "status \<Rightarrow> auditor list \<Rightarrow> auditor list" where
   "removAuditor x [] = []" |
   "removAuditor x (y#ys) = (if x = knowCurrentStatus y then removAuditor x ys
                          else y#(removAuditor x ys))"

fun contains :: "auditor list \<Rightarrow> status \<Rightarrow> bool" where
"contains [] _ = False" |
"contains (x#xs) y = (if knowCurrentStatus x = y then True else contains xs y)"

fun LengthAcc :: "auditor list  \<Rightarrow> status \<Rightarrow> nat \<Rightarrow> nat" where
"LengthAcc [] _ n = n" |
"LengthAcc (x#xs) y n = (if knowCurrentStatus x = y then LengthAcc xs y (n+1) else LengthAcc xs y n)"

fun auditorLength :: "auditor list \<Rightarrow> status \<Rightarrow> nat" where
"auditorLength xs y =  LengthAcc xs y 0"

lemma first_lemma: "\<not>(contains(removAuditor a b) a)"
  nitpick
  sorry

lemma second_lemma: "(auditorLength b a) = (auditorLength(removAuditor a b)a) + (auditorLength b a)"
  nitpick
  apply (induct b)
  apply simp
  by auto

lemma last_lemma:
  "(removAuditor a b) = (removAuditor a b) \<longrightarrow> \<not>(contains (removAuditor a b) a)"
  nitpick
  apply(induct b)
   apply simp
proof -
  fix aa :: auditor and ba :: "auditor list"
  assume "removAuditor a ba = removAuditor a ba \<longrightarrow> \<not> contains (removAuditor a ba) a"
  then have "\<not> contains (removAuditor a ba) a"
    by meson
  then show "removAuditor a (aa # ba) = removAuditor a (aa # ba) \<longrightarrow> \<not> contains (removAuditor a (aa # ba)) a"
    using contains.simps(2) removAuditor.simps(2) by presburger
qed
end

(*
value "removAuditor busy [
(auditor ''Mx'' ''Koxnan'' busy),
(auditor ''Lawrence'' ''Muggerod'' available),
(auditor ''Mikae'' ''Konan'' busy)
]"

value "auditorLength (removAuditor busy [
(auditor ''Mx'' ''Koxnan'' available),
(auditor ''Lawrence'' ''Muggerod'' available),
(auditor ''Mikae'' ''Konan'' busy
)
]) busy"
value "(auditorLength [
(auditor ''Mx'' ''Koxnan'' available),
(auditor ''Lawrence'' ''Muggerod'' available),
(auditor ''Mikae'' ''Konan'' busy
)
]) busy"

value "auditorLength (removAuditor busy [
(auditor ''Mx'' ''Koxnan'' available),
(auditor ''Lawrence'' ''Muggerod'' available),
(auditor ''Mikae'' ''Konan'' busy
)
]) busy"

value "countAuditor (removAuditor busy [
(auditor ''Mx'' ''Koxnan'' available),
(auditor ''Lawrence'' ''Muggerod'' available),
(auditor ''Mikae'' ''Konan'' busy
)
]) "
 *)


theory mi16100_Dara_Milojkovic
  imports Complex_Main
begin

text\<open>
https://imomath.com/srb/zadaci/BIH_2014_bihmo_resenja.pdf
Resavamo zadatak: Neka su a, b, c razliciti realni brojevi.
I) Izracunati vrednost izraza
  a) ((1+a*b) / (a-b)) * ((1+b*c)/(b-c)) + ((1+b*c) / (b-c)) * ((1+c*a)/(c-a)) + ((1+c*a) / (c-a)) * ((1+a*b)/(a-b))
  b) ((1-a*b) / (a-b)) * ((1-b*c)/(b-c)) + ((1-b*c) / (b-c)) * ((1-c*a)/(c-a)) + ((1-c*a) / (c-a)) * ((1-a*b)/(a-b))
II) Dokazati nejednakost
  (1+a^2*b^2)/(a-b)^2 + (1+b^2*c^2)/(b-c)^2 +  (1+c^2*a^2)/(c-a)^2 \<ge> (3::real) / (2::real)
 Da li moze nastupiti znak jednakosti?
\<close>

(*Pravimo funkcije koje izracunavaju vrednost izraza sa nekim izabranim brojevima*)
fun racunanjeIzrazaA::"real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
"racunanjeIzrazaA a b c = ((1+a*b) / (a-b)) * ((1+b*c)/(b-c)) + ((1+b*c) / (b-c)) * ((1+c*a)/(c-a)) + ((1+c*a) / (c-a)) * ((1+a*b)/(a-b))"

fun racunanjeIzrazaB::"real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
"racunanjeIzrazaB a b c = ((1-a*b) / (a-b)) * ((1-b*c)/(b-c)) + ((1-b*c) / (b-c)) * ((1-c*a)/(c-a)) + ((1-c*a) / (c-a)) * ((1-a*b)/(a-b))"

(*Proveravamo koja je vrednost koji vracaju i dobijamo za razlicite brojeve 1 (-1) a za iste brojeve 0*)
value "racunanjeIzrazaA 1 2 3"

value "racunanjeIzrazaB 1 2 3"

(*sledece dve teoreme pokazuju da ako su a b c isti funkcije vracaju 0 jer Isabelle vraca 0 kad se deli sa 0*)

lemma shows "\<forall> a b c::real. a=b \<and> b=c \<and> a=c \<longrightarrow> racunanjeIzrazaB a b c = 0"
  by auto

(*sledece dve teoreme pokazuju da za svako a b c koji su medjusobno razliciti funkcije vracaju 1 odnosno -1*)
lemma shows "\<forall> a b c::real. a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c \<longrightarrow> racunanjeIzrazaA a b c = 1"
  sorry

lemma shows "\<forall> a b c::real. a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c \<longrightarrow> racunanjeIzrazaB a b c = (-1)"
  sorry
(*zadatak pod b). Postoje neki brojevi a b c za koje ce ova nejednakost biti tacna*)
lemma
  fixes a b c::real
  assumes "a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c"
  shows " (1+a\<^sup>2*b\<^sup>2)/(a-b)\<^sup>2 + (1+b\<^sup>2*c\<^sup>2)/(b-c)\<^sup>2 +  (1+c\<^sup>2*a\<^sup>2)/(c-a)\<^sup>2 \<ge> (3::real) / (2::real)"
  using assms
  sorry

(*postavlja se pitanje da li se moze umesto znaka \<ge> staviti znak jednakosti? Isabelle je mogao ovo da dokaze te je odgovor da.*)
lemma
  shows "\<exists> a b c::real. a\<noteq>b \<and> a\<noteq>c \<and> b\<noteq>c \<longrightarrow> (1+a\<^sup>2*b\<^sup>2)/(a-b)\<^sup>2 + (1+b\<^sup>2*c\<^sup>2)/(b-c)\<^sup>2 +  (1+c\<^sup>2*a\<^sup>2)/(c-a)\<^sup>2 =(3::real) / (2::real)"
  by blast

text\<open>
Drugi seminarski: dokazati sledece teoreme/leme.
1. Definisemo koren kompleksnog broja
2. Dokazati da kvadrirani koren kompleksnog broja taj isti kompleksan broj
3. Pokazujemo da postoji neki kompleksan broj s koji pomnozen samim sobom daje neki drugi kompleksan broj z
4. Iz prethodne leme pokazujemo da je taj kompleksan broj s bas koren broja z
5. Koren proizvoda dva kompleksna broja je proizvod korena dva kompleksna broja
6. Pravi se paralela izmedju kvadratne jednacine realnih brojeva i kvadratne jednacine kompleksnih brojeva
\<close>

definition "ccsqrt z = rcis (sqrt (cmod z)) (arg z / 2)"

(*ideja se oslanja na osobinu da su dva kompleksna broja jednaka ako su
im jednaki realni deo i imaginarni deo*)
lemma square_ccsqrt [simp]:
  shows "(ccsqrt x)\<^sup>2 = x"
proof
  show "Re ((ccsqrt x)\<^sup>2) = Re x"
  proof-
    have "Re ((ccsqrt x)\<^sup>2) = Re (ccsqrt x * ccsqrt x)"
      by (simp add: power2_eq_square)
    also have "... = Re ((rcis (sqrt (cmod x)) (arg x / 2)) * (rcis (sqrt (cmod x)) (arg x / 2)))"
      using ccsqrt_def by presburger
    also have "... = Re (rcis (sqrt (cmod x) * sqrt (cmod x)) (arg x / 2 + arg x / 2))"
      using rcis_mult by presburger
    also have "... = Re (rcis (cmod x) (arg x))"
      by (metis abs_norm_cancel field_sum_of_halves real_sqrt_mult_self)
    also have "... = Re x"
      using rcis_cmod_arg by presburger
    finally show ?thesis .
  qed
next
  show "Im ((ccsqrt x)\<^sup>2) = Im x"
  proof-
    have "Im ((ccsqrt x)\<^sup>2) = Im (ccsqrt x * ccsqrt x)"
      by (simp add: power2_eq_square)
    also have "... = Im ((rcis (sqrt (cmod x)) (arg x / 2)) * (rcis (sqrt (cmod x)) (arg x / 2)))"
      using ccsqrt_def by presburger
    also have "... = Im (rcis (sqrt (cmod x) * sqrt (cmod x)) (arg x / 2 + arg x / 2))"
      using rcis_mult by presburger
    also have "... = Im (rcis (cmod x) (arg x))"
      by (metis abs_norm_cancel field_sum_of_halves real_sqrt_mult_self)
    also have "... = Im x"
      using rcis_cmod_arg by presburger
    finally show ?thesis .
  qed
qed
(*ista ideja se primenjuje i ovde*)
lemma ex_complex_sqrt [simp]:
  shows "\<exists> s::complex. s*s = z"
  apply (rule_tac x = "ccsqrt z" in exI)
proof
  show "Re (ccsqrt z * ccsqrt z) = Re z"
  proof-
    have "Re (ccsqrt z * ccsqrt z) = Re ((rcis (sqrt (cmod z)) (arg z / 2)) * (rcis (sqrt (cmod z)) (arg z / 2)))"
      using ccsqrt_def by presburger
    also have "... = Re (rcis (sqrt (cmod z) * sqrt (cmod z)) (arg z /2 + arg z / 2))"
      using rcis_mult by presburger
    also have "... = Re (rcis (cmod z) (arg z))"
    by (metis ccsqrt_def power2_eq_square rcis_cmod_arg rcis_mult square_ccsqrt)
  also have "... = Re z"
    using rcis_cmod_arg by presburger
  finally show ?thesis .
  qed
next
  show "Im (ccsqrt z * ccsqrt z) = Im z"
  proof-
    have "Im (ccsqrt z * ccsqrt z) = Im ((rcis (sqrt (cmod z)) (arg z / 2)) * (rcis (sqrt (cmod z)) (arg z / 2)))"
      using ccsqrt_def by presburger
    also have "... = Im (rcis (sqrt (cmod z) * sqrt (cmod z)) (arg z /2 + arg z / 2))"
      using rcis_mult by presburger
    also have "... = Im (rcis (cmod z) (arg z))"
    by (metis ccsqrt_def power2_eq_square rcis_cmod_arg rcis_mult square_ccsqrt)
  also have "... = Im z"
    using rcis_cmod_arg by presburger
  finally show ?thesis .
  qed
qed

lemma ccsqrt [simp]:
  assumes "s*s = z"
  shows "s = ccsqrt z \<or> s = -ccsqrt z"
proof-
  have "s\<^sup>2 = s*s"
    by (simp add: power2_eq_square)
  then have "... = z"
    using assms
    by simp
  then have "... = ccsqrt z * ccsqrt z"
    by (metis power2_eq_square square_ccsqrt)
  then have "... = (ccsqrt z)\<^sup>2"
    by auto
  then have "s\<^sup>2 = (ccsqrt z)\<^sup>2"
    using \<open>s\<^sup>2 = s * s\<close> assms by auto
  then have "s = ccsqrt z \<or> s = -ccsqrt z"
    using power2_eq_iff by blast
  then show ?thesis.
qed

lemma ccsqrt_mult [simp]:
  shows  "ccsqrt (a*b) = ccsqrt a * ccsqrt b \<or> ccsqrt (a*b) = - ccsqrt a * ccsqrt b"
proof -
  have "(ccsqrt (a*b))^2 = a*b"
  by simp
  then have "a * b = (ccsqrt a * ccsqrt a) * (ccsqrt b * ccsqrt b)"
    by (metis power2_eq_square square_ccsqrt)
  then have "... = (ccsqrt a * ccsqrt b)*(ccsqrt a * ccsqrt b)"
    by simp
  then have "... = (ccsqrt a * ccsqrt b)^2"
    by (simp add: semiring_normalization_rules(29))
  then have "(ccsqrt (a*b))\<^sup>2 = (ccsqrt a * ccsqrt b)\<^sup>2"
  by (simp add: \<open>a * b = ccsqrt a * ccsqrt a * (ccsqrt b * ccsqrt b)\<close> \<open>ccsqrt a * ccsqrt a * (ccsqrt b * ccsqrt b) = ccsqrt a * ccsqrt b * (ccsqrt a * ccsqrt b)\<close>)
  then have "ccsqrt (a*b) = ccsqrt a * ccsqrt b \<or> ccsqrt (a*b) = - ccsqrt a * ccsqrt b"
    using power2_eq_iff by fastforce
  then show ?thesis.
qed

(*neke pomocne leme za resavanje izraza*)
lemma pomocna [simp]:
  fixes a b :: complex
  shows "(a/b)\<^sup>2 = a\<^sup>2 / b\<^sup>2"
  by (simp add: power_divide)

lemma pomocna1 [simp]:
  fixes a b ::complex
  shows "(a - b)\<^sup>2 = a\<^sup>2 - 2*a*b + b\<^sup>2"
  by (simp add: power2_diff)

lemma pomocna2 [simp]:
  fixes a b::complex
  shows "(a*b\<^sup>2)/(4*a\<^sup>2) = b\<^sup>2 / (4*a) "
  by (simp add: power2_eq_square)

lemma pomocna3 [simp]:
  fixes a b c::complex
  shows "(a*2*b*c) / (4*a\<^sup>2) = (b*c) / (2*a)"
proof-
  have "(a*2*b*c) / (4*a\<^sup>2) = (2*a*b*c) / (4*a\<^sup>2)"
    by auto
  also have "... = (2*a)*(b*c) / (2*a)\<^sup>2"
    by auto
  finally show ?thesis
    by (simp add: power2_eq_square)
qed

lemma pomocna4 [simp]:
  fixes a b::complex
  assumes "a\<noteq>0"
  shows " - (4*a*b) / (4*a) = -b"
  using assms by auto

lemma pomocna5 [simp]:
  fixes a b:: complex
  shows "(-a+b)\<^sup>2 = a\<^sup>2 - 2*a*b + b\<^sup>2"
  by auto

lemma pomocna6 [simp]:
  fixes a b::complex
  shows "(-a-b)\<^sup>2 = a\<^sup>2 + 2*a*b + b\<^sup>2"
  by simp

(*dodala sam pretpostavku da je a razlicito od nule kako bi moglo da se deli sa a*)
lemma quadratic_equation_complex:
  fixes a b c x :: complex
  assumes "a \<noteq> 0"
  shows "a*x\<^sup>2+b*x+c=0 \<longleftrightarrow> x = (-b + ccsqrt (b\<^sup>2-4*a*c)) / (2*a) \<or> x = (-b - ccsqrt (b\<^sup>2 - 4*a*c)) / (2*a)"
proof
  assume "x = (- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> x = (- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)"
  show "a*x\<^sup>2 + b*x+c=0"
  proof-
    have "a*x\<^sup>2 + b*x+c=a* ((- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a))\<^sup>2 + b * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c   \<or> a*x\<^sup>2 + b*x+c= a* ((- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a))\<^sup>2 + b * ((- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c "
      using \<open>x = (- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> x = (- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> by blast
    then have "a*x\<^sup>2 + b*x+c = a * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2*a)\<^sup>2) +  b * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c \<or> a*x\<^sup>2 + b*x+c = a* ((- b - ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2 * a)\<^sup>2) + b * ((- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c "
      by simp
    then have "a*x\<^sup>2 + b*x+c = a * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2*a)\<^sup>2) +  (b*(- b + ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=a * ((- b - ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2*a)\<^sup>2) +  (b*(- b - ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c "
      by simp
    then have "a*x\<^sup>2 + b*x+c = a * ((b\<^sup>2-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2) / (4*a\<^sup>2)) +  (b*(- b + ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=a * ((b\<^sup>2 + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2)/(4*a\<^sup>2)) +  (b*(- b - ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c "
      by auto
    then have "a*x\<^sup>2 + b*x+c = a * ((b\<^sup>2-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c)) / (4*a\<^sup>2)) +  (-b\<^sup>2 + b*ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=a * ((b\<^sup>2 + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c))/(4*a\<^sup>2)) +  (- b\<^sup>2 - b*ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) + c "
      by (smt diff_0 mult_zero_right power2_eq_square right_diff_distrib square_ccsqrt uminus_add_conv_diff)
    then have "a*x\<^sup>2 + b*x+c = ((b\<^sup>2-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c)) / (4*a)) -b\<^sup>2/(2*a) + b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=((b\<^sup>2 + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c))/(4*a)) - b\<^sup>2/(2*a) - b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c"
    by (smt ab_group_add_class.ab_diff_conv_add_uminus add.assoc add_divide_distrib minus_divide_left pomocna2 pomocna5 pomocna6 square_ccsqrt times_divide_eq_right)
  then have "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (4*a)-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(4*a) + b\<^sup>2/(4*a) - (4 * a * c) / (4*a) -b\<^sup>2/(2*a) + b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(4*a) + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(4*a) + b\<^sup>2/(4*a) - (4 * a * c)/(4*a) - b\<^sup>2/(2*a) - b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c"
    by (simp add: add_divide_distrib diff_divide_distrib)
  then have  "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (4*a)-b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(2*a) + b\<^sup>2/(4*a) - c -b\<^sup>2/(2*a) + b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(4*a) + b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(2*a) + b\<^sup>2/(4*a) - c - b\<^sup>2/(2*a) - b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c"
    using assms by auto
  then have "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (4*a) + b\<^sup>2/(4*a)  -b\<^sup>2/(2*a)  \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(4*a)  + b\<^sup>2/(4*a) - b\<^sup>2/(2*a)"
    by simp
  then have "a*x\<^sup>2 + b*x+c = 2*b\<^sup>2 / (4*a)   -b\<^sup>2/(2*a)  \<or> a*x\<^sup>2 + b*x+c=2*b\<^sup>2/(4*a) - b\<^sup>2/(2*a)"
    by auto
  then have "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (2*a)   -b\<^sup>2/(2*a)  \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(2*a) - b\<^sup>2/(2*a)"
    by auto
  then have "a*x\<^sup>2 + b*x+c = 0  \<or> a*x\<^sup>2 + b*x+c=0"
    by simp
  then show ?thesis
    by blast
qed
next
  assume "a * x\<^sup>2 + b * x + c = 0 "
  show "x = (- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2*a) \<or> x = (- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2*a)"
  proof-
    have "a*x\<^sup>2+b*x+c = 0 \<longleftrightarrow> 4*a*(a*x\<^sup>2+b*x+c) = 0"
      by (simp add: \<open>a * x\<^sup>2 + b * x + c = 0\<close>)
    also have "4*a*(a*x\<^sup>2+b*x+c) = 4*a\<^sup>2*x\<^sup>2 +4*a*b*x + 4*a*c + b\<^sup>2 -b\<^sup>2"
      by (simp add: distrib_left power2_eq_square)
    also have "... = (2*a*x+b)\<^sup>2 -b\<^sup>2+4*a*c"
    by (smt add_diff_cancel_right' mult_2_right numeral_Bit0 power2_eq_square power2_sum semiring_normalization_rules(16) semiring_normalization_rules(18) semiring_normalization_rules(23))
  also have "(2*a*x+b)\<^sup>2 - b\<^sup>2 + 4*a*c=0"
    using \<open>a * x\<^sup>2 + b * x + c = 0\<close> calculation by blast
  also have "(2*a*x+b)\<^sup>2 = b\<^sup>2 - 4*a*c"
    by (metis \<open>(2 * a * x + b)\<^sup>2 - b\<^sup>2 + 4 * a * c = 0\<close> add_diff_cancel diff_0 diff_add_cancel uminus_add_conv_diff)
  then have "2*a*x+b = ccsqrt (b\<^sup>2 - 4*a*c) \<or> 2*a*x + b = -ccsqrt (b\<^sup>2 - 4*a*c)"
    by (metis \<open>(2 * a * x + b)\<^sup>2 = b\<^sup>2 - 4 * a * c\<close> ccsqrt power2_eq_square)
  then have "2*a*x = -b + ccsqrt (b\<^sup>2 - 4*a*c) \<or> 2*a*x = -b-ccsqrt (b\<^sup>2 - 4*a*c)"
    by (smt \<open>2 * a * x + b = ccsqrt (b\<^sup>2 - 4 * a * c) \<or> 2 * a * x + b = - ccsqrt (b\<^sup>2 - 4 * a * c)\<close> diff_minus_eq_add eq_diff_eq uminus_add_conv_diff)
  then have "x = (-b+ccsqrt (b\<^sup>2 - 4*a*c)) / (2*a) \<or> x = (-b - ccsqrt (b\<^sup>2 - 4*a*c))/ (2*a)"
    by (metis assms divisors_zero nonzero_mult_div_cancel_left zero_neq_numeral)
  thus ?thesis .
  qed
qed

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
section \<open>Subsumption\<close>

text \<open>We define the subsumption relation on terms and prove its well-foundedness.\<close>

theory Subsumption
  imports
    Term
    "Abstract-Rewriting.Seq"
    "HOL-Library.Adhoc_Overloading"
    Fun_More
    Seq_More
begin

consts
  SUBSUMESEQ :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<le>\<cdot>" 50)
  SUBSUMES :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "<\<cdot>" 50)
  LITSIM :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<doteq>" 50)

abbreviation (input) INSTANCEQ (infix "\<cdot>\<ge>" 50)
  where
    "x \<cdot>\<ge> y \<equiv> y \<le>\<cdot> x"

abbreviation (input) INSTANCE (infix "\<cdot>>" 50)
  where
    "x \<cdot>> y \<equiv> y <\<cdot> x"

abbreviation INSTANCEEQ_SET ("{\<cdot>\<ge>}")
  where
    "{\<cdot>\<ge>} \<equiv> {(x, y). y \<le>\<cdot> x}"

abbreviation INSTANCE_SET ("{\<cdot>>}")
  where
    "{\<cdot>>} \<equiv> {(x, y). y <\<cdot> x}"

abbreviation SUBSUMESEQ_SET ("{\<le>\<cdot>}")
  where
    "{\<le>\<cdot>} \<equiv> {(x, y). x \<le>\<cdot> y}"

abbreviation SUBSUMES_SET ("{<\<cdot>}")
  where
    "{<\<cdot>} \<equiv> {(x, y). x <\<cdot> y}"

abbreviation LITSIM_SET ("{\<doteq>}")
  where
    "{\<doteq>} \<equiv> {(x, y). x \<doteq> y}"

locale subsumable =
  fixes subsumeseq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes refl: "subsumeseq x x"
    and trans: "subsumeseq x y \<Longrightarrow> subsumeseq y z \<Longrightarrow> subsumeseq x z"
begin

adhoc_overloading
  SUBSUMESEQ subsumeseq

definition "subsumes t s \<longleftrightarrow> t \<le>\<cdot> s \<and> \<not> s \<le>\<cdot> t"

definition "litsim s t \<longleftrightarrow> s \<le>\<cdot> t \<and> t \<le>\<cdot> s"

adhoc_overloading
  SUBSUMES subsumes and
  LITSIM litsim

lemma litsim_refl [simp]:
  "s \<doteq> s"
  by (auto simp: litsim_def refl)

lemma litsim_sym:
  "s \<doteq> t \<Longrightarrow> t \<doteq> s"
  by (auto simp: litsim_def)

lemma litsim_trans:
  "s \<doteq> t \<Longrightarrow> t \<doteq> u \<Longrightarrow> s \<doteq> u"
  by (auto simp: litsim_def dest: trans)

end

sublocale subsumable \<subseteq> subsumption: preorder "(\<le>\<cdot>)" "(<\<cdot>)"
  by (unfold_locales) (auto simp: subsumes_def refl elim: trans)

inductive subsumeseq_term :: "('a, 'b) term \<Rightarrow> ('a, 'b) term \<Rightarrow> bool"
  where
    [intro]: "t = s \<cdot> \<sigma> \<Longrightarrow> subsumeseq_term s t"

adhoc_overloading
  SUBSUMESEQ subsumeseq_term

lemma subsumeseq_termE [elim]:
  assumes "s \<le>\<cdot> t"
  obtains \<sigma> where "t = s \<cdot> \<sigma>"
  using assms by (cases)

lemma subsumeseq_term_refl:
  fixes t :: "('a, 'b) term"
  shows "t \<le>\<cdot> t"
  by (rule subsumeseq_term.intros [of t t Var]) simp

lemma subsumeseq_term_trans:
  fixes s t u :: "('a, 'b) term"
  assumes "s \<le>\<cdot> t" and "t \<le>\<cdot> u"
  shows "s \<le>\<cdot> u"
proof -
  obtain \<sigma> \<tau>
    where [simp]: "t = s \<cdot> \<sigma>" "u = t \<cdot> \<tau>" using assms by fastforce
  show ?thesis
    by (rule subsumeseq_term.intros [of _ _ "\<sigma> \<circ>\<^sub>s \<tau>"]) simp
qed

interpretation term_subsumable: subsumable subsumeseq_term
  by standard (force simp: subsumeseq_term_refl dest: subsumeseq_term_trans)+

adhoc_overloading
  SUBSUMES term_subsumable.subsumes and
  LITSIM term_subsumable.litsim

lemma subsumeseq_term_iff:
  "s \<cdot>\<ge> t \<longleftrightarrow> (\<exists>\<sigma>. s = t \<cdot> \<sigma>)"
  by auto

fun num_syms :: "('f, 'v) term \<Rightarrow> nat"
  where
    "num_syms (Var x) = 1" |
    "num_syms (Fun f ts) = Suc (sum_list (map num_syms ts))"

fun num_vars :: "('f, 'v) term \<Rightarrow> nat"
  where
    "num_vars (Var x) = 1" |
    "num_vars (Fun f ts) = sum_list (map num_vars ts)"

definition num_unique_vars :: "('f, 'v) term \<Rightarrow> nat"
  where
    "num_unique_vars t = card (vars_term t)"

lemma num_syms_1: "num_syms t \<ge> 1"
  by (induct t) auto

lemma num_syms_subst:
  "num_syms (t \<cdot> \<sigma>) \<ge> num_syms t"
  using num_syms_1
  by (induct t) (auto, metis comp_apply sum_list_mono)

subsection \<open>Equality of terms modulo variables\<close>

inductive emv where
  Var [simp, intro!]: "emv (Var x) (Var y)" |
  Fun [intro]: "\<lbrakk>f = g; length ss = length ts; \<forall>i < length ts. emv (ss ! i) (ts ! i)\<rbrakk> \<Longrightarrow>
    emv (Fun f ss) (Fun g ts)"

lemma sum_list_map_num_syms_subst:
  assumes "sum_list (map (num_syms \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts) = sum_list (map num_syms ts)"
  shows "\<forall>i < length ts. num_syms (ts ! i \<cdot> \<sigma>) = num_syms (ts ! i)"
  using assms
proof (induct ts)
  case (Cons t ts)
  then have "num_syms (t \<cdot> \<sigma>) + sum_list (map (num_syms \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts)
    = num_syms t + sum_list (map num_syms ts)" by (simp add: o_def)
  moreover have "num_syms (t \<cdot> \<sigma>) \<ge> num_syms t" by (metis num_syms_subst)
  moreover have "sum_list (map (num_syms \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts) \<ge> sum_list (map num_syms ts)"
    using num_syms_subst [of _ \<sigma>] by (induct ts) (auto intro: add_mono)
  ultimately show ?case using Cons by (auto) (case_tac i, auto)
qed simp

lemma subst_size_emv:
  assumes "s = t \<cdot> \<tau>" and "num_syms s = num_syms t" and "num_funs s = num_funs t"
  shows "emv s t"
  using assms
proof (induct t arbitrary: s)
  case (Var x)
  then show ?case by (force elim: num_funs_0)
next
  case (Fun g ts)
  note IH = this
  show ?case
  proof (cases s)
    case (Var x)
    then show ?thesis using Fun by simp
  next
    case (Fun f ss)
    from IH(2-) [unfolded Fun]
      and sum_list_map_num_syms_subst [of \<tau> ts]
      and sum_list_map_num_funs_subst [of \<tau> ts]
    have "\<forall>i < length ts. num_syms (ts ! i  \<cdot> \<tau>) = num_syms (ts ! i)"
      and "\<forall>i < length ts. num_funs (ts ! i \<cdot> \<tau>) = num_funs (ts ! i)"
      by auto
    with Fun and IH show ?thesis by auto
  qed
qed

lemma subsumeseq_term_size_emv:
  assumes "s \<cdot>\<ge> t" and "num_syms s = num_syms t" and "num_funs s = num_funs t"
  shows "emv s t"
  using assms(1) and subst_size_emv [OF _ assms(2-)] by (cases) simp

lemma emv_subst_vars_term:
  assumes "emv s t"
    and "s = t \<cdot> \<sigma>"
  shows "vars_term s = (the_Var \<circ> \<sigma>) ` vars_term t"
  using assms [unfolded subsumeseq_term_iff]
  apply (induct)
   apply (auto simp: in_set_conv_nth iff: image_iff)
   apply (metis nth_mem)
  by (metis comp_apply imageI nth_mem)

lemma emv_subst_imp_num_unique_vars_le:
  assumes "emv s t"
    and "s = t \<cdot> \<sigma>"
  shows "num_unique_vars s \<le> num_unique_vars t"
  using emv_subst_vars_term [OF assms]
  apply (simp add: num_unique_vars_def)
  by (metis card_image_le finite_vars_term)

lemma emv_subsumeseq_term_imp_num_unique_vars_le:
  assumes "emv s t"
    and "s \<cdot>\<ge> t"
  shows "num_unique_vars s \<le> num_unique_vars t"
  using assms(2) and emv_subst_imp_num_unique_vars_le [OF assms(1)] by (cases) simp

lemma num_syms_geq_num_vars:
  "num_syms t \<ge> num_vars t"
proof (induct t)
  case (Fun f ts)
  with sum_list_mono [of ts num_vars num_syms]
  have "sum_list (map num_vars ts) \<le> sum_list (map num_syms ts)" by simp
  then show ?case by simp
qed simp

lemma num_unique_vars_Fun_Cons:
  "num_unique_vars (Fun f (t # ts)) \<le> num_unique_vars t + num_unique_vars (Fun f ts)"
  apply (simp_all add: num_unique_vars_def)
  unfolding card_Un_Int [OF finite_vars_term finite_Union_vars_term]
  apply simp
  done

lemma sum_list_map_unique_vars:
  "sum_list (map num_unique_vars ts) \<ge> num_unique_vars (Fun f ts)"
proof (induct ts)
  case (Cons t ts)
  with num_unique_vars_Fun_Cons [of f t ts]
  show ?case by simp
qed (simp add: num_unique_vars_def)

lemma num_unique_vars_Var_1 [simp]:
  "num_unique_vars (Var x) = 1"
  by (simp_all add: num_unique_vars_def)

lemma num_vars_geq_num_unique_vars:
  "num_vars t \<ge> num_unique_vars t"
proof -
  note * =
    sum_list_mono [of _ num_unique_vars num_vars, THEN sum_list_map_unique_vars [THEN le_trans]]
  show ?thesis by (induct t) (auto intro: *)
qed

lemma num_syms_ge_num_unique_vars:
  "num_syms t \<ge> num_unique_vars t"
  by (metis le_trans num_syms_geq_num_vars num_vars_geq_num_unique_vars)

lemma num_syms_num_unique_vars_clash:
  assumes "\<forall>i. num_syms (f i) = num_syms (f (Suc i))"
    and "\<forall>i. num_unique_vars (f i) < num_unique_vars (f (Suc i))"
  shows False
proof -
  have *: "\<forall>i j. i \<le> j \<longrightarrow> num_syms (f i) = num_syms (f j)"
  proof (intro allI impI)
    fix i j :: nat
    assume "i \<le> j"
    then show "num_syms (f i) = num_syms (f j)"
      using assms(1)
      apply (induct "j - i" arbitrary: i)
       apply auto
      by (metis Suc_diff_diff diff_zero less_eq_Suc_le order.not_eq_order_implies_strict)
  qed
  have "\<exists>i. num_unique_vars (f i) \<ge> num_syms (f 0)"
    using inc_seq_greater [OF assms(2), of "num_syms (f 0)"] by (metis nat_less_le)
  then obtain i where "num_unique_vars (f i) \<ge> num_syms (f 0)" by auto
  with * and assms(2) have "num_unique_vars (f (Suc i)) > num_syms (f (Suc i))"
    by (metis le0 le_antisym num_syms_ge_num_unique_vars)
  then show False
    by (metis less_Suc_eq_le not_less_eq num_syms_ge_num_unique_vars)
qed

lemma emv_subst_imp_is_Var:
  assumes "emv s t"
    and "s = t \<cdot> \<sigma>"
  shows "\<forall>x \<in> vars_term t. is_Var (\<sigma> x)"
  using assms
  apply (induct)
   apply auto
  by (metis in_set_conv_nth)

lemma bij_Var_subst_compose_Var:
  assumes "bij g"
  shows "(Var \<circ> g) \<circ>\<^sub>s (Var \<circ> inv g) = Var"
proof
  fix x
  show "((Var \<circ> g) \<circ>\<^sub>s (Var \<circ> inv g)) x = Var x"
    using assms
    apply (auto simp: subst_compose_def)
    by (metis UNIV_I bij_is_inj inv_into_f_f)
qed

subsection \<open>Well-foundedness\<close>

lemma wf_subsumes:
  "wf ({<\<cdot>} :: ('f, 'v) term rel)"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain f :: "('f, 'v) term seq"
    where strict: "\<forall>i. f i \<cdot>> f (Suc i)"
    by (metis mem_Collect_eq case_prodD wf_iff_no_infinite_down_chain)
  then have *: "\<forall>i. f i \<cdot>\<ge> f (Suc i)" by (metis term_subsumable.subsumption.less_imp_le)
  then have "\<forall>i. num_syms (f i) \<ge> num_syms (f (Suc i))"
    by (auto simp: subsumeseq_term_iff) (metis num_syms_subst)
  from down_chain_imp_eq [OF this] obtain N
    where N_syms: "\<forall>i > N. num_syms (f i) = num_syms (f (Suc i))" ..
  define g where "g i = f (i + N)" for i
  from * have "\<forall>i. num_funs (g i) \<ge> num_funs (g (Suc i))"
    by (auto simp: subsumeseq_term_iff g_def) (metis num_funs_subst)
  from down_chain_imp_eq [OF this] obtain K
    where K_funs: "\<forall>i > K. num_funs (g i) = num_funs (g (Suc i))" ..
  define M where "M = max K N"
  have strict_g: "\<forall>i > M. g i \<cdot>> g (Suc i)" using strict by (simp add: g_def M_def)
  have g: "\<forall>i > M. g i \<cdot>\<ge> g (Suc i)" using * by (simp add: g_def M_def)
  moreover have "\<forall>i > M. num_funs (g i) = num_funs (g (Suc i))"
    using K_funs unfolding M_def by (metis max_less_iff_conj)
  moreover have syms: "\<forall>i > M. num_syms (g i) = num_syms (g (Suc i))"
    using N_syms unfolding M_def g_def
    by (metis add_Suc_right add_lessD1 add_strict_left_mono add.commute)
  ultimately have emv: "\<forall>i > M. emv (g i) (g (Suc i))" by (metis subsumeseq_term_size_emv)
  then have "\<forall>i > M. num_unique_vars (g (Suc i)) \<ge> num_unique_vars (g i)"
    using emv_subsumeseq_term_imp_num_unique_vars_le and g by fast
  then obtain i where "i > M"
    and nuv: "num_unique_vars (g (Suc i)) = num_unique_vars (g i)"
    using num_syms_num_unique_vars_clash [of "\<lambda>i. g (i + Suc M)"] and syms
    by (metis add_Suc_right add_Suc_shift le_eq_less_or_eq less_add_Suc2)
  define s and t where "s = g i" and "t = g (Suc i)"
  from nuv have card: "card (vars_term s) = card (vars_term t)"
    by (simp add: num_unique_vars_def s_def t_def)
  from g [THEN spec, THEN mp, OF \<open>i > M\<close>] obtain \<sigma>
    where "s = t \<cdot> \<sigma>" by (cases) (auto simp: s_def t_def)
  then have "emv s t" and "vars_term s = (the_Var \<circ> \<sigma>) ` vars_term t"
    using emv_subst_vars_term [of s t \<sigma>] and emv and \<open>i > M\<close> by (auto simp: s_def t_def)
  with card have "card ((the_Var \<circ> \<sigma>) ` vars_term t) = card (vars_term t)" by simp
  from finite_card_eq_imp_bij_betw [OF finite_vars_term this]
  have "bij_betw (the_Var \<circ> \<sigma>) (vars_term t) ((the_Var \<circ> \<sigma>) ` vars_term t)" .

  from bij_betw_extend [OF this, of UNIV]
  obtain h where *: "\<forall>x\<in>vars_term t. h x = (the_Var \<circ> \<sigma>) x"
    and "finite {x. h x \<noteq> x}"
    and "bij h" by auto
  have "\<forall>x\<in>vars_term t. (Var \<circ> h) x = \<sigma> x"
  proof
    fix x
    assume "x \<in> vars_term t"
    with * have "h x = (the_Var \<circ> \<sigma>) x" by simp
    with emv_subst_imp_is_Var [OF \<open>emv s t\<close> \<open>s = t \<cdot> \<sigma>\<close>] \<open>x \<in> vars_term t\<close>
    show "(Var \<circ> h) x = \<sigma> x" by simp
  qed
  then have "t \<cdot> (Var \<circ> h) = s"
    using \<open>s = t \<cdot> \<sigma>\<close> by (auto simp: term_subst_eq_conv)
  then have "t \<cdot> (Var \<circ> h) \<circ>\<^sub>s (Var \<circ> inv h) = s \<cdot> (Var \<circ> inv h)" by auto
  then have "t = s \<cdot> (Var \<circ> inv h)"
    unfolding bij_Var_subst_compose_Var [OF \<open>bij h\<close>] by simp
  then have "t \<cdot>\<ge> s" by auto
  with strict_g and \<open>i > M\<close> show False by (auto simp: s_def t_def term_subsumable.subsumes_def)
qed

end


(*  Title:       Conservation of CSP Noninterference Security under Sequential Composition
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems, Italy
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjosystems dot com
*)

section "Necessity of nontrivial assumptions"

theory Counterexamples
imports SequentialComposition
begin

text \<open>
\null

The security conservation theorem proven in this paper contains two nontrivial assumptions; namely,
the security policy must satisfy predicate @{term secure_termination}, and the first input process
must satisfy predicate @{term sequential} instead of @{term weakly_sequential} alone. This section
shows, by means of counterexamples, that both of these assumptions are necessary for the theorem to
hold.

In more detail, two counterexamples will be constructed: the former drops the termination security
assumption, whereas the latter drops the process sequentiality assumption, replacing it with weak
sequentiality alone. In both cases, all the other assumptions of the theorem keep being satisfied.

Both counterexamples make use of reflexive security policies, which is the case for any policy of
practical significance, and are based on trace set processes as defined in \cite{R3}. The security
of the processes input to sequential composition, as well as the insecurity of the resulting
process, are demonstrated by means of the Ipurge Unwinding Theorem proven in \cite{R3}.
\<close>

subsection "Preliminary definitions and lemmas"

text \<open>
Both counterexamples will use the same type @{term event} as native type of ordinary events, as well
as the same process @{term Q} as second input to sequential composition. Here below are the
definitions of these constants, followed by few useful lemmas on process @{term Q}.

\null
\<close>

datatype event = a | b

definition Q :: "event option process" where
"Q \<equiv> ts_process {[], [Some b]}"

lemma trace_set_snd:
 "trace_set {[], [Some b]}"
by (simp add: trace_set_def)

lemmas failures_snd = ts_process_failures [OF trace_set_snd]

lemmas traces_snd = ts_process_traces [OF trace_set_snd]

lemmas next_events_snd = ts_process_next_events [OF trace_set_snd]

lemmas unwinding_snd = ts_ipurge_unwinding [OF trace_set_snd]

subsection "Necessity of termination security"

text \<open>
The reason why the conservation of noninterference security under sequential composition requires
the security policy to satisfy predicate @{term secure_termination} is that the second input process
cannot engage in its events unless the first process has terminated successfully. Thus, the ordinary
events of the first process can indirectly affect the events of the second process by affecting the
successful termination of the first process. Therefore, if an ordinary event is allowed to affect
successful termination, then the policy must allow it to affect any other event as well, which is
exactly what predicate @{term secure_termination} states.

A counterexample showing the necessity of this assumption can then be constructed by defining a
reflexive policy @{term I\<^sub>1} that allows event @{term "Some a"} to affect @{term None}, but not
@{term "Some b"}, and a deterministic process @{term P\<^sub>1} that can engage in @{term None} only after
engaging in @{term "Some a"}. The resulting process @{term "P\<^sub>1 ; Q"} will number
@{term "[Some a, Some b]"}, but not @{term "[Some b]"}, among its traces, so that event
@{term "Some a"} affects the occurrence of event @{term "Some b"} in contrast with policy
@{term I\<^sub>1}, viz. @{term "P\<^sub>1 ; Q"} is not secure with respect to @{term I\<^sub>1}.

Here below are the definitions of constants @{term I\<^sub>1} and @{term P\<^sub>1}, followed by few useful lemmas
on process @{term P\<^sub>1}.

\null
\<close>

definition I\<^sub>1 :: "(event option \<times> event option) set" where
"I\<^sub>1 \<equiv> {(Some a, None)}\<^sup>="

definition P\<^sub>1 :: "event option process" where
"P\<^sub>1 \<equiv> ts_process {[], [Some a], [Some a, None]}"

lemma trace_set_fst_1:
 "trace_set {[], [Some a], [Some a, None]}"
by (simp add: trace_set_def)

lemmas failures_fst_1 = ts_process_failures [OF trace_set_fst_1]

lemmas traces_fst_1 = ts_process_traces [OF trace_set_fst_1]

lemmas next_events_fst_1 = ts_process_next_events [OF trace_set_fst_1]

lemmas unwinding_fst_1 = ts_ipurge_unwinding [OF trace_set_fst_1]

text \<open>
\null

Here below is the proof that policy @{term I\<^sub>1} does not satisfy predicate
@{term secure_termination}, whereas the remaining assumptions of the security conservation theorem
keep being satisfied. For the sake of simplicity, the identity function is used as event-domain map.

\null
\<close>

lemma not_secure_termination_1:
 "\<not> secure_termination I\<^sub>1 id"
proof (simp add: secure_termination_def I\<^sub>1_def, rule exI [where x = "Some a"],
 simp)
qed (rule exI [where x = "Some b"], simp)

lemma ref_union_closed_fst_1:
 "ref_union_closed P\<^sub>1"
by (rule d_implies_ruc, subst P\<^sub>1_def, rule ts_process_d, rule trace_set_fst_1)

lemma sequential_fst_1:
 "sequential P\<^sub>1"
proof (simp add: sequential_def sentences_def P\<^sub>1_def traces_fst_1)
qed (simp add: set_eq_iff next_events_fst_1)

lemma secure_fst_1:
 "secure P\<^sub>1 I\<^sub>1 id"
proof (simp add: P\<^sub>1_def unwinding_fst_1 dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_fst_1, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
    (ys = [] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
    ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [Some a], [Some a, None]}) id u xs =
      next_dom_events (ts_process {[], [Some a], [Some a, None]}) id u ys"
  proof (simp add: next_dom_events_def next_events_fst_1, cases u)
    case None
    show
     "(xs = [] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = Some a \<or> xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = Some a \<or> ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>1_def None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = Some a \<or> xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = Some a \<or> ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>1_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp, blast?)+)
  qed
qed

lemma secure_snd_1:
 "secure Q I\<^sub>1 id"
proof (simp add: Q_def unwinding_snd dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_snd, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [Some b]) \<and>
    (ys = [] \<or> ys = [Some b]) \<and>
    ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [Some b]}) id u xs =
      next_dom_events (ts_process {[], [Some b]}) id u ys"
  proof (simp add: next_dom_events_def next_events_snd, cases u)
    case None
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: I\<^sub>1_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp)+)
  qed
qed

text \<open>
\null

In what follows, the insecurity of process @{term "P\<^sub>1 ; Q"} is demonstrated by proving that event
list @{term "[Some a, Some b]"} is a trace of the process, whereas @{term "[Some b]"} is not.

\null
\<close>

lemma traces_comp_1:
 "traces (P\<^sub>1 ; Q) = Domain (seq_comp_failures P\<^sub>1 Q)"
by (subst seq_comp_traces, rule seq_implies_weakly_seq, rule sequential_fst_1, simp)

lemma ref_union_closed_comp_1:
 "ref_union_closed (P\<^sub>1 ; Q)"
proof (rule seq_comp_ref_union_closed, rule seq_implies_weakly_seq,
 rule sequential_fst_1, rule ref_union_closed_fst_1)
qed (rule d_implies_ruc, subst Q_def, rule ts_process_d, rule trace_set_snd)

lemma not_secure_comp_1_aux_aux_1:
 "(xs, X) \<in> seq_comp_failures P\<^sub>1 Q \<Longrightarrow> xs \<noteq> [Some b]"
proof (rule notI, erule rev_mp, erule seq_comp_failures.induct, (rule_tac [!] impI)+,
 simp_all add: P\<^sub>1_def Q_def sentences_def)
qed (simp_all add: failures_fst_1 traces_fst_1)

lemma not_secure_comp_1_aux_1:
 "[Some b] \<notin> traces (P\<^sub>1 ; Q)"
proof (simp add: traces_comp_1 Domain_iff, rule allI, rule notI)
qed (drule not_secure_comp_1_aux_aux_1, simp)

lemma not_secure_comp_1_aux_2:
 "[Some a, Some b] \<in> traces (P\<^sub>1 ; Q)"
proof (simp add: traces_comp_1 Domain_iff, rule exI [where x = "{}"])
  have "[Some a] \<in> sentences P\<^sub>1"
   by (simp add: P\<^sub>1_def sentences_def traces_fst_1)
  moreover have "([Some b], {}) \<in> failures Q"
   by (simp add: Q_def failures_snd)
  moreover have "[Some b] \<noteq> []"
   by simp
  ultimately have "([Some a] @ [Some b], {}) \<in> seq_comp_failures P\<^sub>1 Q"
   by (rule SCF_R3)
  thus "([Some a, Some b], {}) \<in> seq_comp_failures P\<^sub>1 Q"
   by simp
qed

lemma not_secure_comp_1:
 "\<not> secure (P\<^sub>1 ; Q) I\<^sub>1 id"
proof (subst ipurge_unwinding, rule ref_union_closed_comp_1, simp
 add: fc_equals_wfc_rel_ipurge [symmetric] future_consistent_def rel_ipurge_def
 del: disj_not1, rule exI [where x = "Some b"], rule exI [where x = "[]"], rule conjI)
  show "[] \<in> traces (P\<^sub>1 ; Q)"
   by (rule failures_traces [where X = "{}"], rule process_rule_1)
next
  show "\<exists>ys. ys \<in> traces (P\<^sub>1 ; Q) \<and>
    ipurge_tr_rev I\<^sub>1 id (Some b) [] = ipurge_tr_rev I\<^sub>1 id (Some b) ys \<and>
    (next_dom_events (P\<^sub>1 ; Q) id (Some b) [] \<noteq>
       next_dom_events (P\<^sub>1 ; Q) id (Some b) ys \<or>
     ref_dom_events (P\<^sub>1 ; Q) id (Some b) [] \<noteq>
       ref_dom_events (P\<^sub>1 ; Q) id (Some b) ys)"
  proof (rule exI [where x = "[Some a]"], rule conjI, rule_tac [2] conjI,
   rule_tac [3] disjI1)
    have "[Some a] @ [Some b] \<in> traces (P\<^sub>1 ; Q)"
     by (simp add: not_secure_comp_1_aux_2)
    thus "[Some a] \<in> traces (P\<^sub>1 ; Q)"
     by (rule process_rule_2_traces)
  next
    show "ipurge_tr_rev I\<^sub>1 id (Some b) [] = ipurge_tr_rev I\<^sub>1 id (Some b) [Some a]"
     by (simp add: I\<^sub>1_def)
  next
    show
     "next_dom_events (P\<^sub>1 ; Q) id (Some b) [] \<noteq>
      next_dom_events (P\<^sub>1 ; Q) id (Some b) [Some a]"
    proof (simp add: next_dom_events_def next_events_def set_eq_iff,
     rule exI [where x = "Some b"], simp)
    qed (simp add: not_secure_comp_1_aux_1 not_secure_comp_1_aux_2)
  qed
qed

text \<open>
\null

Here below, the previous results are used to show that constants @{term I\<^sub>1}, @{term P\<^sub>1}, @{term Q},
and @{term id} indeed constitute a counterexample to the statement obtained by removing termination
security from the assumptions of the security conservation theorem.

\null
\<close>

lemma counterexample_1:
 "\<not> (ref_union_closed P\<^sub>1 \<and>
     sequential P\<^sub>1 \<and>
     secure P\<^sub>1 I\<^sub>1 id \<and>
     secure Q I\<^sub>1 id \<longrightarrow>
   secure (P\<^sub>1 ; Q) I\<^sub>1 id)"
proof (simp, simp only: conj_assoc [symmetric], (rule conjI)+)
  show "ref_union_closed P\<^sub>1"
   by (rule ref_union_closed_fst_1)
next
  show "sequential P\<^sub>1"
   by (rule sequential_fst_1)
next
  show "secure P\<^sub>1 I\<^sub>1 id"
   by (rule secure_fst_1)
next
  show "secure Q I\<^sub>1 id"
   by (rule secure_snd_1)
next
  show "\<not> secure (P\<^sub>1 ; Q) I\<^sub>1 id"
   by (rule not_secure_comp_1)
qed

subsection "Necessity of process sequentiality"

text \<open>
The reason why the conservation of noninterference security under sequential composition requires
the first input process to satisfy predicate @{term sequential}, instead of the more permissive
predicate @{term weakly_sequential}, is that the possibility for the first process to engage in
events alternative to successful termination entails the possibility for the resulting process to
engage in events alternative to the initial ones of the second process. Namely, the resulting
process would admit some state in which events of the first process can occur in alternative to
events of the second process. But neither process, though being secure on its own, will in general
be prepared to handle securely the alternative events added by the other process. Therefore, the
first process must not admit alternatives to successful termination, which is exactly what predicate
@{term sequential} states in addition to @{term weakly_sequential}.

A counterexample showing the necessity of this assumption can then be constructed by defining a
reflexive policy @{term I\<^sub>2} that does not allow event @{term "Some b"} to affect @{term "Some a"},
and a deterministic process @{term P\<^sub>2} that can engage in @{term "Some a"} in alternative to
@{term None}. The resulting process @{term "P\<^sub>2 ; Q"} will number both @{term "[Some b]"} and
@{term "[Some a]"}, but not @{term "[Some b, Some a]"}, among its traces, so that event
@{term "Some b"} affects the occurrence of event @{term "Some a"} in contrast with policy
@{term I\<^sub>2}, viz. @{term "P\<^sub>2 ; Q"} is not secure with respect to @{term I\<^sub>2}.

Here below are the definitions of constants @{term I\<^sub>2} and @{term P\<^sub>2}, followed by few useful lemmas
on process @{term P\<^sub>2}.

\null
\<close>

definition I\<^sub>2 :: "(event option \<times> event option) set" where
"I\<^sub>2 \<equiv> {(None, Some a)}\<^sup>="

definition P\<^sub>2 :: "event option process" where
"P\<^sub>2 \<equiv> ts_process {[], [None], [Some a], [Some a, None]}"

lemma trace_set_fst_2:
 "trace_set {[], [None], [Some a], [Some a, None]}"
by (simp add: trace_set_def)

lemmas failures_fst_2 = ts_process_failures [OF trace_set_fst_2]

lemmas traces_fst_2 = ts_process_traces [OF trace_set_fst_2]

lemmas next_events_fst_2 = ts_process_next_events [OF trace_set_fst_2]

lemmas unwinding_fst_2 = ts_ipurge_unwinding [OF trace_set_fst_2]

text \<open>
\null

Here below is the proof that process @{term P\<^sub>2} does not satisfy predicate @{term sequential}, but
rather predicate @{term weakly_sequential} only, whereas the remaining assumptions of the security
conservation theorem keep being satisfied. For the sake of simplicity, the identity function is used
as event-domain map.

\null
\<close>

lemma secure_termination_2:
 "secure_termination I\<^sub>2 id"
by (simp add: secure_termination_def I\<^sub>2_def)

lemma ref_union_closed_fst_2:
 "ref_union_closed P\<^sub>2"
by (rule d_implies_ruc, subst P\<^sub>2_def, rule ts_process_d, rule trace_set_fst_2)

lemma weakly_sequential_fst_2:
 "weakly_sequential P\<^sub>2"
by (simp add: weakly_sequential_def P\<^sub>2_def traces_fst_2)

lemma not_sequential_fst_2:
 "\<not> sequential P\<^sub>2"
proof (simp add: sequential_def, rule disjI2, rule bexI [where x = "[]"])
  show "next_events P\<^sub>2 [] \<noteq> {None}"
  proof (rule notI, drule eqset_imp_iff [where x = "Some a"], simp)
  qed (simp add: P\<^sub>2_def next_events_fst_2)
next
  show "[] \<in> sentences P\<^sub>2"
   by (simp add: sentences_def P\<^sub>2_def traces_fst_2)
qed

lemma secure_fst_2:
 "secure P\<^sub>2 I\<^sub>2 id"
proof (simp add: P\<^sub>2_def unwinding_fst_2 dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_fst_2, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [None] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
    (ys = [] \<or> ys = [None] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
    ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [None], [Some a], [Some a, None]}) id u xs =
      next_dom_events (ts_process {[], [None], [Some a], [Some a, None]}) id u ys"
  proof (simp add: next_dom_events_def next_events_fst_2, cases u)
    case None
    show
     "(xs = [] \<or> xs = [None] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [None] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = None \<or> xs = [] \<and> x = Some a \<or>
          xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = None \<or> ys = [] \<and> x = Some a \<or>
          ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>2_def None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp, blast?)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [None] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [None] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = None \<or> xs = [] \<and> x = Some a \<or>
          xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = None \<or> ys = [] \<and> x = Some a \<or>
          ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>2_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp, blast?)+)
  qed
qed

lemma secure_snd_2:
 "secure Q I\<^sub>2 id"
proof (simp add: Q_def unwinding_snd dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_snd, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [Some b]) \<and>
    (ys = [] \<or> ys = [Some b]) \<and>
    ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [Some b]}) id u xs =
      next_dom_events (ts_process {[], [Some b]}) id u ys"
  proof (simp add: next_dom_events_def next_events_snd, cases u)
    case None
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: I\<^sub>2_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp)+)
  qed
qed

text \<open>
\null

In what follows, the insecurity of process @{term "P\<^sub>2 ; Q"} is demonstrated by proving that event
lists @{term "[Some b]"} and @{term "[Some a]"} are traces of the process, whereas
@{term "[Some b, Some a]"} is not.

\null
\<close>

lemma traces_comp_2:
 "traces (P\<^sub>2 ; Q) = Domain (seq_comp_failures P\<^sub>2 Q)"
by (subst seq_comp_traces, rule weakly_sequential_fst_2, simp)

lemma ref_union_closed_comp_2:
 "ref_union_closed (P\<^sub>2 ; Q)"
proof (rule seq_comp_ref_union_closed, rule weakly_sequential_fst_2,
 rule ref_union_closed_fst_2)
qed (rule d_implies_ruc, subst Q_def, rule ts_process_d, rule trace_set_snd)

lemma not_secure_comp_2_aux_aux_1:
 "(xs, X) \<in> seq_comp_failures P\<^sub>2 Q \<Longrightarrow> xs \<noteq> [Some b, Some a]"
proof (rule notI, erule rev_mp, erule seq_comp_failures.induct, (rule_tac [!] impI)+,
 simp_all add: P\<^sub>2_def Q_def sentences_def)
qed (simp_all add: failures_fst_2 traces_fst_2 failures_snd)

lemma not_secure_comp_2_aux_1:
 "[Some b, Some a] \<notin> traces (P\<^sub>2 ; Q)"
proof (simp add: traces_comp_2 Domain_iff, rule allI, rule notI)
qed (drule not_secure_comp_2_aux_aux_1, simp)

lemma not_secure_comp_2_aux_2:
 "[Some a] \<in> traces (P\<^sub>2 ; Q)"
proof (simp add: traces_comp_2 Domain_iff, rule exI [where x = "{}"])
  have "[Some a] \<in> sentences P\<^sub>2"
   by (simp add: P\<^sub>2_def sentences_def traces_fst_2)
  moreover have "([Some a], {}) \<in> failures P\<^sub>2"
   by (simp add: P\<^sub>2_def failures_fst_2)
  moreover have "([], {}) \<in> failures Q"
   by (simp add: Q_def failures_snd)
  ultimately have "([Some a], insert None {} \<inter> {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by (rule SCF_R2)
  thus "([Some a], {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by simp
qed

lemma not_secure_comp_2_aux_3:
 "[Some b] \<in> traces (P\<^sub>2 ; Q)"
proof (simp add: traces_comp_2 Domain_iff, rule exI [where x = "{}"])
  have "[] \<in> sentences P\<^sub>2"
   by (simp add: P\<^sub>2_def sentences_def traces_fst_2)
  moreover have "([Some b], {}) \<in> failures Q"
   by (simp add: Q_def failures_snd)
  moreover have "[Some b] \<noteq> []"
   by simp
  ultimately have "([] @ [Some b], {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by (rule SCF_R3)
  thus "([Some b], {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by simp
qed

lemma not_secure_comp_2:
 "\<not> secure (P\<^sub>2 ; Q) I\<^sub>2 id"
proof (subst ipurge_unwinding, rule ref_union_closed_comp_2, simp
 add: fc_equals_wfc_rel_ipurge [symmetric] future_consistent_def rel_ipurge_def
 del: disj_not1, rule exI [where x = "Some a"], rule exI [where x = "[]"], rule conjI)
  show "[] \<in> traces (P\<^sub>2 ; Q)"
   by (rule failures_traces [where X = "{}"], rule process_rule_1)
next
  show "\<exists>ys. ys \<in> traces (P\<^sub>2 ; Q) \<and>
    ipurge_tr_rev I\<^sub>2 id (Some a) [] = ipurge_tr_rev I\<^sub>2 id (Some a) ys \<and>
    (next_dom_events (P\<^sub>2 ; Q) id (Some a) [] \<noteq>
       next_dom_events (P\<^sub>2 ; Q) id (Some a) ys \<or>
     ref_dom_events (P\<^sub>2 ; Q) id (Some a) [] \<noteq>
       ref_dom_events (P\<^sub>2 ; Q) id (Some a) ys)"
  proof (rule exI [where x = "[Some b]"], rule conjI, rule_tac [2] conjI,
   rule_tac [3] disjI1)
    show "[Some b] \<in> traces (P\<^sub>2 ; Q)"
     by (rule not_secure_comp_2_aux_3)
  next
    show "ipurge_tr_rev I\<^sub>2 id (Some a) [] = ipurge_tr_rev I\<^sub>2 id (Some a) [Some b]"
     by (simp add: I\<^sub>2_def)
  next
    show
     "next_dom_events (P\<^sub>2 ; Q) id (Some a) [] \<noteq>
      next_dom_events (P\<^sub>2 ; Q) id (Some a) [Some b]"
    proof (simp add: next_dom_events_def next_events_def set_eq_iff,
     rule exI [where x = "Some a"], simp)
    qed (simp add: not_secure_comp_2_aux_1 not_secure_comp_2_aux_2)
  qed
qed

text \<open>
\null

Here below, the previous results are used to show that constants @{term I\<^sub>2}, @{term P\<^sub>2}, @{term Q},
and @{term id} indeed constitute a counterexample to the statement obtained by replacing process
sequentiality with weak sequentiality in the assumptions of the security conservation theorem.

\null
\<close>

lemma counterexample_2:
 "\<not> (secure_termination I\<^sub>2 id \<and>
     ref_union_closed P\<^sub>2 \<and>
     weakly_sequential P\<^sub>2 \<and>
     secure P\<^sub>2 I\<^sub>2 id \<and>
     secure Q I\<^sub>2 id \<longrightarrow>
   secure (P\<^sub>2 ; Q) I\<^sub>2 id)"
proof (simp, simp only: conj_assoc [symmetric], (rule conjI)+)
  show "secure_termination I\<^sub>2 id"
   by (rule secure_termination_2)
next
  show "ref_union_closed P\<^sub>2"
   by (rule ref_union_closed_fst_2)
next
  show "weakly_sequential P\<^sub>2"
   by (rule weakly_sequential_fst_2)
next
  show "secure P\<^sub>2 I\<^sub>2 id"
   by (rule secure_fst_2)
next
  show "secure Q I\<^sub>2 id"
   by (rule secure_snd_2)
next
  show "\<not> secure (P\<^sub>2 ; Q) I\<^sub>2 id"
   by (rule not_secure_comp_2)
qed

end