(*  Title:       A General Method for the Proof of Theorems on Tail-recursive Functions
    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 "Case study 1"

theory CaseStudy1
imports Main
begin

text \<open>
\null

In the first case study, the problem will be examined of defining a function
\<open>l_sort\<close> performing insertion sort on lists of elements of a linear order,
and then proving the correctness of this definition, i.e. that the lists output by
the function actually be sorted and contain as many occurrences of any value as
the input lists.

Such function constitutes a paradigmatic example of a function admitting a
straightforward tail-recursive definition. Here below is a naive one:

\null
\<close>

fun l_sort_naive :: "'a::linorder list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"l_sort_naive (x # xs) ys [] = l_sort_naive xs [] (ys @ [x])" |
"l_sort_naive (x # xs) ys (z # zs) = (if x \<le> z
  then l_sort_naive xs [] (ys @ x # z # zs)
  else l_sort_naive (x # xs) (ys @ [z]) zs)" |
"l_sort_naive [] ys zs = zs"

text \<open>
\null

The first argument is deputed to contain the values still having to be inserted
into the sorted list, accumulated in the third argument. For each of such values,
the items of the sorted list are orderly moved into a temporary one (second
argument) to search the insertion position. Once found, the sorted list is
restored, the processed value is moved from the unsorted list to the sorted one,
and another iteration of the loop is performed up to the exhaustion of the former
list.

A further couple of functions are needed to express the aforesaid correctness
properties of function \<open>l_sort_naive\<close>:

\null
\<close>

fun l_sorted :: "'a::linorder list \<Rightarrow> bool" where
"l_sorted (x # x' # xs) = (x \<le> x' \<and> l_sorted (x' # xs))" |
"l_sorted _ = True"

definition l_count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"l_count x xs \<equiv> length [x'\<leftarrow>xs. x' = x]"

text \<open>
\null

Then, the target correctness theorems can be enunciated as follows:

\null

\<open>l_sorted (l_sort_naive xs [] [])\<close>

\null

\<open>l_count x (l_sort_naive xs [] []) = l_count x xs\<close>

\null

Unfortunately, attempts to apply recursion induction to such goals turn out to be
doomed, as can easily be ascertained by considering the former theorem:

\null
\<close>

theorem "l_sorted (l_sort_naive xs [] [])"
proof (rule l_sort_naive.induct [of "\<lambda>xs ys zs. l_sorted (l_sort_naive xs ys zs)"],
 simp_all del: l_sort_naive.simps(3))

txt \<open>
\null

Simplification deletes all the subgoals generated by recursive equations.
However, the following subgoal arises from the non-recursive one:

\null

@{subgoals [display]}

\null

which is hopeless as the formula is false for any unsorted list \<open>zs\<close>.

\null
\<close>

oops

subsection "Step 1"

type_synonym 'a l_type = "'a list \<times> 'a list \<times> 'a list"

fun l_sort_aux :: "'a::linorder l_type \<Rightarrow> 'a l_type" where
"l_sort_aux (x # xs, ys, []) = l_sort_aux (xs, [], ys @ [x])" |
"l_sort_aux (x # xs, ys, z # zs) = (if x \<le> z
  then l_sort_aux (xs, [], ys @ x # z # zs)
  else l_sort_aux (x # xs, ys @ [z], zs))" |
"l_sort_aux ([], ys, zs) = ([], ys, zs)"

text \<open>
\null

Observe that the Cartesian product of the input types has been implemented as a
product type.
\<close>

subsection "Step 2"

definition l_sort_in :: "'a list \<Rightarrow> 'a l_type" where
"l_sort_in xs \<equiv> (xs, [], [])"

definition l_sort_out :: "'a l_type \<Rightarrow> 'a list" where
"l_sort_out X \<equiv> snd (snd X)"

definition l_sort :: "'a::linorder list \<Rightarrow> 'a list" where
"l_sort xs \<equiv> l_sort_out (l_sort_aux (l_sort_in xs))"

text \<open>
\null

Since the significant inputs of function \<open>l_sort_naive\<close> match pattern
\<open>_\<close>, \<open>[]\<close>, \<open>[]\<close>, those of function \<open>l_sort_aux\<close>
match pattern \<open>(_, [], [])\<close>, thus being in a one-to-one correspondence
with the type of the first component.

The target correctness theorems can then be put into the following equivalent
form:

\null

\<open>l_sorted (l_sort xs)\<close>

\null

\<open>l_count x (l_sort xs) = l_count x xs\<close>
\<close>

subsection "Step 3"

text \<open>
The conditional recursive equation in the definition of function
\<open>l_sort_aux\<close> will equivalently be associated to two distinct introduction
rules in the definition of the inductive set \<open>l_sort_set\<close>, one for either
truth value of the Boolean condition, handled as an additional assumption. The
advantage is twofold: simpler introduction rules are obtained, and case
distinctions are saved as rule induction is applied.

\null
\<close>

inductive_set l_sort_set :: "'a::linorder l_type \<Rightarrow> 'a l_type set"
for X :: "'a l_type" where
R0: "X \<in> l_sort_set X" |
R1: "(x # xs, ys, []) \<in> l_sort_set X \<Longrightarrow> (xs, [], ys @ [x]) \<in> l_sort_set X" |
R2: "\<lbrakk>(x # xs, ys, z # zs) \<in> l_sort_set X; x \<le> z\<rbrakk> \<Longrightarrow>
     (xs, [], ys @ x # z # zs) \<in> l_sort_set X" |
R3: "\<lbrakk>(x # xs, ys, z # zs) \<in> l_sort_set X; \<not> x \<le> z\<rbrakk> \<Longrightarrow>
     (x # xs, ys @ [z], zs) \<in> l_sort_set X"

subsection "Step 4"

lemma l_sort_subset:
  assumes XY: "Y \<in> l_sort_set X"
  shows "l_sort_set Y \<subseteq> l_sort_set X"
proof (rule subsetI, erule l_sort_set.induct)
  show "Y \<in> l_sort_set X" using XY .
next
  fix x xs ys
  assume "(x # xs, ys, []) \<in> l_sort_set X"
  thus "(xs, [], ys @ [x]) \<in> l_sort_set X" by (rule R1)
next
  fix x xs ys z zs
  assume "(x # xs, ys, z # zs) \<in> l_sort_set X" and "x \<le> z"
  thus "(xs, [], ys @ x # z # zs) \<in> l_sort_set X" by (rule R2)
next
  fix x xs ys z zs
  assume "(x # xs, ys, z # zs) \<in> l_sort_set X" and "\<not> x \<le> z"
  thus "(x # xs, ys @ [z], zs) \<in> l_sort_set X" by (rule R3)
qed

lemma l_sort_aux_set: "l_sort_aux X \<in> l_sort_set X"
proof (induction rule: l_sort_aux.induct, simp_all del: l_sort_aux.simps(2))
  fix ys :: "'a list" and zs
  show "([], ys, zs) \<in> l_sort_set ([], ys, zs)" by (rule R0)
next
  fix x :: 'a and xs ys
  have "(x # xs, ys, []) \<in> l_sort_set (x # xs, ys, [])" by (rule R0)
  hence "(xs, [], ys @ [x]) \<in> l_sort_set (x # xs, ys, [])" by (rule R1)
  hence "l_sort_set (xs, [], ys @ [x]) \<subseteq> l_sort_set (x # xs, ys, [])"
   by (rule l_sort_subset)
  moreover assume "l_sort_aux (xs, [], ys @ [x]) \<in> l_sort_set (xs, [], ys @ [x])"
  ultimately show "l_sort_aux (xs, [], ys @ [x]) \<in> l_sort_set (x # xs, ys, [])"
   by (rule subsetD)
next
  fix x :: 'a and xs ys z zs
  assume
   case1: "x \<le> z \<Longrightarrow>
    l_sort_aux (xs, [], ys @ x # z # zs) \<in> l_sort_set (xs, [], ys @ x # z # zs)"
  and
   case2: "\<not> x \<le> z \<Longrightarrow>
    l_sort_aux (x # xs, ys @ [z], zs) \<in> l_sort_set (x # xs, ys @ [z], zs)"
  have 0: "(x # xs, ys, z # zs) \<in> l_sort_set (x # xs, ys, z # zs)" by (rule R0)
  show "l_sort_aux (x # xs, ys, z # zs) \<in> l_sort_set (x # xs, ys, z # zs)"
  proof (cases "x \<le> z", simp_all)
    assume "x \<le> z"
    with 0 have "(xs, [], ys @ x # z # zs) \<in> l_sort_set (x # xs, ys, z # zs)"
     by (rule R2)
    hence "l_sort_set (xs, [], ys @ x # z # zs) \<subseteq> l_sort_set (x # xs, ys, z # zs)"
     by (rule l_sort_subset)
    moreover have "l_sort_aux (xs, [], ys @ x # z # zs) \<in>
     l_sort_set (xs, [], ys @ x # z # zs)" using case1 and \<open>x \<le> z\<close> by simp
    ultimately show "l_sort_aux (xs, [], ys @ x # z # zs) \<in>
     l_sort_set (x # xs, ys, z # zs)" by (rule subsetD)
  next
    assume "\<not> x \<le> z"
    with 0 have "(x # xs, ys @ [z], zs) \<in> l_sort_set (x # xs, ys, z # zs)"
     by (rule R3)
    hence "l_sort_set (x # xs, ys @ [z], zs) \<subseteq> l_sort_set (x # xs, ys, z # zs)"
     by (rule l_sort_subset)
    moreover have "l_sort_aux (x # xs, ys @ [z], zs) \<in>
     l_sort_set (x # xs, ys @ [z], zs)" using case2 and \<open>\<not> x \<le> z\<close> by simp
    ultimately show "l_sort_aux (x # xs, ys @ [z], zs) \<in>
     l_sort_set (x # xs, ys, z # zs)" by (rule subsetD)
  qed
qed

text \<open>
\null

The reader will have observed that the simplification rule arising from the
second equation in the definition of function \<open>l_sort_aux\<close>, i.e. the one
whose right-hand side contains a conditional, has been ignored in the initial
backward steps of the previous proof. The reason is that it would actually make
more complex the conclusion of the corresponding subgoal, as can easily be
verified by trying to leave it enabled.

\null
\<close>

lemma "l_sort_aux X \<in> l_sort_set X"
proof (induction rule: l_sort_aux.induct, simp_all)

(*<*)
prefer 2
(*>*)

txt \<open>
\null

As a result of the application of the rule, the related subgoal takes the
following form:

\null

@{subgoals [display, goals_limit = 1]}

\null

Now the conclusion is comprised of a conjunction of two implications. This is
pointless, since case distinction is faster than the application of conjunction
and implication introduction rules in providing sufficient assumptions for the
simplification of both the induction hypotheses and the conclusion.

\null
\<close>

oops

text \<open>
\null

These considerations clearly do not depend on the particular function under
scrutiny, so that postponing the application of conditional simplification rules
to case distinction turns out to be a generally advisable strategy for the
accomplishment of step 4.
\<close>

subsection "Step 5"

text \<open>
Two invariants are defined here below, one for each of the target correctness
theorems:

\null
\<close>

fun l_sort_inv_1 :: "'a::linorder l_type \<Rightarrow> bool" where
"l_sort_inv_1 (x # xs, y # ys, z # zs) =
  (l_sorted (y # ys) \<and> l_sorted (z # zs) \<and>
  last (y # ys) \<le> x \<and> last (y # ys) \<le> z)" |
"l_sort_inv_1 (x # xs, y # ys, []) =
  (l_sorted (y # ys) \<and> last (y # ys) \<le> x)" |
"l_sort_inv_1 (_, _, zs) =
  l_sorted zs"

definition l_sort_inv_2 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a l_type \<Rightarrow> bool" where
"l_sort_inv_2 x xs X \<equiv> (fst X = [] \<longrightarrow> fst (snd X) = []) \<and>
  l_count x (fst X) + l_count x (fst (snd X)) + l_count x (snd (snd X)) =
  l_count x xs"

text \<open>
\null

More precisely, the second invariant, whose type has to match
\<open>'a l_type \<Rightarrow> bool\<close> according to the method specification, shall be
comprised of function \<open>l_sort_inv_2 x xs\<close>, where \<open>x\<close>, \<open>xs\<close>
are the free variables appearing in the latter target theorem.

Both of the above definitions are non-recursive; command \<open>fun\<close> is used in
the former for the sole purpose of taking advantage of pattern matching.
\<close>

subsection "Step 6"

lemma l_sort_input_2: "l_sort_inv_2 x xs (xs, [], [])"
by (simp add: l_sort_inv_2_def l_count_def)

subsection "Step 7"

definition l_sort_form :: "'a l_type \<Rightarrow> bool" where
"l_sort_form X \<equiv> fst X = []"

lemma l_sort_intro_1:
 "l_sort_inv_1 X \<Longrightarrow> l_sorted (l_sort_out X)"
by (rule l_sort_inv_1.cases [of X], simp_all add: l_sort_out_def)

lemma l_sort_intro_2:
 "\<lbrakk>l_sort_inv_2 x xs X; l_sort_form X\<rbrakk> \<Longrightarrow>
  l_count x (l_sort_out X) = l_count x xs"
by (simp add: l_sort_inv_2_def, (erule conjE)+,
 simp add: l_sort_form_def l_sort_out_def l_count_def)

subsection "Step 8"

lemma l_sort_form_aux_all: "l_sort_form (l_sort_aux X)"
by (rule l_sort_aux.induct [of "\<lambda>X. l_sort_form (l_sort_aux X)"],
 simp_all add: l_sort_form_def)

lemma l_sort_form_aux: "l_sort_form (l_sort_aux (xs, [], []))"
by (rule l_sort_form_aux_all)

subsection "Step 9"

text \<open>
The proof of the first invariance property requires the following lemma, stating
that in case two lists are sorted, their concatenation still is such as long as
the last item of the former is not greater than the first one of the latter.

\null
\<close>

lemma l_sorted_app [rule_format]:
 "l_sorted xs \<longrightarrow> l_sorted ys \<longrightarrow> last xs \<le> hd ys \<longrightarrow> l_sorted (xs @ ys)"
proof (induction xs rule: l_sorted.induct, simp_all, (rule impI)+)
  fix x
  assume "l_sorted ys" and "x \<le> hd ys"
  thus "l_sorted (x # ys)" by (cases ys, simp_all)
qed

lemma l_sort_invariance_1:
  assumes XY: "Y \<in> l_sort_set X" and X: "l_sort_inv_1 X"
  shows "l_sort_inv_1 Y"
using XY
proof (rule l_sort_set.induct, simp_all)
  show "l_sort_inv_1 X" using X .
next
  fix x :: 'a and xs ys
  assume I: "l_sort_inv_1 (x # xs, ys, [])"
  show "l_sorted (ys @ [x])"
  proof (cases ys, simp)
    fix a as
    assume "ys = a # as"
    hence "l_sorted ys \<and> last ys \<le> x" using I by simp
    moreover have "l_sorted [x]" by simp
    ultimately show ?thesis by (simp add: l_sorted_app)
  qed
next
  fix x :: 'a and xs ys z zs
  assume XZ: "x \<le> z" and I: "l_sort_inv_1 (x # xs, ys, z # zs)"
  thus "l_sorted (ys @ x # z # zs)"
  proof (cases ys, simp)
    fix a as
    assume "ys = a # as"
    hence *: "l_sorted ys \<and> l_sorted (z # zs) \<and> last ys \<le> x" using I by simp
    with XZ have "l_sorted (x # z # zs)" by simp
    with * show ?thesis by (simp add: l_sorted_app)
  qed
next
  fix x :: 'a and xs ys z zs
  assume "\<not> x \<le> z"
  hence XZ: "z \<le> x" by simp
  assume "l_sort_inv_1 (x # xs, ys, z # zs)"
  thus "l_sort_inv_1 (x # xs, ys @ [z], zs)"
  proof (cases ys, simp)
    assume I: "l_sorted (z # zs)"
    show "l_sort_inv_1 (x # xs, [z], zs)"
    proof (cases zs, simp)
      show "z \<le> x" using XZ .
    next
      fix a as
      assume zs: "zs = a # as"
      then have *: "z \<le> a \<and> l_sorted zs" using I by simp
      have "l_sorted [z]" by simp
      with zs * show ?thesis using XZ by simp
    qed
  next
    fix a as
    assume YS: "ys = a # as" and "l_sort_inv_1 (x # xs, ys, z # zs)"
    hence I: "l_sorted ys \<and> l_sorted (z # zs) \<and> last ys \<le> z" by simp
    have "l_sorted [z]" by simp
    hence I': "l_sorted (ys @ [z])" using I by (simp add: l_sorted_app)
    show ?thesis
    proof (cases zs, simp)
      show "l_sort_inv_1 (x # xs, ys @ [z], [])" using I' and XZ and YS by simp
    next
      fix b bs
      assume zs: "zs = b # bs"
      then have "z \<le> b \<and> l_sorted zs" using I by simp
      with zs show ?thesis using I and I' and XZ and YS by simp
    qed
  qed
qed

text \<open>
\null

Likewise, the proof of the second invariance property calls for the following
lemmas, stating that the number of occurrences of a value in a list is
additive with respect to both item prepending and list concatenation.

\null
\<close>

lemma l_count_cons: "l_count x (y # ys) = l_count x [y] + l_count x ys"
by (simp add: l_count_def)

lemma l_count_app: "l_count x (ys @ zs) = l_count x ys + l_count x zs"
by (simp add: l_count_def)

lemma l_sort_invariance_2:
  assumes XY: "Y \<in> l_sort_set X" and X: "l_sort_inv_2 w ws X"
  shows "l_sort_inv_2 w ws Y"
using XY
proof (rule l_sort_set.induct)
  show "l_sort_inv_2 w ws X" using X .
next
  fix x xs ys
  assume "l_sort_inv_2 w ws (x # xs, ys, [])"
  thus "l_sort_inv_2 w ws (xs, [], ys @ [x])"
  proof (simp add: l_sort_inv_2_def, subst (asm) l_count_cons, subst l_count_app)
  qed (simp add: l_count_def ac_simps)
next
  fix x xs ys z zs
  assume "l_sort_inv_2 w ws (x # xs, ys, z # zs)"
  thus "l_sort_inv_2 w ws (xs, [], ys @ x # z # zs)"
  proof (simp add: l_sort_inv_2_def, subst (asm) l_count_cons, subst l_count_app,
   subst l_count_cons)
  qed (simp add: l_count_def ac_simps)
next
  fix x xs ys z zs
  assume "l_sort_inv_2 w ws (x # xs, ys, z # zs)"
  thus "l_sort_inv_2 w ws (x # xs, ys @ [z], zs)"
  proof (simp add: l_sort_inv_2_def, subst (asm) (2) l_count_cons,
   subst l_count_app)
  qed (simp add: l_count_def ac_simps)
qed

subsection "Step 10"

theorem "l_sorted (l_sort xs)"
proof -
  let ?X = "(xs, [], [])"
  have "l_sort_aux ?X \<in> l_sort_set ?X" by (rule l_sort_aux_set)
  moreover have "l_sort_inv_1 ?X" by (rule l_sort_input_1)
  ultimately have "l_sort_inv_1 (l_sort_aux ?X)" by (rule l_sort_invariance_1)
  hence "l_sorted (l_sort_out (l_sort_aux ?X))" by (rule l_sort_intro_1)
  moreover have "?X = l_sort_in xs" by (simp add: l_sort_in_def)
  ultimately show ?thesis by (simp add: l_sort_def)
qed

theorem "l_count x (l_sort xs) = l_count x xs"
proof -
  let ?X = "(xs, [], [])"
  have "l_sort_aux ?X \<in> l_sort_set ?X" by (rule l_sort_aux_set)
  moreover have "l_sort_inv_2 x xs ?X" by (rule l_sort_input_2)
  ultimately have "l_sort_inv_2 x xs (l_sort_aux ?X)" by (rule l_sort_invariance_2)
  moreover have "l_sort_form (l_sort_aux ?X)" by (rule l_sort_form_aux)
  ultimately have "l_count x (l_sort_out (l_sort_aux ?X)) = l_count x xs"
   by (rule l_sort_intro_2)
  moreover have "?X = l_sort_in xs" by (simp add: l_sort_in_def)
  ultimately show ?thesis by (simp add: l_sort_def)
qed

end


(* Title:      Demonic refinement algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Models for Demonic Refinement Algebra with Tests *}

theory DRA_Models
  imports DRAT Test_Dioids
begin

text {*
  We formalise the predicate transformer model of demonic refinement algebra.
  Predicate transformers are formalised as strict and additive functions over a field of sets,
  or alternatively as costrict and multiplicative functions.
  In the future, this should be merged with Preoteasa's more abstract formalisation~\cite{Preoteasa11}.
*}

no_notation
  plus (infixl "+" 65) and
  less_eq  ("(_/ \<le> _)"  [51, 51] 50)

notation comp (infixl "\<cdot>" 55)

type_synonym 'a bfun = "'a set \<Rightarrow> 'a set"

text {*
  Definitions of signature:
*}

definition top :: "'a bfun" where "top \<equiv> \<lambda>x. UNIV"
definition bot :: "'a bfun" where "bot \<equiv> \<lambda>x. {}"
definition adjoint :: "'a bfun \<Rightarrow> 'a bfun" where "adjoint f \<equiv> (\<lambda>p. - f (-p))"

definition fun_inter :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> 'a bfun" (infix "\<sqinter>" 51) where
  "f \<sqinter> g \<equiv> \<lambda>p. f p \<inter> g p"

definition fun_union :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> 'a bfun" (infix "+" 52) where
  "f + g \<equiv> \<lambda>p. f p \<union> g p"

definition fun_order :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> bool" (infix "\<le>" 50) where
  "f \<le> g \<equiv> \<forall>p. f p \<subseteq> g p"

definition fun_strict_order :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> bool" (infix "<." 50) where
  "f <. g \<equiv> f \<le> g \<and> f \<noteq> g"

definition N :: "'a bfun \<Rightarrow> 'a bfun" where
  "N f \<equiv> (adjoint f o bot) \<sqinter> id"

lemma top_max: "f \<le> top"
  by (auto simp: top_def fun_order_def)

lemma bot_min: "bot \<le> f"
  by (auto simp: bot_def fun_order_def)

lemma oder_def: "f \<sqinter> g = f \<Longrightarrow> f \<le> g"
  by (metis fun_inter_def fun_order_def le_iff_inf)

lemma order_def_var: "f \<le> g \<Longrightarrow> f \<sqinter> g = f"
  by (auto simp: fun_inter_def fun_order_def)

lemma adjoint_idem [simp]: "adjoint (adjoint f) = f"
  by (auto simp: adjoint_def)

lemma adjoint_prop1[simp]: "(f o top) \<sqinter> (adjoint f o bot) = bot"
  by (auto simp: fun_inter_def adjoint_def bot_def top_def)

lemma adjoint_prop2[simp]: "(f o top) + (adjoint f o bot) = top"
  by (auto simp: fun_union_def adjoint_def bot_def top_def)

lemma adjoint_mult: "adjoint (f o g) = adjoint f o adjoint g"
  by (auto simp: adjoint_def)

lemma adjoint_top[simp]: "adjoint top = bot"
  by (auto simp: adjoint_def bot_def top_def)

lemma N_comp1: "(N (N f)) + N f = id"
  by (auto simp: fun_union_def N_def fun_inter_def adjoint_def bot_def)

lemma N_comp2: "(N (N f)) o N f = bot"
  by (auto simp: N_def fun_inter_def adjoint_def bot_def)

lemma N_comp3: "N f o (N (N f)) = bot"
  by (auto simp: N_def fun_inter_def adjoint_def bot_def)

lemma N_de_morgan: "N (N f) o N (N g) = N (N f) \<sqinter> N (N g)"
  by (auto simp: fun_union_def N_def fun_inter_def adjoint_def bot_def)

lemma conj_pred_aux [simp]: "(\<lambda>p. x p \<union> y p) = y \<Longrightarrow> \<forall>p. x p \<subseteq> y p"
  by (metis Un_upper1)

text {*
  Next, we define a type for conjuctive or multiplicative predicate transformers.
*}

typedef 'a bool_op = "{f::'a bfun. (\<forall>g h. mono f \<and> f \<circ> g + f \<circ> h = f \<circ> (g + h) \<and> bot o f = bot)}"
  apply (rule_tac x="\<lambda>x. x" in exI)
  apply auto
  apply (metis monoI)
  by (auto simp: fun_order_def fun_union_def)

setup_lifting type_definition_bool_op

text {*
  Conjuctive predicate transformers form a dioid with tests without right annihilator.
*}

instantiation bool_op :: (type) dioid_one_zerol
begin
  lift_definition less_eq_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> bool" is fun_order .

  lift_definition less_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> bool" is "op <." .

  lift_definition zero_bool_op :: "'a bool_op" is "bot"
    by (auto simp: bot_def fun_union_def fun_order_def mono_def)

  lift_definition one_bool_op :: "'a bool_op" is "id"
    by (auto simp: fun_union_def fun_order_def mono_def)

  lift_definition times_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> 'a bool_op" is "op o"
    by (auto simp: o_def fun_union_def fun_order_def bot_def mono_def) metis

  lift_definition plus_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> 'a bool_op" is "op +"
    apply (auto simp: o_def fun_union_def fun_order_def bot_def mono_def)
    apply (metis set_mp)
    apply (metis set_mp)
    by (metis (hide_lams, no_types) Un_left_commute sup_assoc)

  instance
    by default (transfer, auto simp: fun_order_def fun_strict_order_def fun_union_def bot_def)+

end

instantiation bool_op :: (type) dioid_tests_zerol
begin
  lift_definition comp_op_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op" is "N"
    by (auto simp: N_def fun_inter_def adjoint_def bot_def fun_union_def mono_def)

  instance
    by default (transfer, auto simp: N_def fun_inter_def adjoint_def bot_def fun_union_def)+
end

definition fun_star :: "'a bfun \<Rightarrow> 'a bfun" where
  "fun_star f = lfp (\<lambda>r. f o r + id)"

definition fun_iteration :: "'a bfun \<Rightarrow> 'a bfun" where
  "fun_iteration f = gfp (\<lambda>g. f o g + id)"

text {*
  Verifying the iteration laws is left for future work. This could be obtained by integrating
  Preoteasa's approach~\cite{Preoteasa11}.
*}

end


(* Authors: F. Maric, M. Spasic *)
section \<open>Auxiliary Results\<close>
theory Simplex_Auxiliary
  imports
    "HOL-Library.Permutation"
    "HOL-Library.Mapping"
begin

(* -------------------------------------------------------------------------- *)
(* MoreList *)
(* -------------------------------------------------------------------------- *)
lemma map_reindex:
  assumes "\<forall> i < length l. g (l ! i) = f i"
  shows "map f [0..<length l] = map g l"
  using assms
  by (induct l rule: rev_induct) (auto simp add: nth_append split: if_splits)

lemma map_parametrize_idx:
  "map f l = map (\<lambda>i. f (l ! i)) [0..<length l]"
  by (induct l rule: rev_induct) (auto simp add: nth_append)

lemma last_tl:
  assumes "length l > 1"
  shows "last (tl l) = last l"
  using assms
  by (induct l) auto

lemma hd_tl:
  assumes "length l > 1"
  shows "hd (tl l) = l ! 1"
  using assms
  by (induct l) (auto simp add: hd_conv_nth)

lemma butlast_empty_conv_length:
  shows "(butlast l = []) = (length l \<le> 1)"
  by (induct l) (auto split: if_splits)

lemma butlast_nth:
  assumes "n + 1 < length l"
  shows "butlast l ! n = l ! n"
  using assms
  by (induct l rule: rev_induct) (auto simp add: nth_append)

lemma last_take_conv_nth:
  assumes "0 < n" "n \<le> length l"
  shows "last (take n l) = l ! (n - 1)"
  using assms
  by (cases "l = []") (auto simp add: last_conv_nth min_def)

lemma tl_nth:
  assumes "l \<noteq> []"
  shows "tl l ! n = l ! (n + 1)"
  using assms
  by (induct l) auto

lemma interval_3split:
  assumes "i < n"
  shows "[0..<n] = [0..<i] @ [i] @ [i+1..<n]"
proof-
  have "[0..<n] = [0..<i + 1] @ [i + 1..<n]"
    using upt_add_eq_append[of 0 "i + 1" "n - i - 1"]
    using \<open>i < n\<close>
    by (auto simp del: upt_Suc)
  then show ?thesis
    by simp
qed

abbreviation "list_min l \<equiv> foldl min (hd l) (tl l)"
lemma list_min_Min[simp]: "l \<noteq> [] \<Longrightarrow> list_min l = Min (set l)"
proof (induct l rule: rev_induct)
  case (snoc a l')
  then show ?case
    by (cases "l' = []") (auto simp add: ac_simps)
qed simp

(* Minimal element of a list satisfying the given property *)

definition min_satisfying :: "(('a::linorder) \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where
  "min_satisfying P l \<equiv>
    let xs = filter P l in
    if xs = [] then None else Some (list_min xs)"

lemma min_satisfying_None:
  "min_satisfying P l = None \<longrightarrow>
    (\<forall> x \<in> set l. \<not> P x)"
  unfolding min_satisfying_def Let_def
  by (simp add: filter_empty_conv)

lemma min_satisfying_Some:
  "min_satisfying P l = Some x \<longrightarrow>
      x \<in> set l \<and> P x \<and> (\<forall> x' \<in> set l. x' < x \<longrightarrow> \<not> P x')"
proof (safe)
  let ?xs = "filter P l"
  assume "min_satisfying P l = Some x"
  then have "set ?xs \<noteq> {}" "x = Min (set ?xs)"
    unfolding min_satisfying_def Let_def
    by (auto split: if_splits simp add: filter_empty_conv)
  then show "x \<in> set l" "P x"
    using Min_in[of "set ?xs"]
    by simp_all
  fix x'
  assume "x' \<in> set l" "P x'" "x' < x"
  have "x' \<notin> set ?xs"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "x' \<ge> x"
      using \<open>x = Min (set ?xs)\<close>
      by simp
    then show False
      using \<open>x' < x\<close>
      by simp
  qed
  then show "False"
    using \<open>x' \<in> set l\<close> \<open>P x'\<close>
    by simp
qed

(* -------------------------------------------------------------------------- *)
(* MoreNat *)
(* -------------------------------------------------------------------------- *)

lemma min_element:
  fixes k :: nat
  assumes "\<exists> (m::nat). P m"
  shows "\<exists> mm. P mm \<and> (\<forall> m'. m' < mm \<longrightarrow> \<not> P m')"
proof-
  from assms obtain m where "P m"
    by auto
  show ?thesis
  proof (cases "\<forall>m'<m. \<not> P m'")
    case True
    then show ?thesis
      using \<open>P m\<close>
      by auto
  next
    case False
    then show ?thesis
    proof (induct m)
      case 0
      then show ?case
        by auto
    next
      case (Suc m')
      then show ?case
        by (cases "\<not> (\<forall>m'a<m'. \<not> P m'a)") auto
    qed
  qed
qed

(* -------------------------------------------------------------------------- *)
(* MoreFun *)
(* -------------------------------------------------------------------------- *)

lemma finite_fun_args:
  assumes "finite A" "\<forall> a \<in> A. finite (B a)"
  shows "finite {f. (\<forall> a. if a \<in> A then f a \<in> B a else f a = f0 a)}" (is "finite (?F A)")
  using assms
proof (induct)
  case empty
  have "?F {} = {\<lambda> x. f0 x}"
    by auto
  then show ?case
    by auto
next
  case (insert a A')
  then have "finite (?F A')"
    by auto
  let ?f = "\<lambda> f. {f'. (\<forall> a'. if a = a' then f' a \<in> B a else f' a' = f a')}"
  have "\<forall> f \<in> ?F A'. finite (?f f)"
  proof
    fix f
    assume "f \<in> ?F A'"
    then have "?f f = (\<lambda> b. f (a := b)) ` B a"
      by (force split: if_splits)
    then show "finite (?f f)"
      using \<open>\<forall>a\<in>insert a A'. finite (B a)\<close>
      by auto
  qed
  then have "finite (\<Union> (?f ` (?F A')))"
    using \<open>finite (?F A')\<close>
    by auto
  moreover
  have "?F (insert a A') = \<Union> (?f ` (?F A'))"
  proof
    show "?F (insert a A') \<subseteq> \<Union> (?f ` (?F A'))"
    proof
      fix f
      assume "f \<in> ?F (insert a A')"
      then have "f \<in> ?f (f (a := f0 a))" "f (a := f0 a) \<in> ?F A'"
        using \<open>a \<notin> A'\<close>
        by auto
      then show "f \<in> \<Union> (?f ` (?F A'))"
        by blast
    qed
  next
    show "\<Union> (?f ` (?F A')) \<subseteq> ?F (insert a A')"
    proof
      fix f
      assume "f \<in> \<Union> (?f ` (?F A'))"
      then obtain f0 where "f0 \<in> ?F A'" "f \<in> ?f f0"
        by auto
      then show "f \<in> ?F (insert a A')"
        using \<open>a \<notin> A'\<close>
        by (force split: if_splits)
    qed
  qed
  ultimately
  show ?case
    by simp
qed

(* -------------------------------------------------------------------------- *)
(* MoreMapping *)
(* -------------------------------------------------------------------------- *)

lemma foldl_mapping_update:
  assumes "X \<in> set l" "distinct (map f l)"
  shows "Mapping.lookup (foldl (\<lambda>m a. Mapping.update (f a) (g a) m) i l) (f X) = Some (g X)"
  using assms
proof(induct l rule:rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc h t)
  show ?case
  proof (cases "f h = f X")
    case True
    then show ?thesis using snoc by (auto simp: lookup_update)
  next
    case False
    show ?thesis by (simp add: lookup_update' False, rule snoc, insert False snoc, auto)
  qed
qed

end


section \<open>Kronecker Factorization\<close>

text \<open>This theory contains Kronecker's factorization algorithm to factor
  integer or rational polynomials.\<close>

theory Kronecker_Factorization
imports
  Polynomial_Interpolation.Polynomial_Interpolation
  Sqrt_Babylonian.Sqrt_Babylonian_Auxiliary
  Missing_List
  Prime_Factorization
  Precomputation
  Gauss_Lemma
  Dvd_Int_Poly
begin

subsection \<open>Definitions\<close>
context
  fixes df :: "int \<Rightarrow> int list"
  and dp :: "int \<Rightarrow> int list"
  and bnd :: nat
begin

definition kronecker_samples :: "nat \<Rightarrow> int list" where
  "kronecker_samples n \<equiv> let min = - int (n div 2) in [min .. min + int n]"

lemma kronecker_samples_0: "0 \<in> set (kronecker_samples n)" unfolding kronecker_samples_def by auto

text \<open>Since 0 is always a samples value, we make a case analysis:
   we only take positive divisors of $p(0)$, and consider all divisors for other $p(j)$.\<close>
definition kronecker_factorization_main :: "int poly \<Rightarrow> int poly option" where
  "kronecker_factorization_main p \<equiv> if degree p \<le> 1 then None else let
     p = primitive_part p;
     js = kronecker_samples bnd;
     cjs = map (\<lambda> j. (poly p j, j)) js
   in (case map_of cjs 0 of
     Some j \<Rightarrow> Some ([:- j, 1 :])
   | None \<Rightarrow> let djs = map (\<lambda> (v,j). map (Pair j) (if j = 0 then dp v else df v)) cjs in
     map_option the (find_map_filter newton_interpolation_poly_int
     (\<lambda> go. case go of None \<Rightarrow> False | Some g \<Rightarrow> dvd_int_poly_non_0 g p \<and> degree g \<ge> 1)
       (concat_lists djs)))"

definition kronecker_factorization_rat_main :: "rat poly \<Rightarrow> rat poly option" where
  "kronecker_factorization_rat_main p \<equiv> map_option (map_poly of_int)
     (kronecker_factorization_main (snd (rat_to_normalized_int_poly p)))"
end

definition kronecker_factorization :: "int poly \<Rightarrow> int poly option" where
  "kronecker_factorization p =
     kronecker_factorization_main divisors_int divisors_int_pos (degree p div 2) p"

definition kronecker_factorization_rat :: "rat poly \<Rightarrow> rat poly option" where
  "kronecker_factorization_rat p =
     kronecker_factorization_rat_main divisors_int divisors_int_pos (degree p div 2) p"

subsection \<open>Code setup for divisors\<close>

definition "divisors_nat_copy n \<equiv> if n = 0 then [] else remdups_adj (sort (map prod_list (subseqs (prime_factorization_nat n))))"

lemma divisors_nat_copy[simp]: "divisors_nat_copy = divisors_nat"
  unfolding divisors_nat_def[abs_def] divisors_nat_copy_def[abs_def] ..

definition "memo_divisors_nat \<equiv> memo_nat 0 100 divisors_nat_copy"

lemma memo_divisors_nat[code_unfold]: "divisors_nat = memo_divisors_nat"
  unfolding memo_divisors_nat_def by simp

subsection \<open>Proofs\<close>

context
begin

lemma rat_to_int_poly_of_int: assumes rp: "rat_to_int_poly (map_poly of_int p) = (c,q)"
  shows "c = 1" "q = p"
proof -
  define xs where "xs = map (snd \<circ> quotient_of) (coeffs (map_poly rat_of_int p))"
  have xs: "set xs \<subseteq> {1}" unfolding xs_def by auto
  from assms[unfolded rat_to_int_poly_def Let_def]
  have c: "c = fst (common_denom (coeffs (map_poly rat_of_int p)))" by auto
  also have "\<dots> = list_lcm xs"
    unfolding common_denom_def Let_def xs_def by (simp add: o_assoc)
  also have "\<dots> = 1" using xs
    by (induct xs, auto)
  finally show c: "c = 1" by auto
  from rat_to_int_poly[OF rp, unfolded c] show "q = p" by auto
qed

lemma rat_to_normalized_int_poly_of_int: assumes "rat_to_normalized_int_poly (map_poly of_int p) = (c,q)"
  shows "c \<in> \<int>" "p \<noteq> 0 \<Longrightarrow> c = of_int (content p) \<and> q = primitive_part p"
proof -
  obtain d r where ri: "rat_to_int_poly (map_poly rat_of_int p) = (d,r)" by force
  from rat_to_int_poly_of_int[OF ri]
    assms[unfolded rat_to_normalized_int_poly_def ri split]
  show "c \<in> \<int>" "p \<noteq> 0 \<Longrightarrow> c = of_int (content p) \<and> q = primitive_part p"
    by (auto split: if_splits)
qed

lemma dvd_poly_int_content_1: assumes c_x: "content x = 1"
  shows "(x dvd y) = (map_poly rat_of_int x dvd map_poly of_int y)"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  show ?thesis
  proof
    assume "x dvd y"
    then obtain z where "y = x * z" unfolding dvd_def by auto
    from arg_cong[OF this, of ?rp]
    show "?rp x dvd ?rp y" by auto
  next
    assume dvd: "?rp x dvd ?rp y"
    show "x dvd y"
    proof (cases "y = 0")
      case True
      thus ?thesis by auto
    next
      case False note y0 = this
      hence "?rp y \<noteq> 0" by simp
      hence rx0: "?rp x \<noteq> 0" using dvd by auto
      hence x0: "x \<noteq> 0" by simp
      from dvd obtain z where prod: "?rp y = ?rp x * z" unfolding dvd_def by auto
      obtain cx xx where x: "rat_to_normalized_int_poly (?rp x) = (cx, xx)" by force
      from rat_to_int_factor_explicit[OF prod x] obtain z where y: "y = xx * smult (content y) z" by auto
      from rat_to_normalized_int_poly[OF x] rx0 have xx: "?rp x = smult cx (?rp xx)"
        and cxx: "content xx = 1" and cx0: "cx > 0" by auto
      obtain cn cd where quot: "quotient_of cx = (cn,cd)" by force
      from quotient_of_div[OF quot] have cx: "cx = ?r cn / ?r cd" by auto
      from quotient_of_denom_pos[OF quot] have cd0: "cd > 0" by auto
      with cx cx0 have cn0: "cn > 0" by (simp add: zero_less_divide_iff)
      from arg_cong[OF xx, of "smult (?r cd)"] have "smult (?r cd) (?rp x) = smult (?r cn) (?rp xx)"
        unfolding cx using cd0 by (auto simp: field_simps)
      from this have id: "smult cd x = smult cn xx" by (fold hom_distribs, unfold of_int_poly_hom.eq_iff)
      from arg_cong[OF this, of content, unfolded content_smult_int cxx] cn0 cd0
      have cn: "cn = cd * content x" by auto
      from quotient_of_coprime[OF quot, unfolded cn] cd0 have "cd = 1" by auto
      with cx have cx: "cx = ?r cn" by auto
      from xx[unfolded this] have x: "x = smult cn xx" by (fold hom_distribs, simp)
      from arg_cong[OF this, of content, unfolded content_smult_int c_x cxx] cn0 have "cn = 1" by auto
      with x have xx: "xx = x" by auto
      show "x dvd y" using y[unfolded xx] unfolding dvd_def by blast
    qed
  qed
qed

lemma content_x_minus_const_int[simp]: "content [: c, 1 :] = (1 :: int)"
  unfolding content_def by auto

lemma length_upto_add_nat[simp]: "length [a .. a + int n] = Suc n"
proof (induct n arbitrary: a)
  case (0 a)
  show ?case using upto.simps[of a a] by auto
next
  case (Suc n a)
  from Suc[of "a + 1"]
  show ?case using upto.simps[of a "a + int (Suc n)"] by (auto simp: ac_simps)
qed

lemma kronecker_samples: "distinct (kronecker_samples n)" "length (kronecker_samples n) = Suc n"
  unfolding kronecker_samples_def Let_def length_upto_add_nat by auto

lemma dvd_int_poly_non_0_degree_1[simp]: "degree q \<ge> 1 \<Longrightarrow> dvd_int_poly_non_0 q p = (q dvd p)"
  by (intro dvd_int_poly_non_0, auto)

context fixes df dp :: "int \<Rightarrow> int list"
  and bnd :: nat
begin

lemma kronecker_factorization_main_sound: assumes some: "kronecker_factorization_main df dp bnd p = Some q"
  and bnd: "degree p \<ge> 2 \<Longrightarrow> bnd \<ge> 1"
  shows "degree q \<ge> 1" "degree q \<le> bnd" "q dvd p"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  note res = some[unfolded kronecker_factorization_main_def Let_def]
  from res have dp: "degree p \<ge> 2" and "(degree p \<le> 1) = False" by (auto split: if_splits)
  note res = res[unfolded this if_False]
  note bnd = bnd[OF dp]
  define P where "P = primitive_part p"
  have degP: "degree P = degree p" unfolding P_def by simp
  define js where "js = kronecker_samples bnd"
  define filt where "filt = (case_option False (\<lambda>g. dvd_int_poly_non_0 g P \<and> 1 \<le> degree g))"
  define tests where "tests = concat_lists (map (\<lambda>(v, j). map (Pair j) (if j = 0 then dp v else df v)) (map (\<lambda>j. (poly P j, j)) js))"
  note res = res[folded P_def, folded js_def filt_def, folded tests_def]
  let ?zero = "map (\<lambda>j. (poly P j, j)) js"
  from res have res: "(case map_of ?zero 0 of
     None \<Rightarrow> map_option the (find_map_filter newton_interpolation_poly_int filt tests) | Some j \<Rightarrow> Some [:- j, 1:]) =
     Some q" by auto
  have "degree q \<ge> 1 \<and> degree q \<le> bnd \<and> q dvd P"
  proof (cases "map_of ?zero 0")
    case (Some j)
    with res have q: "q = [: - j, 1 :]" by auto
    from map_of_SomeD[OF Some] have 0: "poly P j = 0" by auto
    hence "poly (?rp P) (?r j) = 0" by simp
    hence "[: - ?r j, 1 :] dvd ?rp P" using poly_eq_0_iff_dvd by blast
    also have "[: - ?r j, 1 :] = ?rp q" unfolding q by simp
    finally have dvd: "?rp q dvd ?rp P" .
    have "q dvd P"
      by (subst dvd_poly_int_content_1, insert dvd q, auto)
    with q dp bnd show ?thesis by auto
  next
    case None
    from res[unfolded None]
    have res: "map_option the (find_map_filter newton_interpolation_poly_int filt tests) = Some q" by auto
    then obtain qq where
      res: "find_map_filter newton_interpolation_poly_int filt tests = Some qq" and q: "q = the qq"
      by (auto split: option.splits)
    from find_map_filter_Some[OF res]
    have filt: "filt qq" and tests: "qq \<in> newton_interpolation_poly_int ` set tests" by auto
    from filt[unfolded filt_def] q obtain g where dvd: "g dvd P" and dg: "1 \<le> degree g" and qq: "qq = Some g"
      by (cases qq, auto)
    from q qq have gq: "g = q" by auto
    from tests obtain t where t: "t \<in> set tests" and l: "newton_interpolation_poly_int t = Some g" unfolding qq
      by auto
    from t[unfolded tests_def]
    have lent: "length t = length js" and "\<And> i. i < length js \<Longrightarrow> map fst t ! i = js ! i" by auto
    hence id: "map fst t = js"
      by (intro nth_equalityI, auto)
    have dist: "distinct js" and lenj: "length js = Suc bnd" unfolding js_def degP
      using kronecker_samples by auto
    from newton_interpolation_poly_int_Some[OF dist[folded id] l, unfolded lent lenj]
    have "degree g \<le> bnd" by auto
    with dvd dg show ?thesis unfolding gq by auto
  qed note main = this
  thus "degree q \<ge> 1" "degree q \<le> bnd" by auto
  from content_times_primitive_part[of p] have "p = smult (content p) P" unfolding P_def by auto
  with main show "q dvd p" by (metis dvd_smult)
qed

lemma kronecker_factorization_rat_main_sound: assumes
  some: "kronecker_factorization_rat_main df dp bnd p = Some q"
  and bnd: "degree p \<ge> 2 \<Longrightarrow> bnd \<ge> 1"
  shows "degree q \<ge> 1" "degree q \<le> bnd" "q dvd p"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  let ?p = "rat_to_normalized_int_poly p"
  obtain a P where rp: "?p = (a,P)" by force
  from rat_to_normalized_int_poly[OF this] have p: "p = smult a (?rp P)" and a: "a \<noteq> 0"
    and deg: "degree P = degree p" by auto
  from some[unfolded kronecker_factorization_rat_main_def rp]
  obtain Q where some: "kronecker_factorization_main df dp bnd P = Some Q" and q: "q = ?rp Q" by auto
  from kronecker_factorization_main_sound[OF some bnd] have dQ: "1 \<le> degree Q"
    "degree Q \<le> bnd"
    and dvd: "Q dvd P" unfolding deg by auto
  from dvd obtain R where PQR: "P = Q * R" unfolding dvd_def by auto
  from p[unfolded arg_cong[OF this, of ?rp]]
  have "p = q * smult a (?rp R)" unfolding q by (auto simp: hom_distribs)
  thus "q dvd p" unfolding dvd_def by blast
  from q dQ show "degree q \<ge> 1" "degree q \<le> bnd" by auto
qed

context
  assumes df: "divisors_fun df" and dpf: "divisors_pos_fun dp"
begin

lemma kronecker_factorization_main_complete: assumes
  none: "kronecker_factorization_main df dp bnd p = None"
  and dp: "degree p \<ge> 2"
  shows "\<not> (\<exists> q. 1 \<le> degree q \<and> degree q \<le> bnd \<and> q dvd p)"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  from dp have "(degree p \<le> 1) = False" by auto
  note res = none[unfolded kronecker_factorization_main_def Let_def this if_False]
  define P where "P = primitive_part p"
  have degP: "degree P = degree p" unfolding P_def by simp
  define js where "js = kronecker_samples bnd"
  define filt where "filt = (case_option False (\<lambda>g. dvd_int_poly_non_0 g P \<and> 1 \<le> degree g))"
  define tests where "tests = concat_lists (map (\<lambda>(v, j). map (Pair j) (if j = 0 then dp v else df v)) (map (\<lambda>j. (poly P j, j)) js))"
  note res = res[folded P_def, folded js_def filt_def, folded tests_def]
  let ?zero = "map (\<lambda>j. (poly P j, j)) js"
  from res have res: "(case map_of ?zero 0 of
     None \<Rightarrow> map_option the (find_map_filter newton_interpolation_poly_int filt tests) | Some j \<Rightarrow> Some [:- j, 1:]) =
     None" by auto
  hence zero: "map_of ?zero 0 = None" by (auto split: option.splits)
  with res have res: "find_map_filter newton_interpolation_poly_int filt tests = None" by auto
  {
    fix qq
    assume qq: "1 \<le> degree qq" "degree qq \<le> bnd" and dvd: "qq dvd p"
    define q' where "q' = primitive_part qq"
    define q where "q = (if poly q' 0 > 0 then q' else -q')"
    from qq have q': "1 \<le> degree q'" "degree q' \<le> bnd" unfolding q'_def by auto
    hence q: "1 \<le> degree q" "degree q \<le> bnd" unfolding q_def by auto
    from dvd have "qq dvd (smult (content p) P)"
      using content_times_primitive_part[of p] unfolding P_def by simp
    from dvd_smult_int[OF _ this] dp have "q' dvd P" unfolding q'_def
      by force
    hence dvd: "q dvd P" unfolding q_def by auto
    then obtain r where P: "P = q * r" unfolding dvd_def by auto
    {
      fix j
      assume j: "j \<in> set js"
      from P have id: "poly P j = poly q j * poly r j" by auto
      hence dvd: "poly q j dvd poly P j" by auto
      from j have "(poly P j, j) \<in> set ?zero" by auto
      with zero have zero: "poly P j \<noteq> 0" unfolding map_of_eq_None_iff by force
      with id have "poly q j \<noteq> 0" by auto
      hence "j = 0 \<Longrightarrow> poly q j > 0" unfolding q_def by auto
      from divisors_funD[OF df zero dvd] divisors_pos_funD[OF dpf zero dvd this]
      have "poly q j \<in> set (df (poly P j))" "j = 0 \<Longrightarrow> poly q j \<in> set (dp (poly P j))" .
    } note mem1 = this
    define t where "t = map (\<lambda> j. (j, poly q j)) js"
    have t: "t \<in> set tests" unfolding tests_def concat_lists_listset listset length_map map_map o_def
    proof (rule, intro conjI allI impI)
      show "length t = length js" unfolding t_def by simp
      fix i
      assume i: "i < length js"
      hence jsi: "js ! i \<in> set js" by auto
      have ti: "t ! i = (js ! i, poly q (js ! i))" unfolding t_def using i by auto
      let ?f = "(\<lambda>x. set (case (poly P x, x) of (v, j) \<Rightarrow> map (Pair j) (if j = 0 then dp v else df v)))"
      show "t ! i \<in> map ?f js ! i"
        unfolding ti nth_map[OF i] split using mem1[OF jsi] by auto
    qed
    have dist: "distinct js" and lenj: "length js = Suc bnd" unfolding js_def degP
      using kronecker_samples by auto
    have map_fst: "map fst t = js" unfolding t_def
      by (rule nth_equalityI, auto)
    with dist have dist: "distinct (map fst t)" by simp
    from lenj q degP have degq: "degree q < length t" unfolding t_def by auto
    from find_map_filter_None[OF res] t
    have nfilt: "\<not> filt (newton_interpolation_poly_int t)" by auto
    have qt: "\<And>x y. (x, y) \<in> set t \<Longrightarrow> poly q x = y" unfolding t_def by auto
    from interpolation_poly_int_None[OF dist _ qt degq, of Newton] have
      "newton_interpolation_poly_int t \<noteq> None" by auto
    then obtain g where lt: "newton_interpolation_poly_int t = Some g" by auto
    from newton_interpolation_poly_int_Some[OF dist lt]
    have gt: "\<And> x y. (x, y) \<in> set t \<Longrightarrow> poly g x = y" and degg: "degree g < length t"
      using degq by auto
    from uniqueness_of_interpolation_point_list[OF dist qt degq gt degg]
    have g: "g = q" by auto
    from nfilt[unfolded lt g] have "\<not> filt (Some q)" .
    from this[unfolded filt_def] q dvd have False by auto
  } note main = this
  thus ?thesis by auto
qed

lemma kronecker_factorization_rat_main_complete: assumes
  none: "kronecker_factorization_rat_main df dp bnd p = None"
  and dp: "degree p \<ge> 2"
  shows "\<not> (\<exists> q. 1 \<le> degree q \<and> degree q \<le> bnd \<and> q dvd p)"
proof
  assume "\<exists> q. 1 \<le> degree q \<and> degree q \<le> bnd \<and> q dvd p"
  then obtain q where q: "1 \<le> degree q" "degree q \<le> bnd" and dvd: "q dvd p" by auto
  from dvd obtain r where prod: "p = q * r" unfolding dvd_def by auto
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  let ?p = "rat_to_normalized_int_poly p"
  obtain a P where rp: "?p = (a,P)" by force
  from rat_to_normalized_int_poly[OF this] have deg: "degree P = degree p" by auto
  from rat_to_int_factor_normalized_int_poly[OF prod rp]
    obtain g' where dvd: "g' dvd P" and dg: "degree g' = degree q" by (auto intro: dvdI)
  have "kronecker_factorization_main df dp bnd P = None"
      using none[unfolded kronecker_factorization_rat_main_def rp] by auto
  from kronecker_factorization_main_complete[OF this dp[folded deg]] dg dvd q show False by auto
qed
end
end

lemma kronecker_factorization:
  "kronecker_factorization p = Some q \<Longrightarrow>
    degree q \<ge> 1 \<and> degree q < degree p \<and> q dvd p"
  "kronecker_factorization p = None \<Longrightarrow> degree p \<ge> 1 \<Longrightarrow> irreducible\<^sub>d p"
proof -
  note d = kronecker_factorization_def
  {
    assume "kronecker_factorization p = Some q"
    from kronecker_factorization_main_sound[OF this[unfolded d]]
    show "degree q \<ge> 1 \<and> degree q < degree p \<and> q dvd p" by auto linarith
  }
  assume kf: "kronecker_factorization p = None" and deg: "degree p \<ge> 1"
  show "irreducible\<^sub>d p"
  proof (cases "degree p = 1")
    case True
    thus ?thesis by (rule linear_irreducible\<^sub>d)
  next
    case False
    with deg have "degree p \<ge> 2" by auto
    with kronecker_factorization_main_complete[OF divisors_fun_int divisors_pos_fun_int kf[unfolded d] this]
    show ?thesis
      by (intro irreducible\<^sub>dI2, auto)
  qed
qed

lemma kronecker_factorization_rat:
  "kronecker_factorization_rat p = Some q \<Longrightarrow>
    degree q \<ge> 1 \<and> degree q < degree p \<and> q dvd p"
  "kronecker_factorization_rat p = None \<Longrightarrow> degree p \<ge> 1 \<Longrightarrow> irreducible\<^sub>d p"
proof -
  note d = kronecker_factorization_rat_def
  {
    assume "kronecker_factorization_rat p = Some q"
    from kronecker_factorization_rat_main_sound[OF this[unfolded d]]
    show "degree q \<ge> 1 \<and> degree q < degree p \<and> q dvd p" by auto linarith
  }
  assume kf: "kronecker_factorization_rat p = None" and deg: "degree p \<ge> 1"
  show "irreducible\<^sub>d p"
  proof (cases "degree p = 1")
    case True
    thus ?thesis by (rule linear_irreducible\<^sub>d)
  next
    case False
    with deg have "degree p \<ge> 2" by auto
    with kronecker_factorization_rat_main_complete[OF divisors_fun_int divisors_pos_fun_int kf[unfolded d] this]
    show ?thesis
      by (intro irreducible\<^sub>dI2, auto)
  qed
qed

end
end


theory ValuesFSetProps
  imports ValuesFSet
begin

inductive_cases
  vfun_le_inv[elim!]: "VFun t1 \<sqsubseteq> VFun t2" and
  le_fun_nat_inv[elim!]: "VFun t2 \<sqsubseteq> VNat x1" and
  le_any_nat_inv[elim!]: "v \<sqsubseteq> VNat n" and
  le_nat_any_inv[elim!]: "VNat n \<sqsubseteq> v" and
  le_fun_any_inv[elim!]: "VFun t \<sqsubseteq> v" and
  le_any_fun_inv[elim!]: "v \<sqsubseteq> VFun t"

proposition val_le_refl[simp]: fixes v::val shows "v \<sqsubseteq> v" by (induction v) auto

proposition val_le_trans[trans]: fixes v2::val shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v3 \<rbrakk> \<Longrightarrow> v1 \<sqsubseteq> v3"
  by (induction v2 arbitrary: v1 v3) blast+

lemma fsubset[intro!]: "fset A \<subseteq> fset B \<Longrightarrow> A |\<subseteq>| B"
proof (rule fsubsetI)
  fix x assume ab: "fset A \<subseteq> fset B" and xa: "x |\<in>| A"
  from xa have "x \<in> fset A" using fmember.rep_eq[of x A] by simp
  from this ab have "x \<in> fset B" by blast
  from this show "x |\<in>| B" using fmember.rep_eq[of x B] by simp
qed

proposition val_le_antisymm: fixes v1::val shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v1 \<rbrakk> \<Longrightarrow> v1 = v2"
  by (induction v1 arbitrary: v2) auto

lemma le_nat_any[simp]: "VNat n \<sqsubseteq> v \<Longrightarrow> v = VNat n"
  by (cases v) auto

lemma le_nat_nat[simp]: "VNat n \<sqsubseteq> VNat n' \<Longrightarrow> n = n'"
  by auto

end


theory kuratowski imports topological_space   begin
locale kuratowski_closure  =
 fixes   X  :: "'a set" (structure)
 and     kc :: "'a set  \<Rightarrow> 'a set"
 assumes k0 : "kc \<in> (Pow X) \<rightarrow> (Pow X)"
 and     k1 : "kc {} = {}"
 and     k2 : "\<lbrakk> A \<in> Pow  X \<rbrakk> \<Longrightarrow> ( A \<subseteq> (kc A))"
 and     k3 : "\<lbrakk> A \<in> Pow  X ; B \<in> Pow X\<rbrakk>
                \<Longrightarrow> kc(A \<union> B) = (kc A) \<union> (kc B)"
 and     k4 : "\<lbrakk> A \<in> Pow  X \<rbrakk> \<Longrightarrow> kc( kc(A)) = kc(A)"

lemma Un_absorb3 : "A \<union>  B = B \<Longrightarrow>  A \<subseteq> B"
apply blast
done
(*
lemma  (in kuratowski_closure) kc_subset_1:
assumes a1: "A \<subseteq> X"
and     a2: "A\<subseteq> B"
shows   "(kc A) \<subseteq> (kc B)"
proof-
from a2 have s1:"B = A\<union> B" apply blast done
from s1 have s2: "(kc B) = kc (A \<union>  B)"  apply simp done
from a1 a2 have s3 : "B \<subseteq> X" apply blast  done
from a1 a2 have s3: "kc(A \<union> B) = (kc A) \<union> (kc B)" apply (rule k3) done
*)

lemma (in kuratowski_closure) kc_subset:
    "\<lbrakk> B \<subseteq>  X; A \<subseteq> B \<rbrakk> \<Longrightarrow> (kc A) \<subseteq>  (kc B) "

apply(rule_tac A="kc A" and B="kc B" in Un_absorb3)
apply(subgoal_tac "kc B = kc (A \<union> B)")
apply(simp add: k3)
apply(drule Un_absorb1)
apply (drule Un_absorb1)
apply simp
done

lemma (in kuratowski_closure) lemma_k1[intro,simp]:
     "\<lbrakk> A \<in> Pow X\<rbrakk>  \<Longrightarrow> ( ( kc A) \<in>( Pow X ))"
apply (subgoal_tac "kc \<in> (Pow X) \<rightarrow> (Pow X)")
apply (simp add:Pi_def k0)
apply  (simp add:k0)
done

(*
lemma (in kuratowski_closure) lemma_k2[intro,simp]:  "\<lbrakk> A \<subseteq>  X\<rbrakk>  \<Longrightarrow> ( ( clos A) \<subseteq>  X )"

apply (rule lemma_k1)

proof-
  assume a: "A \<subseteq> X"
  show  "clos A \<subseteq> X"
  proof
    from a have b: "A \<in> Pow X"  apply simp done
    from b have "clos A \<in> Pow X" apply (rule lemma_k1) done
    from b show ?thesis ..

apply (subgoal_tac "clos \<in> (Pow X) \<rightarrow> (Pow X)")
apply (simp add:Pi_def)
apply  simp
done
*)

(**)
lemma cl_0[intro,simp]:
    "T = {t. t \<subseteq> X } \<Longrightarrow> T \<subseteq>  Pow X"
apply (auto simp:Pow_def)
done

lemma (in kuratowski_closure)  cl_1 [intro,simp]:
   "\<lbrakk> T= {t. t\<subseteq> X \<and>  kc( X- t) =(X- t)  } \<rbrakk> \<Longrightarrow>  T \<subseteq> Pow X"
apply (auto simp:cl_0)
done

lemma (in kuratowski_closure) cl_2 [intro,simp]:
   "\<lbrakk> T= {t. t\<subseteq> X \<and> kc(X- t) =(X- t) } \<rbrakk> \<Longrightarrow>  {} \<in> T "
apply  (subgoal_tac "kc X = X")
apply simp
apply (subgoal_tac "kc X \<subseteq> X")
apply  (subgoal_tac "X \<subseteq> kc X")
apply  (simp )
apply simp
apply (subgoal_tac "kc X \<in> Pow  X")
apply simp
apply (subgoal_tac "X \<in> Pow X")
apply simp+
apply (rule lemma_k1)
apply simp
apply blast
done

lemma (in kuratowski_closure) cl_3 [intro,simp]:
   "\<lbrakk> T= {t. t\<subseteq> X \<and> kc (X-t) =(X- t)} \<rbrakk> \<Longrightarrow> X\<in> T"
apply  (subgoal_tac "kc {} = {}")
apply simp+
done

lemma (in kuratowski_closure)cl_4_0 [intro,simp]:
   assumes a :"T = {t. t\<subseteq> X \<and> kc (X- t) = X- t}" and b: " x\<in> T \<and>  y\<in> T"
   shows "x \<inter> y \<in> T"
proof-
  from a  b have c : "kc (X-x)=X-x \<and> kc (X-y)=X-y "  apply simp done
  have d: " X-(x \<inter> y)  = (X-x) \<union> (X-y) " apply blast done
  from d have e: "kc (  X-(x \<inter> y) ) = kc((X-x) \<union> (X-y))" apply simp  done
  from a b have f:"x \<in> Pow X \<and> y \<in> Pow X" apply simp done
  from f have g: "X-x \<in> Pow X \<and> X-y \<in> Pow X"  apply (blast) done
  from g have i: "kc ((X-x)\<union> (X-y) ) = kc(X-x) \<union> kc(X-y)" apply (simp add:k3) done
  from  c have j: "kc(X-x) \<union> kc(X-y) = (X-x) \<union> (X-y)"  apply simp done
  have k:  "(X-x) \<union> (X-y) = X-(x \<inter> y) " apply blast done
  from e  i j k have l: "kc (  X-(x \<inter> y) ) = X-( x\<inter> y) " apply simp done
  from a b l  have n1:  "x \<inter> y \<in> T" apply blast done
  from n1 show  "x \<inter> y \<in> T "  apply simp done
qed

lemma (in kuratowski_closure)cl_4 [intro,simp]:
 "\<And>x y. \<lbrakk> T= {t. t\<subseteq> X \<and> kc (X- t) = X- t}; x\<in> T ; y\<in> T\<rbrakk> \<Longrightarrow>  x \<inter> y \<in> T"
apply (rule_tac T=T and x=x and y=y in cl_4_0)
apply simp+
done

lemma(in kuratowski_closure)cl_5_0[intro,simp]:
  assumes a:" B\<subseteq> X "
      and b: "A\<subseteq> B"
      and c: "C = B - A"
  shows "kc A \<subseteq> kc B"
proof-
  from b c have d: "B=A \<union> C" apply blast done
  from d have e: "kc B = kc (A \<union> C)" apply simp done
  from a b   have f1: "A \<subseteq>  X"  apply simp done
  from a c have f2 : "C \<subseteq> X" apply blast done
  from f1 f2 have g: "kc(A \<union> C)= (kc A ) \<union> (kc C)"   apply simp done
  from e g have i: "kc B = (kc A) \<union> (kc C)" apply simp done
  from i have j: "kc A \<subseteq> kc B"  apply blast done
  from j show ?thesis apply blast done
qed

lemma(in kuratowski_closure)cl_5_1[intro,simp]:
 "\<lbrakk> B\<subseteq> X; A \<subseteq> B\<rbrakk> \<Longrightarrow> kc A \<subseteq> kc B "
apply simp
done

lemma (in kuratowski_closure)cl_5_2[intro,simp]:
  assumes a1 :"T = {t. t \<subseteq> X \<and> kc (X- t) =X- t}"
      and a2 : "M \<subseteq> T"
      and a3 : "U=\<Union>M"
      and a4 : "A \<in> M"
      and a5 : "U'=X - U"
      and a6 : "A' = X - A"
  shows "kc U' \<subseteq>  A'"
proof-
   from a3 a4 a5 a6 have b :"U'\<subseteq> A'" apply blast done
   from a2 a2 b a5 a6 have c : "A'\<subseteq> X" apply blast done
   from b c have c : "kc U' \<subseteq> kc A'" apply simp done
   from  a2  a4 have d: "A \<in> T" apply blast done
   from  a1 d a6 have e: "kc A' = A'" apply simp done
   from c  e show ?thesis apply simp done
qed

lemma(in kuratowski_closure)cl_5_3[intro,simp]:
"\<And>A.  \<lbrakk> T = {t. t\<subseteq> X \<and> kc (X-t)=X-t}; M\<subseteq> T ; A \<in> M\<rbrakk> \<Longrightarrow> kc ( X - \<Union>M)  \<subseteq> X- A "
apply simp
done

lemma (in kuratowski_closure)cl_5_4[intro,simp]:
  assumes a1 :"T = {t. t \<subseteq> X \<and> kc (X- t) =X- t}"
      and a2 : "M \<subseteq> T"
      and a3 : "U=\<Union>M"
      and a4 : "L={a'.\<exists>a\<in>M. a'=X-a}"
      and a5 : "A'\<in> L"
     (* and a6 : "A = X-A'"*)
  shows " (X-A') \<in> M"
proof-
   from a1 a2 a3 a4 a5  have b :"\<exists>a \<in> M. A'=X-a " apply simp done
   from b have c : "\<exists>a\<in>M.  X-A' = X -(X-a) " apply blast done
   from a1 a2 have d : "\<forall>a\<in>M. a\<subseteq> X " apply blast done
   from d have e: "\<forall>a\<in>M. a = X-(X-a)"  apply blast done
   from c e have f: "\<exists>a\<in>M. X-A' = a  " apply simp done
   from e f show ?thesis apply blast done
qed

lemma(in kuratowski_closure)cl_5_5[intro,simp]:
"\<And>A'. \<lbrakk> T = {t. t\<subseteq> X \<and> kc (X-t)=X-t}; M\<subseteq> T ;L={a'.\<exists>a\<in>M. a'=X-a }; A'\<in>L \<rbrakk> \<Longrightarrow>  (X-A')\<in> M"
apply blast
done

lemma (in kuratowski_closure)cl_5_6[intro,simp]:
  assumes a1 :"T = {t. t \<subseteq> X \<and> kc (X- t) =X- t}"
      and a2 : "M \<subseteq> T"
      and a3 : "U=\<Union>M"
      and a4 : "L={a'.\<exists>a\<in>M. a'=X-a}"
      and a5 : "A'\<in> L"
     (* and a6 : "A = X-A'"*)
      and a7 : "U' = X-U"
  shows "kc U' \<subseteq>  A'"
proof-
   from a1 a2 a3 a4 a5  a7  have b :" (X-A') \<in> M " apply simp done
   from a1 a2 a3 a4 a5  a7 b have c : "U' \<subseteq> A'" apply blast done
   from a1 a2 a3 a4 a5  a7 b c have d :" A' \<subseteq> X "  apply blast done
   from c d have e: "kc U' \<subseteq> kc A' " apply auto done
   from b a2 have f: "X -A' \<in> T" apply blast done
   from  f d  have g: "A' = X- (X-A')" apply blast done
   from a1  f g have i : "kc (X - (X-A')) = X-(X-A')" apply blast done
   from g i have j: "kc A' = A'" apply simp done
   from e j show ?thesis apply blast done
qed

lemma(in kuratowski_closure)cl_5_7[intro,simp]:
"\<And>A'. \<lbrakk> T = {t. t\<subseteq> X \<and> kc (X-t)=X-t}; M\<subseteq> T ;L={a'.\<exists>a\<in>M. a'=X-a }; A'\<in>L  \<rbrakk> \<Longrightarrow>  kc (X-\<Union>M ) \<subseteq> A' "
apply simp
done

lemma cl_5_8[intro,simp]:
"\<lbrakk>\<And>A. A \<in> C \<Longrightarrow>  B \<subseteq> A\<rbrakk> \<Longrightarrow> B \<subseteq> \<Inter>C "
apply blast
done

lemma cl_5_9[intro,simp]:"\<lbrakk> A \<subseteq> Pow X \<rbrakk> \<Longrightarrow> \<Union>A =X- \<Inter>{a'. \<exists> a\<in> A.  a'=X-a}"
apply blast
done
(*
lemma cl_5_10[intro,simp]:"\<lbrakk> A \<subseteq> Pow X \<rbrakk> \<Longrightarrow> \<Inter>{a'. \<exists> a\<in> A.  a'=X-a}= X - \<Union>A  "
apply blast
*)
(*
lemma Inter_lower: "B \<in> A ==> Inter A \<subseteq> B"
  by blast

lemma Inter_subset2:
  "[| !!X. X \<in> A ==> X \<subseteq> B; A ~= {} |] ==> \<Inter>A \<subseteq> B"
apply (simp add:Inter_subset)
done
*)
(*
lemma "\<not> A \<noteq> {} \<Longrightarrow> A ={}"
apply simp
done
*)

lemma (in kuratowski_closure)cl_5_10[intro,simp]:
  assumes a1 :"T = {t. t \<subseteq> X \<and> kc (X- t) =X- t}"
      and a2 : "M \<subseteq> T"
      and a3 : "L={a'.\<exists>a\<in>M. a'=X-a}"
  shows " \<Union>M \<in> T "
proof-
  from a1 a2 a3 have b: "\<And>A'.  A'\<in> L \<Longrightarrow> kc (X-\<Union>M) \<subseteq> A' "apply (simp add:cl_5_7) done
  then have c: "kc (X - \<Union>M) \<subseteq> \<Inter>L "  apply (simp add:cl_5_8) done
  from a1 a2 a3 have d : "M \<subseteq> Pow X" apply blast done
  from a1 a3  d  have e: "\<Union>M =X - \<Inter>L  " apply (simp add:cl_5_9) done
 (* from a1 a2 a3 d e  have "L ={} \<Longrightarrow> M ={}"  apply auto done *)
  from a1 a2 a3 d  have f: "\<forall>a. a \<in> M \<Longrightarrow>  a \<subseteq>  X  " apply blast done
  from f have g: "\<forall>a. a\<in>M \<Longrightarrow> X-a \<subseteq> X   "  apply blast done
  have i : " kc ( X - \<Union>M) = X-\<Union>M"
       proof cases
       assume  i1:"L={}"
         from a1 a2 a3 d e i1 have i2: "M={}"  apply auto done
         from i2 have i3 : "\<Union>M = {} "  apply simp done
         from a1 have i4 : "kc X = X"
               apply (subgoal_tac "kc X \<subseteq> X")
               apply  (subgoal_tac "X \<subseteq> kc X")
               apply  simp+
               apply (subgoal_tac "kc X \<in> Pow  X")
               apply simp
               apply (subgoal_tac "X \<in> Pow X")
               apply (rule lemma_k1)
               apply simp+  done
        from i3 have i5 : "X - \<Union>M = X " apply blast done
        from i5 have i6 : "kc(X - \<Union>M ) = kc X" apply simp done
        from i4 i5 i6 have  i7:  "kc (X- \<Union>M) = X -\<Union>M  " apply simp done
        from i7   show ?thesis apply simp done
      next
      assume j1: "\<not> L = {}"
        from j1 have j2 :"L \<noteq> {}"  apply simp done
        from a1 a2 a3 g have i : "!!a'. a'\<in> L \<Longrightarrow> a' \<subseteq> X "  apply blast done
        from j2 i have j: "\<Inter>L \<subseteq> X "  apply (simp add:Inter_subset) done
        from j  have k : " X - (X - \<Inter>L) = \<Inter>L"  apply blast done
        from e k have l : "X - \<Union>M = \<Inter>L  " apply simp done
        from l c have m: "kc ( X - \<Union>M)  \<subseteq> X-\<Union>M" apply simp done
        from d have n : "(X- \<Union>M) \<in>  Pow X " apply blast done
        from n have o : "(X- \<Union>M ) \<subseteq> kc (X -\<Union>M )"apply (simp add:k2) done
        from m o have p: "kc (X - \<Union>M) = (X -\<Union>M ) " apply simp done
        from p show ?thesis apply simp done
      qed
      from d a1 a2  have q : "\<Union>M \<subseteq> X "  apply blast done
      from a1 i q show  ?thesis apply simp  done
qed

lemma (in kuratowski_closure) cl_5[intro,simp]:
"\<lbrakk>T = {t. t \<subseteq> X \<and> kc(X- t) =X- t}; M \<subseteq> T \<rbrakk> \<Longrightarrow> \<Union>M \<in> T"
apply ( rule cl_5_10)
apply simp+
done

lemma (in kuratowski_closure )
   "\<lbrakk> T= {t. t\<subseteq> X \<and> kc(X - t) = X - t} \<rbrakk>
       \<Longrightarrow>  topological_space T X"

apply (rule topological_space.intro)
\<dots>
done

apply (simp add:cl_1)
apply (simp add:cl_2)
apply (subgoal_tac "kc X \<subseteq> X")
apply (subgoal_tac "X \<subseteq> kc X")
apply (simp )
apply simp
apply (subgoal_tac "kc X \<in> Pow  X")
apply simp
apply (subgoal_tac "X \<in> Pow X")
apply (rule lemma_k1)
apply simp
apply simp
apply (simp add:cl_3)
apply (rule cl_4_0)
apply simp
apply simp
apply (rule cl_5_10)
apply simp+
done

definition (in kuratowski_closure)
   T   where
" T =  {t. t\<subseteq> X \<and> kc (X- t) = X- t}"

lemma (in kuratowski_closure)  T_subset_pow :
   " T \<subseteq> Pow X"
apply (auto simp:Pi_def T_def)
done

lemma (in kuratowski_closure) kc_in_pow :  "\<lbrakk> A \<in> Pow X\<rbrakk>  \<Longrightarrow> ( ( kc A) \<in>( Pow X ))"
apply (subgoal_tac "kc \<in> (Pow X) \<rightarrow> (Pow X)")
apply (simp add:Pi_def)
apply  simp
done

lemma (in kuratowski_closure) KC_X_eq:
    "kc X = X"
apply (rule subset_antisym )
apply  (rule PowD)
apply   (rule_tac  A =X  in kc_in_pow)
apply (rule Pow_top)
apply (rule k2)
apply (rule Pow_top)
done

lemma (in kuratowski_closure) KC_subset:
  "\<lbrakk> A \<in> Pow X ; B \<in> Pow X ; A \<subseteq> B  \<rbrakk> \<Longrightarrow> (kc A) \<subseteq> (kc B)  "
apply (subgoal_tac "(kc A) \<subseteq> kc (A \<union> B) ")
apply (subgoal_tac "A \<union> B = B")
apply simp
apply (rule  Un_absorb1)
apply assumption
apply (subgoal_tac "(kc A) \<subseteq>  (kc A) \<union> (kc B)")
apply simp
apply (rule  Un_upper1)
done

lemma(in kuratowski_closure) KC_inter:
  "\<lbrakk> A \<in> Pow X ; B \<in> Pow X  \<rbrakk> \<Longrightarrow> (kc (A \<inter> B)) \<subseteq> (kc A) \<inter> (kc B) "
apply auto
done

lemma (in kuratowski_closure) ww:
  "\<lbrakk> p \<in> X\<rbrakk> \<Longrightarrow> kc {p} = {p}"
apply (rule  subset_antisym)
apply auto
done

lemma (in kuratowski_closure) empty_in_T :
   "{} \<in> T "
apply (simp add:T_def)
apply (rule KC_X_eq)
done

lemma (in kuratowski_closure) X_in_T :
   " X\<in> T"
apply (simp add:T_def)
done