theory "ext-simpl-properties"
  imports "extensions-simpl"  "../Zorn-lemma"
begin

(**** Testing definitions for extension-based semantics for argumentation frameworks ***)

section \<open>Admissible and complete extensions - Tests\<close>

(* \<F> is monotone (i.e. order preserving wrt. set inclusion). *)
lemma \<F>_mono: "MONO (\<F> AF)" unfolding MONO_def by (metis defends_def)

(* We can in fact verify that \<F> has both a least and a greatest fixed point. *)
lemma \<F>_leastFP_ex: \<open>\<exists>S. least (fixpoint (\<F> AF)) S id\<close> by (simp add: \<F>_mono wKTl)
lemma \<F>_greatestFP_ex: \<open>\<exists>S. greatest (fixpoint (\<F> AF)) S id\<close> by (simp add: \<F>_mono wKTg)

(* The greatest fixed point is not conflict-free. What about the least? *)
lemma "conflictfreeExt AF (tgfp AF)" (*nitpick*) oops (*countermodel found*)
lemma "conflictfreeExt AF (tlfp AF)" (*nitpick*) oops (*neither proven nor disproven*)

(* Emptyset is admissible*)
lemma emptyAdmissible: \<open>admissibleExt AF \<lbrace>-\<rbrace>\<close> by (simp add: admissibleExt_def conflictfreeExt_def)

(* every complete extension is admissible but not the other way round *)
lemma completeAdmissible: \<open>completeExt AF S \<longrightarrow> admissibleExt AF S\<close> by (simp add: completeExt_def)
lemma \<open>admissibleExt AF S \<Longrightarrow> completeExt AF S\<close> nitpick oops

(* Both definitions for complete extensions coincide *)
lemma completeExt_defEq: "completeExt AF S = completeExt2 AF S"
  by (metis admissibleExt_def completeExt_def completeExt2_def fixpoint_def)

section \<open>Preferred extensions - Tests\<close>

(* Dung's "Fundamental lemma" ([Dung 1995] Lemma 10) *)
lemma DungFundLemma1: "admissibleExt AF S \<Longrightarrow> \<forall>a. defends AF S a \<longrightarrow> admissibleExt AF  (S \<union> \<lbrace>a\<rbrace>)"
  by (smt (z3) admissibleExt_def conflictfreeExt_def defends_def)
lemma DungFundLemma2: "admissibleExt AF S \<Longrightarrow> \<forall>a b. defends AF S a \<and> defends AF S b \<longrightarrow> defends AF (S \<union> \<lbrace>a\<rbrace>) b"
  by (smt (verit) defends_def)

(* The following lemma is also quite similar in spirit and might be useful to prove subsequent results *)
lemma aux: "admissibleExt AF S \<Longrightarrow> admissibleExt AF  (S \<union> (\<F> AF S))" by (smt (z3) admissibleExt_def conflictfreeExt_def defends_def)

(********* [Dung 1995] Theorem 11: *************)
(*(1) Admissible sets form an \<omega>-complete poset.*)
(* We can, in fact, prove a stronger statement: admissible extensions form a dcpo*)
lemma admissibleDirectedComplete: "dcpo (admissibleExt AF)"
  unfolding admissibleExt_def conflictfreeExt_def defends_def directedcomplete_def directed_def supremum_def by meson
lemma admissibleOmegaComplete: "\<omega>-cpo (admissibleExt AF)" by (simp add: admissibleDirectedComplete dcpo_\<omega>)

(*(2) For each admissible set S there exists a preferred extension E, such that S \<subseteq> E. *)
lemma DungTh11: "admissibleExt AF S \<longrightarrow> (\<exists>E. S \<subseteq> E \<and> maximal (admissibleExt AF) E id)"
  by (metis ZornLemma2_\<omega> admissibleOmegaComplete)

(* We can also prove that maximal admissible sets always exist*)
lemma preferredExist: "\<exists>S. maximal (admissibleExt AF) S id"
  by (simp add: ZornLemma_\<omega> admissibleOmegaComplete)

(* We can verify that maximally admissible extensions are maximally complete extensions; *)
lemma maxAdmissibleComplete: "maximal (admissibleExt AF) S id \<longrightarrow> maximal (completeExt AF) S id"
  unfolding maximal_def completeExt_def admissibleExt_def by (smt (z3) conflictfreeExt_def defends_def id_apply)

(* The converse direction can proven by making use of the previous results*)
lemma maxCompleteAdmissible: "maximal (completeExt AF) S id \<longrightarrow> maximal (admissibleExt AF) S id"
  by (smt (verit) DungTh11 completeAdmissible id_def maxAdmissibleComplete maximal_def)

(* Finally, we can show that both definitions for preferred extensions coincide *)
lemma preferredExt_defEq: "preferredExt AF S \<longleftrightarrow> preferredExt2 AF S"
  unfolding preferredExt2_def preferredExt_def using maxAdmissibleComplete maxCompleteAdmissible by blast

(* Useful lemma: subsets of preferred extensions are conflict-free*)
lemma preferredConflictfree: "A \<subseteq> B \<Longrightarrow> preferredExt AF B \<Longrightarrow> conflictfreeExt AF A"
  by (smt (verit, best) completeExt2_def completeExt_defEq conflictfreeExt_def maximal_def preferredExt_def)

section \<open>Grounded extensions - Tests\<close>

(* The first two definitions of grounded extensions are shown equivalent
(since \<F> has a least fixed point by the Knaster-Tarski theorem) *)
lemma groundedExt_defEq1: "groundedExt AF S = groundedExt2 AF S"
  unfolding groundedExt_def groundedExt2_def using \<F>_leastFP_ex by (smt (z3) completeExt2_def completeExt_defEq conflictfreeExt_def id_def least_def minimal_def)

(* A key lemma says that minimal/least fixed points of \<F> are conflict-free. This is not at all trivial!
 Quite interestingly, SMT solver can prove this by somehow using the existence of preferred extensions.*)
lemma groundedConflictFree: "least (fixpoint (\<F> AF)) S id \<longrightarrow> conflictfreeExt AF S"
  by (smt (verit, ccfv_threshold) completeExt2_def completeExt_defEq conflictfreeExt_def id_apply least_def maxAdmissibleComplete maximal_def preferredExist)

(* We can show automatically that Dung's definition is equivalent to the other ones*)
lemma groundedExt_defEq2: "groundedExt2 AF S = groundedExt3 AF S"
  by (smt (verit, best) \<F>_mono completeExt2_def completeExt_defEq groundedConflictFree groundedExt2_def groundedExt3_def least_def wKTl')

section \<open>Ideal extensions - Tests\<close>

(* Ideal sets are closed under union *)
lemma idealSetUnion: "idealSet AF A \<Longrightarrow> idealSet AF B \<Longrightarrow> idealSet AF (A\<union>B)" proof -
  assume 1: "idealSet AF A" and 2: "idealSet AF B"
  hence 3: "conflictfreeExt AF (A\<union>B)"
    by (smt (verit) idealSet_def preferredConflictfree preferredExist preferredExt2_def preferredExt_defEq)
  from 1 2 3 show "idealSet AF (A\<union>B)" unfolding idealSet_def preferredExt_def admissibleExt_def by (smt (z3) MONO_def \<F>_mono)
qed

(* both definitions of ideal extensions (i.e. maximal ideal sets) are equivalent *)
lemma idealExt_defEq: "idealExt2 AF S = idealExt AF S"
  unfolding idealExt_def idealExt2_def maximal_def greatest_def
  using idealSetUnion id_def by (smt (verit, del_insts))

section \<open>Stable extensions - Tests\<close>

lemma stableExt_defEq: "stableExt AF S = stableExt2 AF S"
  by (metis (mono_tags, lifting) range_def conflictfreeExt_def plusset_def stableExt2_def stableExt_def)

section \<open>Semistable extensions - Tests\<close>
(*TODO*)

section \<open>Stage extensions - Tests\<close>
(*TODO*)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Missing Ring\<close>

text \<open>This theory contains several lemmas which might be of interest to the Isabelle distribution.\<close>

theory Missing_Ring
imports
  "HOL-Algebra.Ring"
begin

context comm_monoid
begin

lemma finprod_reindex_bij_betw: "bij_betw h S T
  \<Longrightarrow> g \<in> h ` S \<rightarrow> carrier G
  \<Longrightarrow> finprod G (\<lambda>x. g (h x)) S = finprod G g T"
  using finprod_reindex[of g h S] unfolding bij_betw_def by auto

lemma finprod_reindex_bij_witness:
  assumes witness:
    "\<And>a. a \<in> S \<Longrightarrow> i (j a) = a"
    "\<And>a. a \<in> S \<Longrightarrow> j a \<in> T"
    "\<And>b. b \<in> T \<Longrightarrow> j (i b) = b"
    "\<And>b. b \<in> T \<Longrightarrow> i b \<in> S"
  assumes eq:
    "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
  assumes g: "g \<in> S \<rightarrow> carrier G"
  and h: "h \<in> j ` S \<rightarrow> carrier G"
  shows "finprod G g S = finprod G h T"
proof -
  have b: "bij_betw j S T"
    using bij_betw_byWitness[where A=S and f=j and f'=i and A'=T] witness by auto
  have fp: "finprod G g S = finprod G (\<lambda>x. h (j x)) S"
    by (rule finprod_cong, insert eq g, auto)
  show ?thesis
    using finprod_reindex_bij_betw[OF b h] unfolding fp .
qed
end

lemmas (in abelian_monoid) finsum_reindex_bij_witness = add.finprod_reindex_bij_witness

locale csemiring = semiring + comm_monoid R

context cring
begin
sublocale csemiring ..
end

lemma (in comm_monoid) finprod_one':
  "(\<And> a. a \<in> A \<Longrightarrow> f a = \<one>) \<Longrightarrow> finprod G f A = \<one>"
  by (induct A rule: infinite_finite_induct, auto)

lemma (in comm_monoid) finprod_split:
  "finite A \<Longrightarrow> f ` A \<subseteq> carrier G \<Longrightarrow> a \<in> A \<Longrightarrow> finprod G f A = f a \<otimes> finprod G f (A - {a})"
  by (rule trans[OF trans[OF _ finprod_Un_disjoint[of "{a}" "A - {a}" f]]], auto,
  rule arg_cong[of _ _ "finprod G f"], auto)

lemma (in comm_monoid) finprod_finprod:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> (\<And> a b. a \<in> A  \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> carrier G) \<Longrightarrow>
  finprod G (\<lambda> a. finprod G (g a) B) A = finprod G (\<lambda> (a,b). g a b) (A \<times> B)"
proof (induct A rule: finite_induct)
  case (insert a' A)
  note IH = this
  let ?l = "(\<Otimes>a\<in>insert a' A. finprod G (g a) B)"
  let ?r = "(\<Otimes>a\<in>insert a' A \<times> B. case a of (a, b) \<Rightarrow> g a b)"
  have "?l = finprod G (g a') B \<otimes> (\<Otimes>a\<in>A. finprod G (g a) B)"
    using IH by simp
  also have "(\<Otimes>a\<in>A. finprod G (g a) B) = finprod G (\<lambda> (a,b). g a b) (A \<times> B)"
    by (rule IH(3), insert IH, auto)
  finally have idl: "?l = finprod G (g a') B \<otimes> finprod G (\<lambda> (a,b). g a b) (A \<times> B)" .
  from IH(2) have "insert a' A \<times> B = {a'} \<times> B \<union> A \<times> B" by auto
  hence "?r = (\<Otimes>a\<in>{a'} \<times> B \<union> A \<times> B. case a of (a, b) \<Rightarrow> g a b)" by simp
  also have "\<dots> = (\<Otimes>a\<in>{a'} \<times> B. case a of (a, b) \<Rightarrow> g a b) \<otimes> (\<Otimes>a\<in> A \<times> B. case a of (a, b) \<Rightarrow> g a b)"
    by (rule finprod_Un_disjoint, insert IH, auto)
  also have "(\<Otimes>a\<in>{a'} \<times> B. case a of (a, b) \<Rightarrow> g a b) = finprod G (g a') B"
    using IH(4) IH(5)
  proof (induct B rule: finite_induct)
    case (insert b' B)
    note IH = this
    have id: "(\<Otimes>a\<in>{a'} \<times> B. case a of (a, b) \<Rightarrow> g a b) = finprod G (g a') B"
      by (rule IH(3)[OF IH(4)], auto)
    have id2: "\<And> x F. {a'} \<times> insert x F = insert (a',x) ({a'} \<times> F)" by auto
    have id3: "(\<Otimes>a\<in>insert (a', b') ({a'} \<times> B). case a of (a, b) \<Rightarrow> g a b)
      = g a' b' \<otimes> (\<Otimes>a\<in>({a'} \<times> B). case a of (a, b) \<Rightarrow> g a b)"
      by (rule trans[OF finprod_insert], insert IH, auto)
    show ?case unfolding id2 id3 id
      by (rule sym, rule finprod_insert, insert IH, auto)
  qed simp
  finally have idr: "?r = finprod G (g a') B \<otimes> (\<Otimes>a\<in>A \<times> B. case a of (a, b) \<Rightarrow> g a b)" .
  show ?case unfolding idl idr ..
qed simp

lemma (in comm_monoid) finprod_swap:
  assumes "finite A" "finite B" "\<And> a b. a \<in> A  \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> carrier G"
  shows "finprod G (\<lambda> (b,a). g a b) (B \<times> A) = finprod G (\<lambda> (a,b). g a b) (A \<times> B)"
proof -
  have [simp]: "(\<lambda>(a, b). (b, a)) ` (A \<times> B) = B \<times> A" by auto
  have [simp]: "(\<lambda> x. case case x of (a, b) \<Rightarrow> (b, a) of (a, b) \<Rightarrow> g b a) = (\<lambda> (a,b). g a b)"
    by (intro ext, auto)
  show ?thesis
    by (rule trans[OF trans[OF _ finprod_reindex[of "\<lambda> (a,b). g b a" "\<lambda> (a,b). (b,a)"]]],
    insert assms, auto simp: inj_on_def)
qed

lemma (in comm_monoid) finprod_finprod_swap:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> (\<And> a b. a \<in> A  \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> carrier G) \<Longrightarrow>
  finprod G (\<lambda> a. finprod G (g a) B) A = finprod G (\<lambda> b. finprod G (\<lambda> a. g a b) A) B"
  using finprod_finprod[of A B] finprod_finprod[of B A] finprod_swap[of A B]
  by simp

lemmas (in semiring) finsum_zero' = add.finprod_one'
lemmas (in semiring) finsum_split = add.finprod_split
lemmas (in semiring) finsum_finsum_swap = add.finprod_finprod_swap

lemma (in csemiring) finprod_zero:
  "finite A \<Longrightarrow> f \<in> A \<rightarrow> carrier R \<Longrightarrow> \<exists>a\<in>A. f a = \<zero>
   \<Longrightarrow> finprod R f A = \<zero>"
proof (induct A rule: finite_induct)
  case (insert a A)
  from finprod_insert[OF insert(1-2), of f] insert(4)
  have ins: "finprod R f (insert a A) = f a \<otimes> finprod R f A" by simp
  have fA: "finprod R f A \<in> carrier R"
    by (rule finprod_closed, insert insert, auto)
  show ?case
  proof (cases "f a = \<zero>")
    case True
    with fA show ?thesis unfolding ins by simp
  next
    case False
    with insert(5) have "\<exists> a \<in> A. f a = \<zero>" by auto
    from insert(3)[OF _ this] insert have "finprod R f A = \<zero>" by auto
    with insert show ?thesis unfolding ins by auto
  qed
qed simp

lemma (in semiring) finsum_product:
  assumes A: "finite A" and B: "finite B"
  and f: "f \<in> A \<rightarrow> carrier R" and g: "g \<in> B \<rightarrow> carrier R"
  shows "finsum R f A \<otimes> finsum R g B = (\<Oplus>i\<in>A. \<Oplus>j\<in>B. f i \<otimes> g j)"
  unfolding finsum_ldistr[OF A finsum_closed[OF g] f]
proof (rule finsum_cong'[OF refl])
  fix a
  assume a: "a \<in> A"
  show "f a \<otimes> finsum R g B = (\<Oplus>j\<in>B. f a \<otimes> g j)"
  by (rule finsum_rdistr[OF B _ g], insert a f, auto)
qed (insert f g B, auto intro: finsum_closed)

lemma (in semiring) Units_one_side_I:
  "a \<in> carrier R \<Longrightarrow> p \<in> Units R \<Longrightarrow> p \<otimes> a = \<one> \<Longrightarrow> a \<in> Units R"
  "a \<in> carrier R \<Longrightarrow> p \<in> Units R \<Longrightarrow> a \<otimes> p = \<one> \<Longrightarrow> a \<in> Units R"
  by (metis Units_closed Units_inv_Units Units_l_inv inv_unique)+

context ordered_cancel_semiring begin
subclass ordered_cancel_ab_semigroup_add ..
end

text \<open>partially ordered variant\<close>
class ordered_semiring_strict = semiring + comm_monoid_add + ordered_cancel_ab_semigroup_add +
  assumes mult_strict_left_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
  assumes mult_strict_right_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> a * c < b * c"
begin

subclass semiring_0_cancel ..

subclass ordered_semiring
proof
  fix a b c :: 'a
  assume A: "a \<le> b" "0 \<le> c"
  from A show "c * a \<le> c * b"
    unfolding le_less
    using mult_strict_left_mono by (cases "c = 0") auto
  from A show "a * c \<le> b * c"
    unfolding le_less
    using mult_strict_right_mono by (cases "c = 0") auto
qed

lemma mult_pos_pos[simp]: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a * b"
using mult_strict_left_mono [of 0 b a] by simp

lemma mult_pos_neg: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> a * b < 0"
using mult_strict_left_mono [of b 0 a] by simp

lemma mult_neg_pos: "a < 0 \<Longrightarrow> 0 < b \<Longrightarrow> a * b < 0"
using mult_strict_right_mono [of a 0 b] by simp

text \<open>Legacy - use \<open>mult_neg_pos\<close>\<close>
lemma mult_pos_neg2: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> b * a < 0"
by (drule mult_strict_right_mono [of b 0], auto)

text\<open>Strict monotonicity in both arguments\<close>
lemma mult_strict_mono:
  assumes "a < b" and "c < d" and "0 < b" and "0 \<le> c"
  shows "a * c < b * d"
  using assms apply (cases "c=0")
  apply (simp)
  apply (erule mult_strict_right_mono [THEN less_trans])
  apply (force simp add: le_less)
  apply (erule mult_strict_left_mono, assumption)
  done

text\<open>This weaker variant has more natural premises\<close>
lemma mult_strict_mono':
  assumes "a < b" and "c < d" and "0 \<le> a" and "0 \<le> c"
  shows "a * c < b * d"
by (rule mult_strict_mono) (insert assms, auto)

lemma mult_less_le_imp_less:
  assumes "a < b" and "c \<le> d" and "0 \<le> a" and "0 < c"
  shows "a * c < b * d"
  using assms apply (subgoal_tac "a * c < b * c")
  apply (erule less_le_trans)
  apply (erule mult_left_mono)
  apply simp
  apply (erule mult_strict_right_mono)
  apply assumption
  done

lemma mult_le_less_imp_less:
  assumes "a \<le> b" and "c < d" and "0 < a" and "0 \<le> c"
  shows "a * c < b * d"
  using assms apply (subgoal_tac "a * c \<le> b * c")
  apply (erule le_less_trans)
  apply (erule mult_strict_left_mono)
  apply simp
  apply (erule mult_right_mono)
  apply simp
  done

end

class ordered_idom = idom + ordered_semiring_strict +
  assumes zero_less_one [simp]: "0 < 1" begin

subclass semiring_1 ..
subclass comm_ring_1 ..
subclass ordered_ring ..
subclass ordered_comm_semiring by(unfold_locales, fact mult_left_mono)
subclass ordered_ab_semigroup_add ..

lemma of_nat_ge_0[simp]: "of_nat x \<ge> 0"
proof (induct x)
  case 0 thus ?case by auto
  next case (Suc x)
    hence "0 \<le> of_nat x" by auto
    also have "of_nat x < of_nat (Suc x)" by auto
    finally show ?case by auto
qed

lemma of_nat_eq_0[simp]: "of_nat x = 0 \<longleftrightarrow> x = 0"
proof(induct x,simp)
  case (Suc x)
    have "of_nat (Suc x) > 0" apply(rule le_less_trans[of _ "of_nat x"]) by auto
    thus ?case by auto
qed

lemma inj_of_nat: "inj (of_nat :: nat \<Rightarrow> 'a)"
proof(rule injI)
  fix x y show "of_nat x = of_nat y \<Longrightarrow> x = y"
  proof (induct x arbitrary: y)
    case 0 thus ?case
      proof (induct y)
        case 0 thus ?case by auto
        next case (Suc y)
          hence "of_nat (Suc y) = 0" by auto
          hence "Suc y = 0" unfolding of_nat_eq_0 by auto
          hence False by auto
          thus ?case by auto
      qed
    next case (Suc x)
      thus ?case
      proof (induct y)
        case 0
          hence "of_nat (Suc x) = 0" by auto
          hence "Suc x = 0" unfolding of_nat_eq_0 by auto
          hence False by auto
          thus ?case by auto
        next case (Suc y) thus ?case by auto
      qed
  qed
qed

subclass ring_char_0 by(unfold_locales, fact inj_of_nat)

end

(*
instance linordered_idom \<subseteq> ordered_semiring_strict by (intro_classes,auto)
instance linordered_idom \<subseteq> ordered_idom by (intro_classes, auto)
*)

end


(*  Title:       Noninterference Security in Communicating Sequential Processes
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "Noninterference in CSP"

theory CSPNoninterference
imports Main
begin

text \<open>
\null

An extension of classical noninterference security for deterministic state machines, as introduced
by Goguen and Meseguer \cite{R2} and elegantly formalized by Rushby \cite{R3}, to nondeterministic
systems should satisfy two fundamental requirements: it should be based on a mathematically precise
theory of nondeterminism, and should be equivalent to (or at least not weaker than) the classical
notion in the degenerate deterministic case.

The purpose of this section is to formulate a definition of noninterference security that meet these
requirements, applying to the concept of process as formalized by Hoare in his remarkable theory of
Communicating Sequential Processes (CSP) \cite{R1}. The general case of a possibly intransitive
noninterference policy will be considered.

Throughout this paper, the salient points of definitions and proofs are commented; for additional
information see Isabelle documentation, particularly \cite{R5}, \cite{R6}, \cite{R7}, and \cite{R8}.
\<close>

subsection "Processes"

text \<open>
It is convenient to represent CSP processes by means of a type definition including a type variable,
which stands for the process alphabet. Type \<open>process\<close> shall then be isomorphic to the subset
of the product type of failures sets and divergences sets comprised of the pairs that satisfy the
properties enunciated in \cite{R1}, section 3.9. Such subset shall be shown to contain process
\emph{STOP}, which proves that it is nonempty.

Property \emph{C5} is not considered as it is entailed by \emph{C7}. Moreover, the formalization of
properties \emph{C2} and \emph{C6} only takes into account event lists \emph{t} containing a single
item. Such formulation is equivalent to the original one, since the truth of \emph{C2} and \emph{C6}
for a singleton list \emph{t} immediately derives from that for a generic list, and conversely:

\begin{itemize}

\item
the truth of \emph{C2} and \emph{C6} for a generic nonempty list \emph{t} results from the repeated
application of \emph{C2} and \emph{C6} for a singleton list;

\item
the truth of \emph{C2} for \emph{t} matching the empty list is implied by property \emph{C3};

\item
the truth of \emph{C6} for \emph{t} matching the empty list is a tautology.

\end{itemize}

The advantage of the proposed formulation is that it facilitates the task to prove that pairs of
failures and divergences sets defined inductively indeed be processes, viz. be included in the set
of pairs isomorphic to type \<open>process\<close>, since the introduction rules in such inductive
definitions will typically construct process traces by appending one item at a time.

In what follows, the concept of process is formalized according to the previous considerations.

\null
\<close>

type_synonym 'a failure = "'a list \<times> 'a set"

type_synonym 'a process_prod = "'a failure set \<times> 'a list set"

definition process_prop_1 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_1 P \<equiv> ([], {}) \<in> fst P"

definition process_prop_2 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_2 P \<equiv> \<forall>xs x X. (xs @ [x], X) \<in> fst P \<longrightarrow> (xs, {}) \<in> fst P"

definition process_prop_3 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_3 P \<equiv> \<forall>xs X Y. (xs, Y) \<in> fst P \<and> X \<subseteq> Y \<longrightarrow> (xs, X) \<in> fst P"

definition process_prop_4 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_4 P \<equiv> \<forall>xs x X. (xs, X) \<in> fst P \<longrightarrow>
  (xs @ [x], {}) \<in> fst P \<or> (xs, insert x X) \<in> fst P"

definition process_prop_5 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_5 P \<equiv> \<forall>xs x. xs \<in> snd P \<longrightarrow> xs @ [x] \<in> snd P"

definition process_prop_6 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_6 P \<equiv> \<forall>xs X. xs \<in> snd P \<longrightarrow> (xs, X) \<in> fst P"

definition process_set :: "'a process_prod set" where
"process_set \<equiv> {P.
  process_prop_1 P \<and>
  process_prop_2 P \<and>
  process_prop_3 P \<and>
  process_prop_4 P \<and>
  process_prop_5 P \<and>
  process_prop_6 P}"

typedef 'a process = "process_set :: 'a process_prod set"
by (rule_tac x = "({(xs, X). xs = []}, {})" in exI, simp add:
  process_set_def
  process_prop_1_def
  process_prop_2_def
  process_prop_3_def
  process_prop_4_def
  process_prop_5_def
  process_prop_6_def)

text \<open>
\null

Here below are the definitions of some functions acting on processes. Functions \<open>failures\<close>,
\<open>traces\<close>, and \<open>deterministic\<close> match the homonymous notions defined in \cite{R1}. As for
the other ones:

\begin{itemize}

\item
\<open>futures P xs\<close> matches the failures set of process \emph{P / xs};

\item
\<open>refusals P xs\<close> matches the refusals set of process \emph{P / xs};

\item
\<open>next_events P xs\<close> matches the event set (\emph{P / xs})\textsuperscript{0}.

\end{itemize}

\null
\<close>

definition failures :: "'a process \<Rightarrow> 'a failure set" where
"failures P \<equiv> fst (Rep_process P)"

definition futures :: "'a process \<Rightarrow> 'a list \<Rightarrow> 'a failure set" where
"futures P xs \<equiv> {(ys, Y). (xs @ ys, Y) \<in> failures P}"

definition traces :: "'a process \<Rightarrow> 'a list set" where
"traces P \<equiv> Domain (failures P)"

definition refusals :: "'a process \<Rightarrow> 'a list \<Rightarrow> 'a set set" where
"refusals P xs \<equiv> failures P `` {xs}"

definition next_events :: "'a process \<Rightarrow> 'a list \<Rightarrow> 'a set" where
"next_events P xs \<equiv> {x. xs @ [x] \<in> traces P}"

definition deterministic :: "'a process \<Rightarrow> bool" where
"deterministic P \<equiv>
  \<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"

text \<open>
\null

In what follows, properties \<open>process_prop_2\<close> and \<open>process_prop_3\<close> of processes are put
into the form of introduction rules, which will turn out to be useful in subsequent proofs.
Particularly, the more general formulation of \<open>process_prop_2\<close> as given in \cite{R1} (section
3.9, property \emph{C2}) is restored, and it is expressed in terms of both functions
\<open>failures\<close> and \<open>futures\<close>.

\null
\<close>

lemma process_rule_2: "(xs @ [x], X) \<in> failures P \<Longrightarrow> (xs, {}) \<in> failures P"
proof (simp add: failures_def)
  have "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "\<forall>xs x X. (xs @ [x], X) \<in> fst ?P' \<longrightarrow> (xs, {}) \<in> fst ?P'"
   by (simp add: process_set_def process_prop_2_def)
  thus "(xs @ [x], X) \<in> fst ?P' \<Longrightarrow> (xs, {}) \<in> fst ?P'" by blast
qed

lemma process_rule_3: "(xs, Y) \<in> failures P \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> (xs, X) \<in> failures P"
proof (simp add: failures_def)
  have "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "\<forall>xs X Y. (xs, Y) \<in> fst ?P' \<and> X \<subseteq> Y \<longrightarrow> (xs, X) \<in> fst ?P'"
   by (simp add: process_set_def process_prop_3_def)
  thus "(xs, Y) \<in> fst ?P' \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> (xs, X) \<in> fst ?P'" by blast
qed

lemma process_rule_2_failures [rule_format]:
 "(xs @ xs', X) \<in> failures P \<longrightarrow> (xs, {}) \<in> failures P"
proof (induction xs' arbitrary: X rule: rev_induct, rule_tac [!] impI, simp)
  fix X
  assume "(xs, X) \<in> failures P"
  moreover have "{} \<subseteq> X" ..
  ultimately show "(xs, {}) \<in> failures P" by (rule process_rule_3)
next
  fix x xs' X
  assume "\<And>X. (xs @ xs', X) \<in> failures P \<longrightarrow> (xs, {}) \<in> failures P"
  hence "(xs @ xs', {}) \<in> failures P \<longrightarrow> (xs, {}) \<in> failures P" .
  moreover assume "(xs @ xs' @ [x], X) \<in> failures P"
  hence "((xs @ xs') @ [x], X) \<in> failures P" by simp
  hence "(xs @ xs', {}) \<in> failures P" by (rule process_rule_2)
  ultimately show "(xs, {}) \<in> failures P" ..
qed

lemma process_rule_2_futures:
 "(ys @ ys', Y) \<in> futures P xs \<Longrightarrow> (ys, {}) \<in> futures P xs"
by (simp add: futures_def, simp only: append_assoc [symmetric], rule process_rule_2_failures)

subsection "Noninterference"

text \<open>
In the classical theory of noninterference, a deterministic state machine is considered to be secure
just in case, for any trace of the machine and any action occurring next, the observable effect of
the action, i.e. the produced output, is compatible with the assigned noninterference policy.

Thus, by analogy, it seems reasonable to regard a process as being noninterference-secure just in
case, for any of its traces and any event occurring next, the observable effect of the event, i.e.
the set of the possible futures of the process, is compatible with a given noninterference policy.

More precisely, let \<open>sinks I D u xs\<close> be the set of the security domains of the events within
event list \<open>xs\<close> that may be affected by domain \<open>u\<close> according to interference relation
\<open>I\<close>, where \<open>D\<close> is the mapping of events into their domains. Since the general case of a
possibly intransitive relation \<open>I\<close> is considered, function \<open>sinks\<close> has to be defined
recursively, similarly to what happens for function \emph{sources} in \cite{R3}. However,
contrariwise to function \emph{sources}, function \<open>sinks\<close> takes into account the influence of
the input domain on the input event list, so that the recursive decomposition of the latter has to
be performed by item appending rather than prepending.

Furthermore, let \<open>ipurge_tr I D u xs\<close> be the sublist of event list \<open>xs\<close> obtained by
recursively deleting the events that may be affected by domain \<open>u\<close> as detected via function
\<open>sinks\<close>, and \<open>ipurge_ref I D u xs X\<close> be the subset of refusal \<open>X\<close> whose elements
may not be affected by either \<open>u\<close> or any domain in \<open>sinks I D u xs\<close>.

Then, a process \<open>P\<close> is secure just in case, for each event list \<open>xs\<close> and each
\<open>(y # ys, Y), (zs, Z) \<in> futures P xs\<close>, both of the following conditions are satisfied:

\begin{itemize}

\item
\<open>(ipurge_tr I D (D y) ys, ipurge_ref I D (D y) ys Y) \<in> futures P xs\<close>.
\\Otherwise, the absence of event \<open>y\<close> after \<open>xs\<close> would affect the possibility for pair
\<open>(ipurge_tr I D (D y) ys, ipurge_ref I D (D y) ys Y)\<close> to occur as a future of \<open>xs\<close>,
although its components, except for the deletion of \<open>y\<close>, are those of possible future
\<open>(y # ys, Y)\<close> deprived of any event allowed to be affected by \<open>y\<close>.

\item
\<open>(y # ipurge_tr I D (D y) zs, ipurge_ref I D (D y) zs Z)\<close>
\\\<open>\<in> futures P xs\<close>.
\\Otherwise, the presence of event \<open>y\<close> after \<open>xs\<close> would affect the possibility for pair
\<open>(y # ipurge_tr I D (D y) zs, ipurge_ref I D (D y) zs Z)\<close> to occur as a future of
\<open>xs\<close>, although its components, except for the addition of \<open>y\<close>, are those of possible
future \<open>(zs, Z)\<close> deprived of any event allowed to be affected by \<open>y\<close>.

\end{itemize}

Observe that this definition of security, henceforth referred to as
\emph{CSP noninterference security}, does not rest on the supposition that noninterference policy
\<open>I\<close> be reflexive, even though any policy of practical significance will be such.

Moreover, this simpler formulation is equivalent to the one obtained by restricting the range of
event list \<open>xs\<close> to the traces of process \<open>P\<close>. In fact, for each \<open>zs\<close>, \<open>Z\<close>,
\<open>(zs, Z) \<in> futures P xs\<close> just in case \<open>(xs @ zs, Z) \<in> failures P\<close>, which by virtue
of rule \<open>process_rule_2_failures\<close> implies that \<open>xs\<close> is a trace of \<open>P\<close>. Therefore,
formula \<open>(zs, Z) \<in> futures P xs\<close> is invariably false in case \<open>xs\<close> is not a trace of
\<open>P\<close>.

Here below are the formal counterparts of the definitions discussed so far.

\null
\<close>

function sinks :: "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'd set" where
"sinks _ _ _ [] = {}" |
"sinks I D u (xs @ [x]) = (if (u, D x) \<in> I \<or> (\<exists>v \<in> sinks I D u xs. (v, D x) \<in> I)
  then insert (D x) (sinks I D u xs)
  else sinks I D u xs)"
proof (atomize_elim, simp_all add: split_paired_all)
qed (rule rev_cases, rule disjI1, assumption, simp)
termination by lexicographic_order

function ipurge_tr :: "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"ipurge_tr _ _ _ [] = []" |
"ipurge_tr I D u (xs @ [x]) = (if D x \<in> sinks I D u (xs @ [x])
  then ipurge_tr I D u xs
  else ipurge_tr I D u xs @ [x])"
proof (atomize_elim, simp_all add: split_paired_all)
qed (rule rev_cases, rule disjI1, assumption, simp)
termination by lexicographic_order

definition ipurge_ref ::
 "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'a set \<Rightarrow> 'a set" where
"ipurge_ref I D u xs X \<equiv>
  {x \<in> X. (u, D x) \<notin> I \<and> (\<forall>v \<in> sinks I D u xs. (v, D x) \<notin> I)}"

definition secure :: "'a process \<Rightarrow> ('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> bool" where
"secure P I D \<equiv>
  \<forall>xs y ys Y zs Z. (y # ys, Y) \<in> futures P xs \<and> (zs, Z) \<in> futures P xs \<longrightarrow>
  (ipurge_tr I D (D y) ys, ipurge_ref I D (D y) ys Y) \<in> futures P xs \<and>
  (y # ipurge_tr I D (D y) zs, ipurge_ref I D (D y) zs Z) \<in> futures P xs"

text \<open>
\null

The continuation of this section is dedicated to the demonstration of some lemmas concerning
functions \<open>sinks\<close>, \<open>ipurge_tr\<close>, and \<open>ipurge_ref\<close> which will turn out to be useful
in subsequent proofs.

\null
\<close>

lemma sinks_cons_same:
  assumes R: "refl I"
  shows "sinks I D (D x) (x # xs) = insert (D x) (sinks I D (D x) xs)"
proof (rule rev_induct, simp)
  have A: "[x] = [] @ [x]" by simp
  have "sinks I D (D x) [x] = (if (D x, D x) \<in> I \<or> (\<exists>v \<in> {}. (v, D x) \<in> I)
    then insert (D x) {}
    else {})"
   by (subst A, simp only: sinks.simps)
  moreover have "(D x, D x) \<in> I" using R by (simp add: refl_on_def)
  ultimately show "sinks I D (D x) [x] = {D x}" by simp
next
  fix x' xs
  assume A: "sinks I D (D x) (x # xs) = insert (D x) (sinks I D (D x) xs)"
  show "sinks I D (D x) (x # xs @ [x']) =
    insert (D x) (sinks I D (D x) (xs @ [x']))"
  proof (cases "(D x, D x') \<in> I \<or> (\<exists>v \<in> sinks I D (D x) xs. (v, D x') \<in> I)",
   simp_all (no_asm_simp))
    case True
    hence "(D x, D x') \<in> I \<or> (\<exists>v \<in> sinks I D (D x) (x # xs). (v, D x') \<in> I)"
     using A by simp
    hence "sinks I D (D x) ((x # xs) @ [x']) =
      insert (D x') (sinks I D (D x) (x # xs))"
     by (simp only: sinks.simps if_True)
    thus "sinks I D (D x) (x # xs @ [x']) =
      insert (D x) (insert (D x') (sinks I D (D x) xs))"
     using A by (simp add: insert_commute)
  next
    case False
    hence "\<not> ((D x, D x') \<in> I \<or> (\<exists>v \<in> sinks I D (D x) (x # xs). (v, D x') \<in> I))"
     using A by simp
    hence "sinks I D (D x) ((x # xs) @ [x']) = sinks I D (D x) (x # xs)"
     by (simp only: sinks.simps if_False)
    thus "sinks I D (D x) (x # xs @ [x']) = insert (D x) (sinks I D (D x) xs)"
     using A by simp
  qed
qed

lemma ipurge_tr_cons_same:
  assumes R: "refl I"
  shows "ipurge_tr I D (D x) (x # xs) = ipurge_tr I D (D x) xs"
proof (induction xs rule: rev_induct, simp)
  have A: "[x] = [] @ [x]" by simp
  have "ipurge_tr I D (D x) [x] = (if D x \<in> sinks I D (D x) ([] @ [x])
    then []
    else [] @ [x])"
   by (subst A, simp only: ipurge_tr.simps)
  moreover have "sinks I D (D x) [x] = {D x}"
   using R by (simp add: sinks_cons_same)
  ultimately show "ipurge_tr I D (D x) [x] = []" by simp
next
  fix x' xs
  assume A: "ipurge_tr I D (D x) (x # xs) = ipurge_tr I D (D x) xs"
  show "ipurge_tr I D (D x) (x # xs @ [x']) = ipurge_tr I D (D x) (xs @ [x'])"
  proof (cases "D x' \<in> sinks I D (D x) (x # xs @ [x'])")
    assume B: "D x' \<in> sinks I D (D x) (x # xs @ [x'])"
    hence "D x' \<in> sinks I D (D x) ((x # xs) @ [x'])" by simp
    hence "ipurge_tr I D (D x) ((x # xs) @ [x']) = ipurge_tr I D (D x) (x # xs)"
     by (simp only: ipurge_tr.simps if_True)
    hence C: "ipurge_tr I D (D x) (x # xs @ [x']) = ipurge_tr I D (D x) xs"
     using A by simp
    have "D x' = D x \<or> D x' \<in> sinks I D (D x) (xs @ [x'])"
     using R and B by (simp add: sinks_cons_same)
    moreover {
      assume "D x' = D x"
      hence "(D x, D x') \<in> I" using R by (simp add: refl_on_def)
      hence "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs" by simp
    }
    moreover {
      assume "D x' \<in> sinks I D (D x) (xs @ [x'])"
      hence "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs" by simp
    }
    ultimately have D: "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs"
     by blast
    show ?thesis using C and D by simp
  next
    assume B: "D x' \<notin> sinks I D (D x) (x # xs @ [x'])"
    hence "D x' \<notin> sinks I D (D x) ((x # xs) @ [x'])" by simp
    hence "ipurge_tr I D (D x) ((x # xs) @ [x']) =
      ipurge_tr I D (D x) (x # xs) @ [x']"
     by (simp only: ipurge_tr.simps if_False)
    hence "ipurge_tr I D (D x) (x # xs @ [x']) = ipurge_tr I D (D x) xs @ [x']"
     using A by simp
    moreover have "\<not> (D x' = D x \<or> D x' \<in> sinks I D (D x) (xs @ [x']))"
     using R and B by (simp add: sinks_cons_same)
    hence "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs @ [x']"
     by simp
    ultimately show ?thesis by simp
  qed
qed

lemma sinks_cons_nonint:
  assumes A: "(u, D x) \<notin> I"
  shows "sinks I D u (x # xs) = sinks I D u xs"
proof (rule rev_induct, simp)
  have "sinks I D u [x] = sinks I D u ([] @ [x])" by simp
  hence "sinks I D u [x] = (if (u, D x) \<in> I \<or> (\<exists>v \<in> {}. (v, D x) \<in> I)
    then insert (D x) {}
    else {})"
   by (simp only: sinks.simps)
  thus "sinks I D u [x] = {}" using A by simp
next
  fix xs x'
  assume B: "sinks I D u (x # xs) = sinks I D u xs" (is "?d' = ?d")
  have "x # xs @ [x'] = (x # xs) @ [x']" by simp
  hence C: "sinks I D u (x # xs @ [x']) =
    (if (u, D x') \<in> I \<or> (\<exists>v \<in> ?d'. (v, D x') \<in> I)
    then insert (D x') ?d'
    else ?d')"
    by (simp only: sinks.simps)
  show "sinks I D u (x # xs @ [x']) = sinks I D u (xs @ [x'])"
  proof (cases "(u, D x') \<in> I \<or> (\<exists>v \<in> ?d. (v, D x') \<in> I)")
    case True
    with B and C have "sinks I D u (x # xs @ [x']) = insert (D x') ?d"
      by simp
    with True show ?thesis by simp
  next
    case False
    with B and C have "sinks I D u (x # xs @ [x']) = ?d" by simp
    with False show ?thesis by simp
  qed
qed

lemma sinks_empty [rule_format]:
 "sinks I D u xs = {} \<longrightarrow> ipurge_tr I D u xs = xs"
proof (rule rev_induct, simp, rule impI)
  fix x xs
  assume A: "sinks I D u (xs @ [x]) = {}"
  moreover have "sinks I D u xs \<subseteq> sinks I D u (xs @ [x])"
   by (simp add: subset_insertI)
  ultimately have "sinks I D u xs = {}" by simp
  moreover assume "sinks I D u xs = {} \<longrightarrow> ipurge_tr I D u xs = xs"
  ultimately have "ipurge_tr I D u xs = xs" by (rule rev_mp)
  thus "ipurge_tr I D u (xs @ [x]) = xs @ [x]" using A by simp
qed

lemma ipurge_ref_eq:
  assumes A: "D x \<in> sinks I D u (xs @ [x])"
  shows "ipurge_ref I D u (xs @ [x]) X =
    ipurge_ref I D u xs {x' \<in> X. (D x, D x') \<notin> I}"
proof (rule equalityI, rule_tac [!] subsetI, simp_all add: ipurge_ref_def del: sinks.simps,
 (erule conjE)+, (erule_tac [2] conjE)+)
  fix y
  assume B: "\<forall>v \<in> sinks I D u (xs @ [x]). (v, D y) \<notin> I"
  show "(D x, D y) \<notin> I \<and> (\<forall>v \<in> sinks I D u xs. (v, D y) \<notin> I)"
  proof (rule conjI, rule_tac [2] ballI)
    show "(D x, D y) \<notin> I" using B and A ..
  next
    fix v
    assume "v \<in> sinks I D u xs"
    hence "v \<in> sinks I D u (xs @ [x])" by simp
    with B show "(v, D y) \<notin> I" ..
  qed
next
  fix y
  assume
    B: "(D x, D y) \<notin> I" and
    C: "\<forall>v \<in> sinks I D u xs. (v, D y) \<notin> I"
  show "\<forall>v \<in> sinks I D u (xs @ [x]). (v, D y) \<notin> I"
  proof (rule ballI, cases "(u, D x) \<in> I \<or> (\<exists>v \<in> sinks I D u xs. (v, D x) \<in> I)")
    fix v
    case True
    moreover assume "v \<in> sinks I D u (xs @ [x])"
    ultimately have "v = D x \<or> v \<in> sinks I D u xs" by simp
    moreover {
      assume "v = D x"
      with B have "(v, D y) \<notin> I" by simp
    }
    moreover {
      assume "v \<in> sinks I D u xs"
      with C have "(v, D y) \<notin> I" ..
    }
    ultimately show "(v, D y) \<notin> I" by blast
  next
    fix v
    case False
    moreover assume "v \<in> sinks I D u (xs @ [x])"
    ultimately have "v \<in> sinks I D u xs" by simp
    with C show "(v, D y) \<notin> I" ..
  qed
qed

end


theory ex09_2
  imports Main "HOL-Data_Structures.RBT_Set"
begin

fun ins' :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt option" where
"ins' x Leaf = Some (R Leaf x Leaf)" |
"ins' x (B l a r) =
  (case cmp x a of
     LT \<Rightarrow> (case (ins' x l) of None \<Rightarrow> None | Some t \<Rightarrow> Some (baliL t a r)) |
     GT \<Rightarrow> (case (ins' x r) of None \<Rightarrow> None | Some t \<Rightarrow> Some (baliR l a t)) |
     EQ \<Rightarrow> None)" |
"ins' x (R l a r) =
  (case cmp x a of
    LT \<Rightarrow> (case (ins' x l) of None \<Rightarrow> None | Some t \<Rightarrow> Some(R t a r)) |
    GT \<Rightarrow> (case (ins' x r) of None \<Rightarrow> None | Some t \<Rightarrow> Some (R l a t)) |
    EQ \<Rightarrow> None)"

lemma baliR_lem: "invc l \<Longrightarrow> invc r \<Longrightarrow> baliR l a r = B l a r"
  apply (induction l a r rule: baliR.induct)
  by auto

lemma baliL_lem: "invc l \<Longrightarrow> invc r \<Longrightarrow> baliL l a r = B l a r"
  apply (induction l a r rule: baliL.induct)
  by auto

lemma "invc t \<Longrightarrow> case ins' x t of None \<Rightarrow> ins x t = t | Some t' \<Rightarrow> ins x t = t'"
  apply(induction x t rule: ins'.induct)
  by (auto split: option.splits simp: baliR_lem baliL_lem)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_MSortTDPermutes
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
"minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
"lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun take :: "Nat => 'a list => 'a list" where
"take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
"idiv x y = (if lt x y then Z else S (idiv (minus x y) y))"
  by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun drop :: "Nat => 'a list => 'a list" where
"drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function msorttd :: "Nat list => Nat list" where
"msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = idiv (length (cons2 y (cons2 x2 x3))) (S (S Z))
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msorttd xs) xs"
  oops

end


(*   Title: HOL/ex/Ballot.thy
     Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com>
     Author: Johannes Hölzl <hoelzl@in.tum.de>
*)

section \<open>Bertrand's Ballot Theorem\<close>

theory Ballot
imports
  Complex_Main
  "HOL-Library.FuncSet"
begin

subsection \<open>Preliminaries\<close>

lemma card_bij':
  assumes "f \<in> A \<rightarrow> B" "\<And>x. x \<in> A \<Longrightarrow> g (f x) = x"
    and "g \<in> B \<rightarrow> A" "\<And>x. x \<in> B \<Longrightarrow> f (g x) = x"
  shows "card A = card B"
  apply (rule bij_betw_same_card)
  apply (rule bij_betwI)
  apply fact+
  done

subsection \<open>Formalization of Problem Statement\<close>

subsubsection \<open>Basic Definitions\<close>

datatype vote = A | B

definition
  "all_countings a b = card {f \<in> {1 .. a + b} \<rightarrow>\<^sub>E {A, B}.
      card {x \<in> {1 .. a + b}. f x = A} = a \<and> card {x \<in> {1 .. a + b}. f x = B} = b}"

definition
  "valid_countings a b =
    card {f\<in>{1..a+b} \<rightarrow>\<^sub>E {A, B}.
      card {x\<in>{1..a+b}. f x = A} = a \<and> card {x\<in>{1..a+b}. f x = B} = b \<and>
      (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > card {x\<in>{1..m}. f x = B})}"

subsubsection \<open>Equivalence with Set Cardinality\<close>

lemma Collect_on_transfer:
  assumes "rel_set R X Y"
  shows "rel_fun (rel_fun R op =) (rel_set R) (\<lambda>P. {x\<in>X. P x}) (\<lambda>P. {y\<in>Y. P y})"
  using assms unfolding rel_fun_def rel_set_def by fast

lemma rel_fun_trans:
  "rel_fun P Q g g' \<Longrightarrow> rel_fun R P f f' \<Longrightarrow> rel_fun R Q (\<lambda>x. g (f x)) (\<lambda>y. g' (f' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_trans2:
  "rel_fun P1 (rel_fun P2 Q) g g' \<Longrightarrow> rel_fun R P1 f1 f1' \<Longrightarrow> rel_fun R P2 f2 f2' \<Longrightarrow>
    rel_fun R Q (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g' (f1' y) (f2' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_trans2':
  "rel_fun R (op =) f1 f1' \<Longrightarrow> rel_fun R (op =) f2 f2' \<Longrightarrow>
    rel_fun R (op =) (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g (f1' y) (f2' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_const: "rel_fun R (op =) (\<lambda>x. a) (\<lambda>y. a)"
  by auto

lemma rel_fun_conj:
  "rel_fun R (op =) f f' \<Longrightarrow> rel_fun R (op =) g g' \<Longrightarrow> rel_fun R (op =) (\<lambda>x. f x \<and> g x) (\<lambda>y. f' y \<and> g' y)"
  by (auto simp: rel_fun_def)

lemma rel_fun_ball:
  "(\<And>i. i \<in> I \<Longrightarrow> rel_fun R (op =) (f i) (f' i)) \<Longrightarrow> rel_fun R (op =) (\<lambda>x. \<forall>i\<in>I. f i x) (\<lambda>y. \<forall>i\<in>I. f' i y)"
  by (auto simp: rel_fun_def rel_set_def)

lemma
  shows all_countings_set: "all_countings a b = card {V\<in>Pow {0..<a+b}. card V = a}"
      (is "_ = card ?A")
    and valid_countings_set: "valid_countings a b =
      card {V\<in>Pow {0..<a+b}. card V = a \<and> (\<forall>m\<in>{1..a+b}. card ({0..<m} \<inter> V) > m - card ({0..<m} \<inter> V))}"
      (is "_ = card ?V")
proof -
  define P where "P j i \<longleftrightarrow> i < a + b \<and> j = Suc i" for j i
  have unique_P: "bi_unique P" and total_P: "\<And>m. m \<le> a + b \<Longrightarrow> rel_set P {1..m} {0..<m}"
    by (auto simp add: bi_unique_def rel_set_def P_def Suc_le_eq gr0_conv_Suc)
  have rel_fun_P: "\<And>R f g. (\<And>i. i < a+b \<Longrightarrow> R (f  (Suc i)) (g i)) \<Longrightarrow> rel_fun P R f g"
    by (simp add: rel_fun_def P_def)

  define R where "R f V \<longleftrightarrow>
    V \<subseteq> {0..<a+b} \<and> f \<in> extensional {1..a+b} \<and> (\<forall>i<a+b. i \<in> V \<longleftrightarrow> f (Suc i) = A)" for f V
  { fix f g :: "nat \<Rightarrow> vote" assume "f \<in> extensional {1..a + b}" "g \<in> extensional {1..a + b}"
    moreover assume "\<forall>i<a + b. (f (Suc i) = A) = (g (Suc i) = A)"
    then have "\<forall>i<a + b. f (Suc i) = g (Suc i)"
      by (metis vote.nchotomy)
    ultimately have "f i = g i" for i
      by (cases "i \<in> {1..a+b}") (auto simp: extensional_def Suc_le_eq gr0_conv_Suc) }
  then have unique_R: "bi_unique R"
    by (auto simp: bi_unique_def R_def)

  have "f \<in> extensional {1..a + b} \<Longrightarrow> \<exists>V\<in>Pow {0..<a + b}. R f V" for f
    by (intro bexI[of _ "{i. i < a+b \<and> f (Suc i) = A}"]) (auto simp add: R_def PiE_def)
  moreover have "V \<in> Pow {0..<a + b} \<Longrightarrow> \<exists>f\<in>extensional {1..a+b}. R f V" for V
    by (intro bexI[of _ "\<lambda>i\<in>{1..a+b}. if i - 1 \<in> V then A else B"]) (auto simp add: R_def PiE_def)
  ultimately have total_R: "rel_set R (extensional {1..a+b}) (Pow {0..<a+b})"
    by (auto simp: rel_set_def)

  have P: "rel_fun R (rel_fun P op =) (\<lambda>f x. f x = A) (\<lambda>V y. y \<in> V)"
    by (auto simp: P_def R_def Suc_le_eq gr0_conv_Suc rel_fun_def)

  have eq_B: "x = B \<longleftrightarrow> x \<noteq> A" for x
    by (cases x; simp)

  { fix f and m :: nat
    have "card {x\<in>{1..m}. f x = B} = card ({1..m} - {x\<in>{1..m}. f x = A})"
      by (simp add: eq_B set_diff_eq cong: conj_cong)
    also have "\<dots> = m - card {x\<in>{1..m}. f x = A}"
      by (subst card_Diff_subset) auto
    finally have "card {x\<in>{1..m}. f x = B} = m - card {x\<in>{1..m}. f x = A}" . }
  note card_B = this

  note transfers = rel_fun_const card_transfer[THEN rel_funD, OF unique_R] rel_fun_conj rel_fun_ball
    Collect_on_transfer[THEN rel_funD, OF total_R] Collect_on_transfer[THEN rel_funD, OF total_P]
    rel_fun_trans[OF card_transfer, OF unique_P] rel_fun_trans[OF Collect_on_transfer[OF total_P]]
    rel_fun_trans2'[where g="op ="] rel_fun_trans2'[where g="op <"] rel_fun_trans2'[where g="op -"]

  have "all_countings a b = card {f \<in> extensional {1..a + b}. card {x \<in> {1..a + b}. f x = A} = a}"
    using card_B by (simp add: all_countings_def PiE_iff vote.nchotomy cong: conj_cong)
  also have "\<dots> = card {V\<in>Pow {0..<a+b}. card ({x\<in>{0 ..< a + b}. x \<in> V}) = a}"
    by (intro P order_refl transfers)
  finally show "all_countings a b = card ?A"
    unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)

  have "valid_countings a b = card {f\<in>extensional {1..a+b}.
      card {x\<in>{1..a+b}. f x = A} = a \<and> (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > m - card {x\<in>{1..m}. f x = A})}"
    using card_B by (simp add: valid_countings_def PiE_iff vote.nchotomy cong: conj_cong)
  also have "\<dots> = card {V\<in>Pow {0..<a+b}. card {x\<in>{0..<a+b}. x\<in>V} = a \<and>
    (\<forall>m\<in>{1..a+b}. card {x\<in>{0..<m}. x\<in>V} > m - card {x\<in>{0..<m}. x\<in>V})}"
    by (intro P order_refl transfers) auto
  finally show "valid_countings a b = card ?V"
    unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)
qed

lemma all_countings: "all_countings a b = (a + b) choose a"
  unfolding all_countings_set by (simp add: n_subsets)

subsection \<open>Facts About @{term valid_countings}\<close>

subsubsection \<open>Non-Recursive Cases\<close>

lemma card_V_eq_a: "V \<subseteq> {0..<a} \<Longrightarrow> card V = a \<longleftrightarrow> V = {0..<a}"
  using card_subset_eq[of "{0..<a}" V] by auto

lemma valid_countings_a_0: "valid_countings a 0 = 1"
  by (simp add: valid_countings_set card_V_eq_a cong: conj_cong)

lemma valid_countings_eq_zero:
  "a \<le> b \<Longrightarrow> 0 < b \<Longrightarrow> valid_countings a b = 0"
  by (auto simp add: valid_countings_set Int_absorb1 intro!: bexI[of _ "a + b"])

lemma Ico_subset_finite: "i \<subseteq> {a ..< b::nat} \<Longrightarrow> finite i"
  by (auto dest: finite_subset)

lemma Icc_Suc2: "a \<le> b \<Longrightarrow> {a..Suc b} = insert (Suc b) {a..b}"
  by auto

lemma Ico_Suc2: "a \<le> b \<Longrightarrow> {a..<Suc b} = insert b {a..<b}"
  by auto

lemma valid_countings_Suc_Suc:
  assumes "b < a"
  shows "valid_countings (Suc a) (Suc b) = valid_countings a (Suc b) + valid_countings (Suc a) b"
proof -
  let ?l = "Suc (a + b)"
  let ?Q = "\<lambda>V c. \<forall>m\<in>{1..c}. m - card ({0..<m} \<inter> V) < card ({0..<m} \<inter> V)"
  let ?V = "\<lambda>P. {V. (V \<in> Pow {0..<Suc ?l} \<and> P V) \<and> card V = Suc a \<and> ?Q V (Suc ?l)}"
  have "valid_countings (Suc a) (Suc b) = card (?V (\<lambda>V. ?l \<notin> V)) + card (?V (\<lambda>V. ?l \<in> V))"
    unfolding valid_countings_set
    by (subst card_Un_disjoint[symmetric]) (auto simp add: set_eq_iff intro!: arg_cong[where f=card])
  also have "card (?V (\<lambda>V. ?l \<in> V)) = valid_countings a (Suc b)"
    unfolding valid_countings_set
  proof (rule card_bij'[where f="\<lambda>V. V - {?l}" and g="insert ?l"])
    have *: "\<And>m V. m \<in> {1..a + Suc b} \<Longrightarrow> {0..<m} \<inter> (V - {?l}) = {0..<m} \<inter> V"
      by auto
    show "(\<lambda>V. V - {?l}) \<in> ?V (\<lambda>V. ?l \<in> V) \<rightarrow> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)}"
      by (auto simp: Ico_subset_finite *)
    { fix V assume V: "V \<subseteq> {0..<?l}"
      then have "finite V" "?l \<notin> V" "{0..<Suc ?l} \<inter> V = V"
        by (auto dest: finite_subset)
      with V have "card (insert ?l V) = Suc (card V)"
        "card ({0..<m} \<inter> insert ?l V) = (if m = Suc ?l then Suc (card V) else card ({0..<m} \<inter> V))"
        if "m \<le> Suc ?l" for m
        using that by auto }
    then show "insert ?l \<in> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)} \<rightarrow> ?V (\<lambda>V. ?l \<in> V)"
      using \<open>b < a\<close> by auto
  qed auto
  also have "card (?V (\<lambda>V. ?l \<notin> V)) = valid_countings (Suc a) b"
    unfolding valid_countings_set
  proof (intro arg_cong[where f="\<lambda>P. card {x. P x}"] ext conj_cong)
    fix V assume "V \<in> Pow {0..<Suc a + b}" and [simp]: "card V = Suc a"
    then have [simp]: "V \<subseteq> {0..<Suc ?l}"
      by auto
    show "?Q V (Suc ?l) = ?Q V (Suc a + b)"
      using \<open>b<a\<close> by (simp add: Int_absorb1 Icc_Suc2)
  qed (auto simp: subset_eq less_Suc_eq)
  finally show ?thesis
    by simp
qed

lemma valid_countings:
  "(a + b) * valid_countings a b = (a - b) * ((a + b) choose a)"
proof (induct a arbitrary: b)
  case 0 show ?case
    by (cases b) (simp_all add: valid_countings_eq_zero)
next
  case (Suc a) note Suc_a = this
  show ?case
  proof (induct b)
    case (Suc b) note Suc_b = this
    show ?case
    proof cases
      assume "a \<le> b" then show ?thesis
        by (simp add: valid_countings_eq_zero)
    next
      assume "\<not> a \<le> b"
      then have "b < a" by simp

      have "Suc a * (a - Suc b) + (Suc a - b) * Suc b =
        (Suc a * a - Suc a * Suc b) + (Suc a * Suc b - Suc b * b)"
        by (simp add: sign_simps)
      also have "\<dots> = (Suc a * a + (Suc a * Suc b - Suc b * b)) - Suc a * Suc b"
        using \<open>b<a\<close> by (intro add_diff_assoc2 mult_mono) auto
      also have "\<dots> = (Suc a * a + Suc a * Suc b) - Suc b * b - Suc a * Suc b"
        using \<open>b<a\<close> by (intro arg_cong2[where f="op -"] add_diff_assoc mult_mono) auto
      also have "\<dots> = (Suc a * Suc (a + b)) - (Suc b * Suc (a + b))"
        by (simp add: sign_simps)
      finally have rearrange: "Suc a * (a - Suc b) + (Suc a - b) * Suc b = (Suc a - Suc b) * Suc (a + b)"
        unfolding diff_mult_distrib by simp

      have "(Suc a * Suc (a + b)) * ((Suc a + Suc b) * valid_countings (Suc a) (Suc b)) =
        (Suc a + Suc b) * Suc a * ((a + Suc b) * valid_countings a (Suc b) + (Suc a + b) * valid_countings (Suc a) b)"
        unfolding valid_countings_Suc_Suc[OF \<open>b < a\<close>] by (simp add: field_simps)
      also have "... = (Suc a + Suc b) * ((a - Suc b) * (Suc a * (Suc (a + b) choose a)) +
        (Suc a - b) * (Suc a * (Suc (a + b) choose Suc a)))"
        unfolding Suc_a Suc_b by (simp add: field_simps)
      also have "... = (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc (Suc a + b) * (Suc a + b choose a))"
        unfolding Suc_times_binomial_add by (simp add: field_simps)
      also have "... = Suc a * (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc a + Suc b choose Suc a)"
        unfolding Suc_times_binomial_eq by (simp add: field_simps)
      also have "... = (Suc a * Suc (a + b)) * ((Suc a - Suc b) * (Suc a + Suc b choose Suc a))"
        unfolding rearrange by (simp only: mult_ac)
      finally show ?thesis
        unfolding mult_cancel1 by simp
    qed
  qed (simp add: valid_countings_a_0)
qed

lemma valid_countings_eq[code]:
  "valid_countings a b = (if a + b = 0 then 1 else ((a - b) * ((a + b) choose a)) div (a + b))"
  by (simp add: valid_countings[symmetric] valid_countings_a_0)

subsection \<open>Relation Between @{term valid_countings} and @{term all_countings}\<close>

lemma main_nat: "(a + b) * valid_countings a b = (a - b) * all_countings a b"
  unfolding valid_countings all_countings ..

lemma main_real:
  assumes "b < a"
  shows "valid_countings a b = (a - b) / (a + b) * all_countings a b"
using assms
proof -
  from main_nat[of a b] \<open>b < a\<close> have
    "(real a + real b) * real (valid_countings a b) = (real a - real b) * real (all_countings a b)"
    by (simp only: of_nat_add[symmetric] of_nat_mult[symmetric]) auto
  from this \<open>b < a\<close> show ?thesis
    by (subst mult_left_cancel[of "real a + real b", symmetric]) auto
qed

lemma
  "valid_countings a b = (if a \<le> b then (if b = 0 then 1 else 0) else (a - b) / (a + b) * all_countings a b)"
proof (cases "a \<le> b")
  case False
    from this show ?thesis by (simp add: main_real)
next
  case True
    from this show ?thesis
      by (auto simp add: valid_countings_a_0 all_countings valid_countings_eq_zero)
qed

subsubsection \<open>Executable Definition\<close>

declare all_countings_def [code del]
declare all_countings[code]

value "all_countings 1 0"
value "all_countings 0 1"
value "all_countings 1 1"
value "all_countings 2 1"
value "all_countings 1 2"
value "all_countings 2 4"
value "all_countings 4 2"

subsubsection \<open>Executable Definition\<close>

declare valid_countings_def [code del]

value "valid_countings 1 0"
value "valid_countings 0 1"
value "valid_countings 1 1"
value "valid_countings 2 1"
value "valid_countings 1 2"
value "valid_countings 2 4"
value "valid_countings 4 2"

end


section\<open>Confining a series to a set\<close>

theory Confine
  imports Complex_Main
begin

definition confine :: "('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b"
  where "confine f A = (\<lambda>x. if x \<in> A then f x else 0)"

lemma confine_UNIV [simp]: "confine f UNIV = f"
  by (simp add: confine_def)

lemma sum_confine_eq_Int:
  assumes "finite I"
  shows "sum (confine f A) I = (\<Sum>i \<in> I \<inter> A. f i)"
proof -
  have "sum f(I \<inter> A) = (\<Sum>a\<in>I. if a \<in> A then f a else 0)"
    using assms sum.inter_restrict by blast
  then show ?thesis
    by (auto simp: confine_def)
qed

lemma sums_confine_add:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
  assumes "confine f N sums a" "confine g N sums b"
  shows "confine (\<lambda>i. f i + g i) N sums (a+b)"
proof -
  have "\<And>n. (if n \<in> N then f n + g n else 0) = (if n \<in> N then f n else 0) + (if n \<in> N then g n else 0)"
    by simp
  then show ?thesis
    using sums_add [of "confine f N" a "confine g N" b] assms
    by (simp add: confine_def)
qed

lemma sums_confine_minus:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
  shows "confine f N sums a \<Longrightarrow> confine (uminus \<circ> f) N sums (-a)"
     using sums_minus [of "confine f N" a]
     by (simp add: confine_def if_distrib [of uminus] cong: if_cong)

lemma sums_confine_mult:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_algebra"
  shows "confine f N sums a \<Longrightarrow> confine (\<lambda>n. c * f n) N sums (c * a)"
     using sums_mult [of "confine f N" a c]
     by (simp add: confine_def if_distrib [of "(*)c"] cong: if_cong)

lemma sums_confine_divide:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_field"
  shows "confine f N sums a \<Longrightarrow> confine (\<lambda>n. f n / c) N sums (a/c)"
     using sums_divide [of "confine f N" a c]
     by (simp add: confine_def if_distrib [of "\<lambda>x. x/c"] cong: if_cong)

lemma sums_confine_divide_iff:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_field"
  assumes "c \<noteq> 0"
  shows "confine (\<lambda>n. f n / c) N sums (a/c) \<longleftrightarrow> confine f N sums a"
proof
  show "confine f N sums a"
    if "confine (\<lambda>n. f n / c) N sums (a / c)"
    using sums_confine_mult [OF that, of c] assms by simp
qed (auto simp: sums_confine_divide)

lemma sums_confine:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
  shows "confine f N sums l \<longleftrightarrow> ((\<lambda>n. \<Sum>i \<in> {..<n} \<inter> N. f i) \<longlonglongrightarrow> l)"
  by (simp add: sums_def atLeast0LessThan confine_def sum.inter_restrict)

lemma sums_confine_le:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
  shows "confine f N sums l \<longleftrightarrow> ((\<lambda>n. \<Sum>i \<in> {..n} \<inter> N. f i) \<longlonglongrightarrow> l)"
  by (simp add: sums_def_le atLeast0AtMost confine_def sum.inter_restrict)

end