theory tests_for_isagym_from_chapter5_exercises
imports Main
begin

(*
Exercise 5.1. Give a readable, structured proof of the following lemma:
*)

thm allE (* \<lbrakk>\<forall>x. ?P x; ?P ?x \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
thm exE (* \<lbrakk>\<exists>x. ?P x; \<And>x. ?P x \<Longrightarrow> ?Q\<rbrakk> \<Longrightarrow> ?Q *)
lemma exercise5p1_apply:
"\<lbrakk> \<forall>x y. T x y \<or> T y x;(\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y);(\<forall>x y. T x y \<longrightarrow> A x y); A x y\<rbrakk> \<Longrightarrow> T x y"
  by metis

thm HOL.mp (* \<lbrakk>?P \<longrightarrow> ?Q; ?P\<rbrakk> \<Longrightarrow> ?Q *)
thm conjE (* \<lbrakk>?P \<and> ?Q; \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
lemma exercise5p1:
  assumes T: "\<forall>x y. T x y \<or> T y x"
    and   A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
    and   TA: "\<forall>x y. T x y \<longrightarrow> A x y"
    and   "A x y"
  shows "T x y"
proof -
  have T2: "T x y \<or> T y x" using T by simp
  show "T x y" using T2 proof (rule disjE) (* 1) *)
    (* Part 0*)
    show "T x y \<Longrightarrow> T x y" by assumption (* 2) *)
    show "T y x \<Longrightarrow> T x y" proof -
      (* Part 1: *)
      have TA3: "T y x \<longrightarrow> A y x" using TA by (simp add: TA) (* 3) *)
      assume "T y x" (* 1) *)
      have "A y x" using TA3 `T y x` by (rule HOL.mp) (* 4) *)
      (* Part 2: *)
      have A2: "A x y \<and> A y x \<longrightarrow> x = y" using A by simp (* 5 *)
      have "x=y" using `A y x` `A x y` A2 by simp (* 6 *)
      show "T x y" using `x=y` `T y x` by simp (* 7 *)
    qed
  qed
qed

(*
this second version fixes the issue with the previous version
of the proof to strcture it in a more Isar style according to
section 5.2 of the Proof Pattern chapter
*)
lemma exercise5version2:
  assumes T: "\<forall>x y. T x y \<or> T y x"
    and   A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
    and   TA: "\<forall>x y. T x y \<longrightarrow> A x y"
    and   "A x y"
  shows "T x y"
proof -
  have T2: "T x y \<or> T y x" using T by simp
  show "T x y" using T2 proof (rule disjE) (* 1) *)
    (* Part 0*)
    assume "T x y"
    show "T x y" using `T x y` by assumption (* 2) *)
  next
    assume "T y x"
    show "T x y" proof -
      (* Part 1: *)
      have TA3: "T y x \<longrightarrow> A y x" using TA by (simp add: TA) (* 3) *)
      have "A y x" using TA3 `T y x` by (rule HOL.mp) (* 4) *)
      (* Part 2: *)
      have A2: "A x y \<and> A y x \<longrightarrow> x = y" using A by simp (* 5 *)
      have "x=y" using `A y x` `A x y` A2 by simp (* 6 *)
      show "T x y" using `x=y` `T y x` by simp (* 7 *)
    qed
  qed
qed

(*
We want to show T x y.
To show that we do:
1) disjE and try to prove T x y from both T x y and T y x.
Part 0: the trivial case from disjE
2) From T x y goal (T x y) is trivial (just by assumption)
Part 1: Now we want the goal T x y from (assm) T y x. The idea is to show x=y to have T y x = T x y.
To do that we need A y x and A x y. So first we get A y x:
3) Establish T y x \<rightarrow> A y x from initial thm assumption TA
4) Use disjE assumption T y x and TA3 (T y x \<longrightarrow> A y x) to get A y x.
Part 2: Now the second part to conclude the proof:
5) Establish we can indeed do A x y \<and> A y x \<longrightarrow> x = y from initial thm assumption.
6) Establish x=y from A y x (from 4) and A x y (from initial thm assumption)
7) Complete proof using all the facts we need x=y & T y x \<rightarrow> T x y.
Done

*)

(* Note to self. The insight was that you needed to use T x y \<or> T y x. Using that you get by disjE
that you need to proof some goal using them seperately. The insight was that if you noticed that
A y x would give you x = y which would ultimately give you T x y. But A y x was NOT true by iself,
so when you tried proving it by itself you failed (of course). BUT disjE allowed you to get T y x
by itself which would give you the goal you needed, A y x which gave x = y which have T x y using
T y x. So apply disjE early on. Then the first assumption it introduces IS the goal so it ends
immediately. Then you do need to use more logic to get to A y x but you ONLY have to show A y x
using T y x, instead of needing to show A y x using T x y also (which probably can't be done).
The reason that problem would occur is if you try to have A y x as a stand alone theorem, which is
not true. It's only true using ONLY T y x.
*)

(*
Exercise 5.2. Give a readable, structured proof of the following lemma

Hint: There are predefined functions take :: nat \<Rightarrow> ′a list \<Rightarrow> ′a list and
drop :: nat \<Rightarrow> ′a list \<Rightarrow> ′a list such that
take k [x1,...] = [x1,...,xk] and drop k [x1,...] = [xk+1,...].
Let sledgehammer find and apply the relevant
take and drop lemmas for you.
*)

lemma "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
  apply (cases)
  sorry

lemma
  shows "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof (cases)
  assume 0: "2 dvd (length xs)" (* length xs = 2*k *) (* 1 *)
  (* this is the crux cuz it gives us how many elements k we need from knowing length xs = 2*k *)
  obtain k where 1: "length xs = 2*k" using 0 by blast (* 2 *)
  let ?ys="take k xs" (* 3 *)
  let ?zs="drop k xs" (* 3 *)
  have 2: "xs = ?ys @ ?zs" by auto (* 4 *)
  have 3:"length ?ys = length ?zs" using 0 1 by auto (* 5 *)
  show ?thesis using 2 3 by blast (* 6 *)
next
  assume 0: "\<not> 2 dvd (length xs)" (* length xs = 2*k+1 *) (* 1 *)
  obtain k where 1: "length xs = 2*k+1" using 0 using oddE by blast (* 2 *)
  let ?ys="take (k+1) xs" (* 3 *)
  let ?zs="drop (k+1) xs" (* 3 *)
  have 2: "xs = ?ys @ ?zs" by simp (* 4 *)
  have 5: "length ?ys = (length ?zs) + 1" using 1 by auto (* 5 *)
  show ?thesis using 2 5 by blast (* 6 *)
qed

(*
thm: Show that given a list xs you can always find two lists to split xs s.t. they combine to get
the original list and the split can be done evenly or just 1 off.
There are two cases:
Part 1: xs is even length so the split is perfectly even
Part 2: xs is not even so the split is 1 off from even.
The technique to show them is the same (except with the negation of the other, i.e. even or odd):
1) Do assumtion, xs is even or not (wlog xs is even)
2) get the length k of the list you need via isabelle
3) define the appropriate splits from take and drop
4) use the splits to show they combine to give xs
5) use the splits to get the length and show k'=k (even case) or k'=k+1 (odd case)
6) using 4 and 5 proof is concluded for both cases

*)

(* Exercise 5.3
Give a structured proof by rule inversion:
lemma assumes a: "ev(Suc(Suc n))" shows "ev n"

rule inversion: case analysis to which rules could have been used to arrive at certain facts.
e.g.
ev n \<Longrightarrow> n=0 \<or> (\<exists>k. n = Suc(Suc(k)) \<and> ev k )
i.e. if we have the fact ev n, we could have arrived using either rule for it.
*)

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc( Suc(n)))"
thm ev.cases (* ev ?a \<Longrightarrow> (?a = 0 \<Longrightarrow> ?P) \<Longrightarrow> (\<And>n. ?a = Suc (Suc n) \<Longrightarrow> ev n \<Longrightarrow> ?P) \<Longrightarrow> ?P *)

lemma
  shows "ev(Suc(Suc n)) \<Longrightarrow> ev n"
proof -
  assume assumption: "ev (Suc( Suc n))"
  from assumption show "ev n"
  proof (rule ev.cases) (* 1 *)
    show "Suc (Suc n) = 0 \<Longrightarrow> ev n"
    proof -
      assume "Suc (Suc n) = 0" (* 2 *)
      from this have "False" by simp (* 3 *)
      from `False` show "ev n" by simp (* 4 *)
    qed
    fix na (* 5 *)
    assume evSS_assumption: "Suc (Suc n) = Suc (Suc na)" "ev na" (* 5 *)
    have "na = n" using evSS_assumption by simp (* 6 *)
    show "ev na \<Longrightarrow> ev n" using `na = n` by simp (* 7 *)
  qed
qed

(*
The proof is by rue inversion (i.e. what rule/cases could we have applied to arrive at
ev(n+2)? Then show from those cases that arrived at ev(n+2) show ev n.
1) First step is rule inversion step (rule ev.cases) which introduces that n+2=0 arrives at the goal
ev n (via rule/case ev0) or via 2nd case/rule evSS, which introduces \<And>na. n+2 = na+2; ev na
Part1: ev0 case
2) Assume the rule inversion assumtion n+2=0 via rule ev0
3) Make explicit that this assumption is equal to False in natural numbers.
4) Conclude goal ev n from False.
Part2: evSS
5) Assume the evSS assumptions \<And>na. n+2 = na+2; ev na.
6) Simplify n+2 = n+2 to conclude na = n.
7) Using the assumption ev na from rule inversion and na=na, conclude goal ev n
*)

(*
Exercise 5.4.
Give a structured proof of
\<not> ev (Suc (Suc (Suc 0))) by rule inversions.
If there  are no cases to be proved you can close
a proof immediately with qed.
*)

thm ev.cases (* \<lbrakk>ev ?a; ?a = 0 \<Longrightarrow> ?P; \<And>n. \<lbrakk>?a = Suc (Suc n); ev n\<rbrakk> \<Longrightarrow> ?P\<rbrakk> \<Longrightarrow> ?P *)

lemma
  shows "\<not> ev (Suc (Suc (Suc 0)))"
proof (rule notI) (* 1 *)
  assume "ev (Suc (Suc (Suc 0)))" (* 3 *)
  from this show "False"
  proof cases (* 3 *)
    (*  note first case is empty *) (* 4 *)
    case evSS (* 5 *)
    then show ?thesis using ev.cases by auto
  qed
qed

(*
Prove that we cannot get 3 being an even number.
1) Rule not Introduction i.e. change goal to ev 3 \<Longrightarrow> False
2) By contradiction, assume we did have the inductiv predicate ev 3
3) Rule inversion, what cases (ev0,evSS) could have arrived at assumption and then at the goal (False)?
4) First case is empty since it's impossible and Isabelle closes that proof obligation
5) We could have arrived using evSS rule which for this case simplifies as follow:
\<And>na. (0+1)+2=na+2; ev na thus na = 0+1 which leads to use ev (0+1) to prove False.
6) Now since no rules could have been used to arrive at goal (False) we invoke the rules
and auto to conclude it's impossible to have ev (1+0), which concludes proof.

*)

(* Exercise 5.5 *)
(* Notes:
iter r n x y = n-fold iteration of a relation r should hold if there are x0, ..., xn
such that x = x0, xn = y and r xi xi+1 for all i < n.

iter0: iter must be reflexive. i.e. there is a path of length 0 from x to y
and y is simply itself x.
iterSS: is inductively defined. If we already know there is a path of length n from y to z and we
simply include the extra step x\<rightarrow>y using r, then of course there is a path from x to z using r.
Simply use the old path from the inductively defined  iter r n y z the "old path" and then add the
new path x\<rightarrow>y using r. Thus there is a path of length n+1 (i.e. we can conclude the left most
predicate in the meta-implication chain.
*)
inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter0: "iter r 0 x x" |
iterSS: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"
(*
iterSS says there is a path with r of length n+1 inductively, if there is
a path of length n with r and we have an addition step with r.
path(r,x\<rightarrow>y) & path(r,y \<rightarrow>z,length=n) \<Rightarrow> path(r,x\<rightarrow>y,length=n+1)

*)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl: "star r x x"|
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
thm star.cases
thm star.induct

lemma "iter r n x y \<Longrightarrow> star r x y"
  apply (induction rule: iter.induct)
   apply (rule star.refl)
  by (simp add: star.step)

lemma (* Correct proof but prefer the other one I wrote *)
  shows "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case (iter0 x)
  then show ?case by (rule star.refl)
next
  case (iterSS x y n z)
  then show ?case by (meson star.step)
qed

lemma
  shows "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct) (* 1 *)
  (*   case (iter0 x) *)
  fix x' (* 2 *)
  show "star r x' x'" by (rule star.refl)
next
  (* case (iterSS x y n z) *)
  fix x' y' z' n' (* 4 *)
  assume iterSS_rxy_asm: "r x' y'" (* 5 *)
  assume iterSS_iter_asm: " iter r n' y' z'" (* 5 *) (* NOT needed, it's helpful as it introduces IH *)
  assume IH: "star r y' z'" (* 6 *) (* IH from iter r n y z *)
  show "star r x' z'" using `r x' y'` `star r y' z'` by (rule star.step)
qed

(*
Thm: We want to show that if the n-fold iteration from x to y using relation r holds then
the transitive closure for r from x to y also holds.

1) The proof is by induction. We could have arrived at iter r n x y
with either iter0 or iterSS. So break the assumption into those two cases and include the
induction hypothesis if any of them introduces it.
Part 1: iter0 base case
2) The first step Unified iter r n x y in the thm statement with the iter0 rule.
This identifies that the mapping of the variables in the thm should be the follow:
sigma = {x\<rightarrow>x'} and that's it, where x' is quantified for any x' (since the rule iter0
holds for any x x).
3) We get the 1st goal \<And>x. star r x x which is exactly the same as the rule reflexive for r*
and that closes the proof.
Part 2: iterSS: indutive step step
The idea for this proof is that we use r x' y' and the IH r* y' z' to conclude r* x' z'.
i.e. r x' y' + r* y' z' \<Longrightarrow> r* x' z' using the star step rule (which mathches that).
Note that the unification has the map sigma={x\<rightarrow>x',y\<rightarrow>y',z\<rightarrow>z',n\<rightarrow>n'} (usually the mapping
is a little more interesting if there are constructors e.g. mapping of variable goals
to variable from rule like this sigma={x\<rightarrow>C x1' x2' ... xn'} etc.
Note: goal is \<And>x y n z. r x y \<Longrightarrow> iter r n y z \<Longrightarrow> star r y z \<Longrightarrow> star r x z
since we removed iter n x z with the rule that could have arrived at it & IH r* y z.
4) Introduce the variables from the quanitifcation from the induction rule on iterSS
5) Introduce the assumptions from iterSS rule: r x y \<Longrightarrow> iter r n y z
6) Introduce the IH r* y z (introduced by iter r n y z).
7) use r x' y' (iterSS assumption) and r* y' z' (IH) to conclude goal r* y z using
r* step rule (which is exactly that r x y \<Rightarrow> r* y z \<Rightarrow> r* x z.
*)

(*
Exercise 5.6. Define a recursive function
elems :: ′a list \<Rightarrow> ′a set (gets the set of elements of the list) and
prove: x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys.
*)

fun elems :: "'a list \<Rightarrow> 'a set" where
" elems [] = {}" |
" elems (a # xs) = {a} \<union> elems xs"

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
  apply (induction xs)
   apply simp
  apply auto
   apply fastforce
  by (metis Un_iff append.simps(2) append_Nil elems.simps(1) elems.simps(2) empty_iff insert_iff)

thm list.induct (* \<lbrakk>?P []; \<And>x1 x2. ?P x2 \<Longrightarrow> ?P (x1 # x2)\<rbrakk> \<Longrightarrow> ?P ?list *)

lemma
  shows "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x#zs \<and> x \<notin> elems ys" (is "?A x xs \<Longrightarrow> ?P x xs")
proof (induction xs) (* 1 *)
  (* case Nil [] *)
  assume prems : "x \<in> elems []" (* 1 *)
  from prems have x_in_emptyset: "x \<in> {}" by (simp only: elems.simps(1)) (* 2 *)
  from x_in_emptyset have "False" by simp (* 2 *)
  from `False` show "\<exists>ys zs. [] = ys @ x # zs \<and> x \<notin> elems ys" by simp (* 3 *)
next
(*  case (Cons x' xs)  *)
  fix x' xs'
  assume IH: "x \<in> elems xs' \<Longrightarrow> \<exists>ys zs. xs' = ys @ x#zs \<and> x \<notin> elems ys" (* 4 *)
  assume Goal_Premise: "x \<in> elems (x'#xs')" (* 5 *)
  show "\<exists>ys zs. (x'#xs') = ys @ x#zs \<and> x \<notin> elems ys" using IH Goal_Premise (* 5 *)
  proof cases
    (*  this case yields: xs\<rightarrow>x'#xs'
        then ultimately we want: (x'#xs') = ys @ x#zs \<and> x \<notin> elems ys
   *)
    assume "x' = x" (* 5 *)
    (* since our goal ?P has existentials, we introduce them by exhibiting witness that work*)
    obtain ys where ys: "(ys :: 'a list) = []" by simp (* 7 *)
    obtain zs where zs: "zs = xs'" by simp (* 7 *)
    have first: "x'#xs'= ys @ x'#zs" using ys zs by simp (* 8 *)
    have second: "x' \<notin> elems ys" using ys by simp  (* 9 *)
    have thesis: "?P x (x'#xs')" using `x'=x` ys zs first second by blast (* 10 *)
    show "\<exists>ys zs. x'#xs' = ys@(x#zs) \<and> x \<notin> elems ys" using thesis by simp (* 10 *)
  next
    assume "x' \<noteq> x" (* 6 *)
    (* get ys' zs' that we need from the induction hypothesis *)
    have 0: "x \<in> elems xs'" using Goal_Premise `x' \<noteq> x` by simp (* 12 *)
    have 1: "\<exists> ys' zs'. xs'=ys'@(x#zs') \<and> x \<notin> elems ys'" using 0 IH by simp (* 12 *)
    obtain ys' zs' where 2: "xs'=ys'@(x#zs') \<and> x \<notin> elems ys'" using 1 by auto (* 12 *)
    have 3: "x \<notin> elems ys'" using 2 by simp
    (* obtain ys zs where x'#xs'=ys@x#zs where xs'=ys'@x#zs'*)
    let ?ys="x'#ys'" (* 11 *)
    let ?zs="zs'" (* 11 *)
    have 4: "x \<notin> elems ?ys" using  `x'\<noteq>x` 3 by simp (* 13 *)
    have 5: "x'#xs' = ?ys @(x#?zs)" using  `x'\<noteq>x` 2 by simp (* 14 *)
    show "\<exists>ys zs. x'#xs' = ys @(x#zs) \<and> x \<notin> elems ys" using 4 5 by blast
  qed
qed

(*
Recall:
elems xs = the set of elements of the list
WTS: x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys.
i.e. we want to show that if x is in the set of elements of list xs, then we can always split
the list into two parts ys zs s.t. we recover the original list via xs = ys @(x#zs) and
x is not in the first half of the list ys.
Proof:
1) Induction on the list xs. We get two cases [] and x#xs.
Part 1: [] Nil base case
2) In the Nil case we have [] \<equiv> {} so have x \<in> {}.
3) In that x \<in> {} is false whuch we can conclude anything (in particular the goal).
Part 2: Cons case x'#xs'
Introduce the assumptions:
4) Since we are doing induction, we can introduce the implication we are
trying to prove but for xs' from the cons case:
IH: P xs' \<equiv> x \<in> elems xs' \<Longrightarrow> \<exists>ys zs. xs' = ys @ x#zs \<and> x \<notin> elems ys
5) Notice how the goal we are trying to show has xs\<rightarrow>xs'#x from unification
of the goal term xs to the cons case xs'#x'.
So we are proving:
\<And>x' xs'. (x \<in> elems xs' \<Longrightarrow> \<exists>ys zs. xs' = ys @ x#zs \<and> x \<notin> elems ys) \<Longrightarrow> x \<in> elems (x'#xs') \<Longrightarrow> \<exists>ys zs. x'#xs' = ys @ x # zs \<and> x \<notin> elems ys
First term in brackets is the IH (which is an implication for xs') and the last is the new goal and it's assumption (using mapping xs\<rightarrow>xs'#x').

Notice what the ultimate goal is: x \<in> elems (x'#xs') \<Longrightarrow> \<exists>ys zs. x'#xs' = ys @ x # zs \<and> x \<notin> elems ys
The main idea is that the first split ys must NOT have the element. Thus there must be two cases:
5) when x is indeed the head and when it's 6) not the head.
Cases:

-1st: 7) When x is in the head (x=x') then we set the witnesses ys\<rightarrow>[] and zs\<rightarrow>xs, 8) and check
that when combined they return the original list xs. i.e. []@x'#xs is x#xs.
9) note that we have x \<notin> ys since x \<notin> [] is true.
10) With 9 and 8 we have that x is not in the ys list and the split returns the original list as required

-2nd: 11) When x is not in the head (x\<noteq>x') we set the first half of the target list ys
to be x'#ys' i.e. ys\<rightarrow>x'#ys' and the second half zs to be zs\<rightarrow>zs'.
12) But we obtained ys' and zs' from the induction hypothesis. Thus, ys' will
have the property we need x \<notin> ys' and zs' completes the list xs'
13) The witness ys is the important one because we want it such that x is NOT in it.
That is satisfied from construction of them by 12, since by induction ys' will have the property
we want (that x is not in ys') and also x\<noteq>x'.
14) We show that the construction for ?ys and ?zs indeed complete the original list since
x'#ys'@(x#zs') \<rightarrow> x'@xs' via 2 as required.
15) now that we have the two statements we need (that the original list is completed by 5 and
that x is not in the first half of the list ?ys 4) we concliude the proof.

(note ys\<equiv>?ys, zs\<equiv>?zs)
*)

(* Substitute for Ex 5.7 *)

(*
lemma
  shows "x \<in> \<real> \<and> x*x =2"
*)

end


section \<open>Tries via Functions\<close>

theory Trie_Fun
imports
  Set_Specs
begin

text \<open>A trie where each node maps a key to sub-tries via a function.
Nice abstract model. Not efficient because of the function space.\<close>

datatype 'a trie = Nd bool "'a \<Rightarrow> 'a trie option"

definition empty :: "'a trie" where
[simp]: "empty = Nd False (\<lambda>_. None)"

fun isin :: "'a trie \<Rightarrow> 'a list \<Rightarrow> bool" where
"isin (Nd b m) [] = b" |
"isin (Nd b m) (k # xs) = (case m k of None \<Rightarrow> False | Some t \<Rightarrow> isin t xs)"

fun insert :: "'a list \<Rightarrow> 'a trie \<Rightarrow> 'a trie" where
"insert [] (Nd b m) = Nd True m" |
"insert (x#xs) (Nd b m) =
   (let s = (case m x of None \<Rightarrow> empty | Some t \<Rightarrow> t) in Nd b (m(x := Some(insert xs s))))"

fun delete :: "'a list \<Rightarrow> 'a trie \<Rightarrow> 'a trie" where
"delete [] (Nd b m) = Nd False m" |
"delete (x#xs) (Nd b m) = Nd b
   (case m x of
      None \<Rightarrow> m |
      Some t \<Rightarrow> m(x := Some(delete xs t)))"

text \<open>Use (a tuned version of) @{const isin} as an abstraction function:\<close>

lemma isin_case: "isin (Nd b m) xs =
  (case xs of
   [] \<Rightarrow> b |
   x # ys \<Rightarrow> (case m x of None \<Rightarrow> False | Some t \<Rightarrow> isin t ys))"
by(cases xs)auto

definition set :: "'a trie \<Rightarrow> 'a list set" where
[simp]: "set t = {xs. isin t xs}"

lemma isin_set: "isin t xs = (xs \<in> set t)"
by simp

lemma set_insert: "set (insert xs t) = set t \<union> {xs}"
by (induction xs t rule: insert.induct)
   (auto simp: isin_case split!: if_splits option.splits list.splits)

lemma set_delete: "set (delete xs t) = set t - {xs}"
by (induction xs t rule: delete.induct)
   (auto simp: isin_case split!: if_splits option.splits list.splits)

interpretation S: Set
where empty = empty and isin = isin and insert = insert and delete = delete
and set = set and invar = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by (simp add: isin_case split: list.split)
next
  case 2 show ?case by(rule isin_set)
next
  case 3 show ?case by(rule set_insert)
next
  case 4 show ?case by(rule set_delete)
qed (rule TrueI)+

end


(* Title:      Filters
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Filters\<close>

text \<open>
This theory develops filters based on orders, semilattices, lattices and distributive lattices.
We prove the ultrafilter lemma for orders with a least element.
We show the following structure theorems:
\begin{itemize}
\item The set of filters over a directed semilattice forms a lattice with a greatest element.
\item The set of filters over a bounded semilattice forms a bounded lattice.
\item The set of filters over a distributive lattice with a greatest element forms a bounded distributive lattice.
\end{itemize}
Another result is that in a distributive lattice ultrafilters are prime filters.
We also prove a lemma of Gr\"atzer and Schmidt about principal filters.

We apply these results in proving the construction theorem for Stone algebras (described in a separate theory).
See, for example, \cite{BalbesDwinger1974,Birkhoff1967,Blyth2005,DaveyPriestley2002,Graetzer1971} for further results about filters.
\<close>

theory Filters

imports Lattice_Basics

begin

subsection \<open>Orders\<close>

text \<open>
This section gives the basic definitions related to filters in terms of orders.
The main result is the ultrafilter lemma.
\<close>

context ord
begin

abbreviation down :: "'a \<Rightarrow> 'a set" ("\<down>_" [81] 80)
  where "\<down>x \<equiv> { y . y \<le> x }"

abbreviation down_set :: "'a set \<Rightarrow> 'a set" ("\<Down>_" [81] 80)
  where "\<Down>X \<equiv> { y . \<exists>x\<in>X . y \<le> x }"

abbreviation is_down_set :: "'a set \<Rightarrow> bool"
  where "is_down_set X \<equiv> \<forall>x\<in>X . \<forall>y . y \<le> x \<longrightarrow> y\<in>X"

abbreviation is_principal_down :: "'a set \<Rightarrow> bool"
  where "is_principal_down X \<equiv> \<exists>x . X = \<down>x"

abbreviation up :: "'a \<Rightarrow> 'a set" ("\<up>_" [81] 80)
  where "\<up>x \<equiv> { y . x \<le> y }"

abbreviation up_set :: "'a set \<Rightarrow> 'a set" ("\<Up>_" [81] 80)
  where "\<Up>X \<equiv> { y . \<exists>x\<in>X . x \<le> y }"

abbreviation is_up_set :: "'a set \<Rightarrow> bool"
  where "is_up_set X \<equiv> \<forall>x\<in>X . \<forall>y . x \<le> y \<longrightarrow> y\<in>X"

abbreviation is_principal_up :: "'a set \<Rightarrow> bool"
  where "is_principal_up X \<equiv> \<exists>x . X = \<up>x"

text \<open>
A filter is a non-empty, downward directed, up-closed set.
\<close>

definition filter :: "'a set \<Rightarrow> bool"
  where "filter F \<equiv> (F \<noteq> {}) \<and> (\<forall>x\<in>F . \<forall>y\<in>F . \<exists>z\<in>F . z \<le> x \<and> z \<le> y) \<and> is_up_set F"

abbreviation proper_filter :: "'a set \<Rightarrow> bool"
  where "proper_filter F \<equiv> filter F \<and> F \<noteq> UNIV"

abbreviation ultra_filter :: "'a set \<Rightarrow> bool"
  where "ultra_filter F \<equiv> proper_filter F \<and> (\<forall>G . proper_filter G \<and> F \<subseteq> G \<longrightarrow> F = G)"

abbreviation filters :: "'a set set"
  where "filters \<equiv> { F::'a set . filter F }"

lemma filter_map_filter:
  assumes "filter F"
      and "mono f"
      and "\<forall>x y . f x \<le> y \<longrightarrow> (\<exists>z . x \<le> z \<and> y = f z)"
    shows "filter (f ` F)"
proof (unfold ord_class.filter_def, intro conjI)
  show "f ` F \<noteq> {}"
    using assms(1) ord_class.filter_def by auto
next
  show "\<forall>x\<in>f ` F . \<forall>y\<in>f ` F . \<exists>z\<in>f ` F . z \<le> x \<and> z \<le> y"
  proof (intro ballI)
    fix x y
    assume "x \<in> f ` F" and "y \<in> f ` F"
    then obtain u v where 1: "x = f u \<and> u \<in> F \<and> y = f v \<and> v \<in> F"
      by auto
    then obtain w where "w \<le> u \<and> w \<le> v \<and> w \<in> F"
      by (meson assms(1) ord_class.filter_def)
    thus "\<exists>z\<in>f ` F . z \<le> x \<and> z \<le> y"
      using 1 assms(2) mono_def image_eqI by blast
  qed
next
  show "is_up_set (f ` F)"
  proof
    fix x
    assume "x \<in> f ` F"
    then obtain u where 1: "x = f u \<and> u \<in> F"
      by auto
    show "\<forall>y . x \<le> y \<longrightarrow> y \<in> f ` F"
    proof (rule allI, rule impI)
      fix y
      assume "x \<le> y"
      hence "f u \<le> y"
        using 1 by simp
      then obtain z where "u \<le> z \<and> y = f z"
        using assms(3) by auto
      thus "y \<in> f ` F"
        by (meson 1 assms(1) image_iff ord_class.filter_def)
    qed
  qed
qed

end

context order
begin

lemma self_in_downset [simp]:
  "x \<in> \<down>x"
  by simp

lemma self_in_upset [simp]:
  "x \<in> \<up>x"
  by simp

lemma up_filter [simp]:
  "filter (\<up>x)"
  using filter_def order_lesseq_imp by auto

lemma up_set_up_set [simp]:
  "is_up_set (\<Up>X)"
  using order.trans by fastforce

lemma up_injective:
  "\<up>x = \<up>y \<Longrightarrow> x = y"
  using antisym by auto

lemma up_antitone:
  "x \<le> y \<longleftrightarrow> \<up>y \<subseteq> \<up>x"
  by auto

end

context order_bot
begin

lemma bot_in_downset [simp]:
  "bot \<in> \<down>x"
  by simp

lemma down_bot [simp]:
  "\<down>bot = {bot}"
  by (simp add: bot_unique)

lemma up_bot [simp]:
  "\<up>bot = UNIV"
  by simp

text \<open>
The following result is the ultrafilter lemma, generalised from \cite[10.17]{DaveyPriestley2002} to orders with a least element.
Its proof uses Isabelle/HOL's \<open>Zorn_Lemma\<close>, which requires closure under union of arbitrary (possibly empty) chains.
Actually, the proof does not use any of the underlying order properties except \<open>bot_least\<close>.
\<close>

lemma ultra_filter:
  assumes "proper_filter F"
    shows "\<exists>G . ultra_filter G \<and> F \<subseteq> G"
proof -
  let ?A = "{ G . (proper_filter G \<and> F \<subseteq> G) \<or> G = {} }"
  have "\<forall>C \<in> chains ?A . \<Union>C \<in> ?A"
  proof
    fix C :: "'a set set"
    let ?D = "C - {{}}"
    assume 1: "C \<in> chains ?A"
    hence 2: "\<forall>x\<in>\<Union>?D . \<exists>H\<in>?D . x \<in> H \<and> proper_filter H"
      using chainsD2 by fastforce
    have 3: "\<Union>?D = \<Union>C"
      by blast
    have "\<Union>?D \<in> ?A"
    proof (cases "?D = {}")
      assume "?D = {}"
      thus ?thesis
        by auto
    next
      assume 4: "?D \<noteq> {}"
      then obtain G where "G \<in> ?D"
        by auto
      hence 5: "F \<subseteq> \<Union>?D"
        using 1 chainsD2 by blast
      have 6: "is_up_set (\<Union>?D)"
      proof
        fix x
        assume "x \<in> \<Union>?D"
        then obtain H where "x \<in> H \<and> H \<in> ?D \<and> filter H"
          using 2 by auto
        thus "\<forall>y . x \<le> y \<longrightarrow> y\<in>\<Union>?D"
          using filter_def UnionI by fastforce
      qed
      have 7: "\<Union>?D \<noteq> UNIV"
      proof (rule ccontr)
        assume "\<not> \<Union>?D \<noteq> UNIV"
        then obtain H where "bot \<in> H \<and> proper_filter H"
          using 2 by blast
        thus False
          by (meson UNIV_I bot_least filter_def subsetI subset_antisym)
      qed
      {
        fix x y
        assume "x\<in>\<Union>?D \<and> y\<in>\<Union>?D"
        then obtain H I where 8: "x \<in> H \<and> H \<in> ?D \<and> filter H \<and> y \<in> I \<and> I \<in> ?D \<and> filter I"
          using 2 by metis
        have "\<exists>z\<in>\<Union>?D . z \<le> x \<and> z \<le> y"
        proof (cases "H \<subseteq> I")
          assume "H \<subseteq> I"
          hence "\<exists>z\<in>I . z \<le> x \<and> z \<le> y"
            using 8 by (metis subsetCE filter_def)
          thus ?thesis
            using 8 by (metis UnionI)
        next
          assume "\<not> (H \<subseteq> I)"
          hence "I \<subseteq> H"
            using 1 8 by (meson DiffE chainsD)
          hence "\<exists>z\<in>H . z \<le> x \<and> z \<le> y"
            using 8 by (metis subsetCE filter_def)
          thus ?thesis
            using 8 by (metis UnionI)
        qed
      }
      thus ?thesis
        using 4 5 6 7 filter_def by auto
    qed
    thus "\<Union>C \<in> ?A"
      using 3 by simp
  qed
  hence "\<exists>M\<in>?A . \<forall>X\<in>?A . M \<subseteq> X \<longrightarrow> X = M"
    by (rule Zorn_Lemma)
  then obtain M where 9: "M \<in> ?A \<and> (\<forall>X\<in>?A . M \<subseteq> X \<longrightarrow> X = M)"
    by auto
  hence 10: "M \<noteq> {}"
    using assms filter_def by auto
  {
    fix G
    assume 11: "proper_filter G \<and> M \<subseteq> G"
    hence "F \<subseteq> G"
      using 9 10 by blast
    hence "M = G"
      using 9 11 by auto
  }
  thus ?thesis
    using 9 10 by blast
qed

end

context order_top
begin

lemma down_top [simp]:
  "\<down>top = UNIV"
  by simp

lemma top_in_upset [simp]:
  "top \<in> \<up>x"
  by simp

lemma up_top [simp]:
  "\<up>top = {top}"
  by (simp add: top_unique)

lemma filter_top [simp]:
  "filter {top}"
  using filter_def top_unique by auto

lemma top_in_filter [simp]:
  "filter F \<Longrightarrow> top \<in> F"
  using filter_def by fastforce

end

text \<open>
The existence of proper filters and ultrafilters requires that the underlying order contains at least two elements.
\<close>

context non_trivial_order
begin

lemma proper_filter_exists:
  "\<exists>F . proper_filter F"
proof -
  from consistent obtain x y :: 'a where "x \<noteq> y"
    by auto
  hence "\<up>x \<noteq> UNIV \<or> \<up>y \<noteq> UNIV"
    using antisym by blast
  hence "proper_filter (\<up>x) \<or> proper_filter (\<up>y)"
    by simp
  thus ?thesis
    by blast
qed

end

context non_trivial_order_bot
begin

lemma ultra_filter_exists:
  "\<exists>F . ultra_filter F"
  using ultra_filter proper_filter_exists by blast

end

context non_trivial_bounded_order
begin

lemma proper_filter_top:
  "proper_filter {top}"
  using bot_not_top filter_top by blast

lemma ultra_filter_top:
  "\<exists>G . ultra_filter G \<and> top \<in> G"
  using ultra_filter proper_filter_top by fastforce

end

subsection \<open>Lattices\<close>

text \<open>
This section develops the lattice structure of filters based on a semilattice structure of the underlying order.
The main results are that filters over a directed semilattice form a lattice with a greatest element and that filters over a bounded semilattice form a bounded lattice.
\<close>

context semilattice_sup
begin

abbreviation prime_filter :: "'a set \<Rightarrow> bool"
  where "prime_filter F \<equiv> proper_filter F \<and> (\<forall>x y . x \<squnion> y \<in> F \<longrightarrow> x \<in> F \<or> y \<in> F)"

end

context semilattice_inf
begin

lemma filter_inf_closed:
  "filter F \<Longrightarrow> x \<in> F \<Longrightarrow> y \<in> F \<Longrightarrow> x \<sqinter> y \<in> F"
  by (meson filter_def inf.boundedI)

lemma filter_univ:
  "filter UNIV"
  by (meson UNIV_I UNIV_not_empty filter_def inf.cobounded1 inf.cobounded2)

text \<open>
The operation \<open>filter_sup\<close> is the join operation in the lattice of filters.
\<close>

definition "filter_sup F G \<equiv> { z . \<exists>x\<in>F . \<exists>y\<in>G . x \<sqinter> y \<le> z }"

lemma filter_sup:
  assumes "filter F"
      and "filter G"
    shows "filter (filter_sup F G)"
proof -
  have "F \<noteq> {} \<and> G \<noteq> {}"
    using assms filter_def by blast
  hence 1: "filter_sup F G \<noteq> {}"
    using filter_sup_def by blast
  have 2: "\<forall>x\<in>filter_sup F G . \<forall>y\<in>filter_sup F G . \<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
  proof
    fix x
    assume "x\<in>filter_sup F G"
    then obtain t u where 3: "t \<in> F \<and> u \<in> G \<and> t \<sqinter> u \<le> x"
      using filter_sup_def by auto
    show "\<forall>y\<in>filter_sup F G . \<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
    proof
      fix y
      assume "y\<in>filter_sup F G"
      then obtain v w where 4: "v \<in> F \<and> w \<in> G \<and> v \<sqinter> w \<le> y"
        using filter_sup_def by auto
      let ?z = "(t \<sqinter> v) \<sqinter> (u \<sqinter> w)"
      have 5: "?z \<le> x \<and> ?z \<le> y"
        using 3 4 by (meson order.trans inf.cobounded1 inf.cobounded2 inf_mono)
      have "?z \<in> filter_sup F G"
        unfolding filter_sup_def using assms 3 4 filter_inf_closed by blast
      thus "\<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
        using 5 by blast
    qed
  qed
  have "\<forall>x\<in>filter_sup F G . \<forall>y . x \<le> y \<longrightarrow> y \<in> filter_sup F G"
    unfolding filter_sup_def using order_trans by blast
  thus ?thesis
    using 1 2 filter_def by presburger
qed

lemma filter_sup_left_upper_bound:
  assumes "filter G"
    shows "F \<subseteq> filter_sup F G"
proof -
  from assms obtain y where "y\<in>G"
    using all_not_in_conv filter_def by auto
  thus ?thesis
    unfolding filter_sup_def using inf.cobounded1 by blast
qed

lemma filter_sup_symmetric:
  "filter_sup F G = filter_sup G F"
  unfolding filter_sup_def using inf.commute by fastforce

lemma filter_sup_right_upper_bound:
  "filter F \<Longrightarrow> G \<subseteq> filter_sup F G"
  using filter_sup_symmetric filter_sup_left_upper_bound by simp

lemma filter_sup_least_upper_bound:
  assumes "filter H"
      and "F \<subseteq> H"
      and "G \<subseteq> H"
    shows "filter_sup F G \<subseteq> H"
proof
  fix x
  assume "x \<in> filter_sup F G"
  then obtain y z where 1: "y \<in> F \<and> z \<in> G \<and> y \<sqinter> z \<le> x"
    using filter_sup_def by auto
  hence "y \<in> H \<and> z \<in> H"
    using assms(2-3) by auto
  hence "y \<sqinter> z \<in> H"
    by (simp add: assms(1) filter_inf_closed)
  thus "x \<in> H"
    using 1 assms(1) filter_def by auto
qed

lemma filter_sup_left_isotone:
  "G \<subseteq> H \<Longrightarrow> filter_sup G F \<subseteq> filter_sup H F"
  unfolding filter_sup_def by blast

lemma filter_sup_right_isotone:
  "G \<subseteq> H \<Longrightarrow> filter_sup F G \<subseteq> filter_sup F H"
  unfolding filter_sup_def by blast

lemma filter_sup_right_isotone_var:
  "filter_sup F (G \<inter> H) \<subseteq> filter_sup F H"
  unfolding filter_sup_def by blast

lemma up_dist_inf:
  "\<up>(x \<sqinter> y) = filter_sup (\<up>x) (\<up>y)"
proof
  show "\<up>(x \<sqinter> y) \<subseteq> filter_sup (\<up>x) (\<up>y)"
    unfolding filter_sup_def by blast
next
  show "filter_sup (\<up>x) (\<up>y) \<subseteq> \<up>(x \<sqinter> y)"
  proof
    fix z
    assume "z \<in> filter_sup (\<up>x) (\<up>y)"
    then obtain u v where "u\<in>\<up>x \<and> v\<in>\<up>y \<and> u \<sqinter> v \<le> z"
      using filter_sup_def by auto
    hence "x \<sqinter> y \<le> z"
      using order.trans inf_mono by blast
    thus "z \<in> \<up>(x \<sqinter> y)"
      by blast
  qed
qed

text \<open>
The following result is part of \cite[Exercise 2.23]{DaveyPriestley2002}.
\<close>

lemma filter_inf_filter [simp]:
  assumes "filter F"
    shows "filter (\<Up>{ y . \<exists>z\<in>F . x \<sqinter> z = y})"
proof -
  let ?G = "\<Up>{ y . \<exists>z\<in>F . x \<sqinter> z = y}"
  have "F \<noteq> {}"
    using assms filter_def by simp
  hence 1: "?G \<noteq> {}"
    by blast
  have 2: "is_up_set ?G"
    by auto
  {
    fix y z
    assume "y \<in> ?G \<and> z \<in> ?G"
    then obtain v w where "v \<in> F \<and> w \<in> F \<and> x \<sqinter> v \<le> y \<and> x \<sqinter> w \<le> z"
      by auto
    hence "v \<sqinter> w \<in> F \<and> x \<sqinter> (v \<sqinter> w) \<le> y \<sqinter> z"
      by (meson assms filter_inf_closed order.trans inf.boundedI inf.cobounded1 inf.cobounded2)
    hence "\<exists>u\<in>?G . u \<le> y \<and> u \<le> z"
      by auto
  }
  hence "\<forall>x\<in>?G . \<forall>y\<in>?G . \<exists>z\<in>?G . z \<le> x \<and> z \<le> y"
    by auto
  thus ?thesis
    using 1 2 filter_def by presburger
qed

end

context directed_semilattice_inf
begin

text \<open>
Set intersection is the meet operation in the lattice of filters.
\<close>

lemma filter_inf:
  assumes "filter F"
      and "filter G"
    shows "filter (F \<inter> G)"
proof (unfold filter_def, intro conjI)
  from assms obtain x y where 1: "x\<in>F \<and> y\<in>G"
    using all_not_in_conv filter_def by auto
  from ub obtain z where "x \<le> z \<and> y \<le> z"
    by auto
  hence "z \<in> F \<inter> G"
    using 1 by (meson assms Int_iff filter_def)
  thus "F \<inter> G \<noteq> {}"
    by blast
next
  show "is_up_set (F \<inter> G)"
    by (meson assms Int_iff filter_def)
next
  show "\<forall>x\<in>F \<inter> G . \<forall>y\<in>F \<inter> G . \<exists>z\<in>F \<inter> G . z \<le> x \<and> z \<le> y"
    by (metis assms Int_iff filter_inf_closed inf.cobounded2 inf.commute)
qed

end

text \<open>
We introduce the following type of filters to instantiate the lattice classes and thereby inherit the results shown about lattices.
\<close>

typedef (overloaded) 'a filter = "{ F::'a::order set . filter F }"
  by (meson mem_Collect_eq up_filter)

lemma simp_filter [simp]:
  "filter (Rep_filter x)"
  using Rep_filter by simp

setup_lifting type_definition_filter

text \<open>
The set of filters over a directed semilattice forms a lattice with a greatest element.
\<close>

instantiation filter :: (directed_semilattice_inf) bounded_lattice_top
begin

lift_definition top_filter :: "'a filter" is UNIV
  by (simp add: filter_univ)

lift_definition sup_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> 'a filter" is filter_sup
  by (simp add: filter_sup)

lift_definition inf_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> 'a filter" is inter
  by (simp add: filter_inf)

lift_definition less_eq_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> bool" is subset_eq .

lift_definition less_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> bool" is subset .

instance
  apply intro_classes
  subgoal apply transfer by (simp add: less_le_not_le)
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by (simp add: filter_sup_left_upper_bound)
  subgoal apply transfer by (simp add: filter_sup_right_upper_bound)
  subgoal apply transfer by (simp add: filter_sup_least_upper_bound)
  subgoal apply transfer by simp
  done

end

context bounded_semilattice_inf_top
begin

abbreviation "filter_complements F G \<equiv> filter F \<and> filter G \<and> filter_sup F G = UNIV \<and> F \<inter> G = {top}"

end

text \<open>
The set of filters over a bounded semilattice forms a bounded lattice.
\<close>

instantiation filter :: (bounded_semilattice_inf_top) bounded_lattice
begin

lift_definition bot_filter :: "'a filter" is "{top}"
  by simp

instance
  apply intro_classes
  apply transfer
  by simp

end

context lattice
begin

lemma up_dist_sup:
  "\<up>(x \<squnion> y) = \<up>x \<inter> \<up>y"
  by auto

end

text \<open>
For convenience, the following function injects principal filters into the filter type.
We cannot define it in the \<open>order\<close> class since the type filter requires the sort constraint \<open>order\<close> that is not available in the class.
The result of the function is a filter by lemma \<open>up_filter\<close>.
\<close>

abbreviation up_filter :: "'a::order \<Rightarrow> 'a filter"
  where "up_filter x \<equiv> Abs_filter (\<up>x)"

lemma up_filter_dist_inf:
  "up_filter ((x::'a::lattice) \<sqinter> y) = up_filter x \<squnion> up_filter y"
  by (simp add: eq_onp_def sup_filter.abs_eq up_dist_inf)

lemma up_filter_dist_sup:
  "up_filter ((x::'a::lattice) \<squnion> y) = up_filter x \<sqinter> up_filter y"
  by (metis eq_onp_def inf_filter.abs_eq up_dist_sup up_filter)

lemma up_filter_injective:
  "up_filter x = up_filter y \<Longrightarrow> x = y"
  by (metis Abs_filter_inject mem_Collect_eq up_filter up_injective)

lemma up_filter_antitone:
  "x \<le> y \<longleftrightarrow> up_filter y \<le> up_filter x"
  by (metis eq_onp_same_args less_eq_filter.abs_eq up_antitone up_filter)

text \<open>
The following definition applies a function to each element of a filter.
The subsequent lemma gives conditions under which the result of this application is a filter.
\<close>

abbreviation filter_map :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> 'a filter \<Rightarrow> 'b filter"
  where "filter_map f F \<equiv> Abs_filter (f ` Rep_filter F)"

lemma filter_map_filter:
  assumes "mono f"
      and "\<forall>x y . f x \<le> y \<longrightarrow> (\<exists>z . x \<le> z \<and> y = f z)"
    shows "filter (f ` Rep_filter F)"
  by (simp add: assms inf.filter_map_filter)

subsection \<open>Distributive Lattices\<close>

text \<open>
In this section we additionally assume that the underlying order forms a distributive lattice.
Then filters form a bounded distributive lattice if the underlying order has a greatest element.
Moreover ultrafilters are prime filters.
We also prove a lemma of Gr\"atzer and Schmidt about principal filters.
\<close>

context distrib_lattice
begin

lemma filter_sup_left_dist_inf:
  assumes "filter F"
      and "filter G"
      and "filter H"
    shows "filter_sup F (G \<inter> H) = filter_sup F G \<inter> filter_sup F H"
proof
  show "filter_sup F (G \<inter> H) \<subseteq> filter_sup F G \<inter> filter_sup F H"
    unfolding filter_sup_def using filter_sup_right_isotone_var by blast
next
  show "filter_sup F G \<inter> filter_sup F H \<subseteq> filter_sup F (G \<inter> H)"
  proof
    fix x
    assume "x \<in> filter_sup F G \<inter> filter_sup F H"
    then obtain t u v w where 1: "t \<in> F \<and> u \<in> G \<and> v \<in> F \<and> w \<in> H \<and> t \<sqinter> u \<le> x \<and> v \<sqinter> w \<le> x"
      using filter_sup_def by auto
    let ?y = "t \<sqinter> v"
    let ?z = "u \<squnion> w"
    have 2: "?y \<in> F"
      using 1 by (simp add: assms(1) filter_inf_closed)
    have 3: "?z \<in> G \<inter> H"
      using 1 by (meson assms(2-3) Int_iff filter_def sup_ge1 sup_ge2)
    have "?y \<sqinter> ?z = (t \<sqinter> v \<sqinter> u) \<squnion> (t \<sqinter> v \<sqinter> w)"
      by (simp add: inf_sup_distrib1)
    also have "... \<le> (t \<sqinter> u) \<squnion> (v \<sqinter> w)"
      by (metis inf.cobounded1 inf.cobounded2 inf.left_idem inf_mono sup.mono)
    also have "... \<le> x"
      using 1 by (simp add: le_supI)
    finally show "x \<in> filter_sup F (G \<inter> H)"
      unfolding filter_sup_def using 2 3 by blast
  qed
qed

lemma filter_inf_principal_rep:
  "F \<inter> G = \<up>z \<Longrightarrow> (\<exists>x\<in>F . \<exists>y\<in>G . z = x \<squnion> y)"
  by force

lemma filter_sup_principal_rep:
  assumes "filter F"
      and "filter G"
      and "filter_sup F G = \<up>z"
    shows "\<exists>x\<in>F . \<exists>y\<in>G . z = x \<sqinter> y"
proof -
  from assms(3) obtain x y where 1: "x\<in>F \<and> y\<in>G \<and> x \<sqinter> y \<le> z"
    unfolding filter_sup_def using order_refl by blast
  hence 2: "x \<squnion> z \<in> F \<and> y \<squnion> z \<in> G"
    by (meson assms(1-2) sup_ge1 filter_def)
  have "(x \<squnion> z) \<sqinter> (y \<squnion> z) = z"
    using 1 sup_absorb2 sup_inf_distrib2 by fastforce
  thus ?thesis
    using 2 by force
qed

lemma inf_sup_principal_aux:
  assumes "filter F"
      and "filter G"
      and "is_principal_up (filter_sup F G)"
      and "is_principal_up (F \<inter> G)"
    shows "is_principal_up F"
proof -
  from assms(3-4) obtain x y where 1: "filter_sup F G = \<up>x \<and> F \<inter> G = \<up>y"
    by blast
  from filter_inf_principal_rep obtain t u where 2: "t\<in>F \<and> u\<in>G \<and> y = t \<squnion> u"
    using 1 by meson
  from filter_sup_principal_rep obtain v w where 3: "v\<in>F \<and> w\<in>G \<and> x = v \<sqinter> w"
    using 1 by (meson assms(1-2))
  have "t \<in> filter_sup F G \<and> u \<in> filter_sup F G"
    unfolding filter_sup_def using 2 inf.cobounded1 inf.cobounded2 by blast
  hence "x \<le> t \<and> x \<le> u"
    using 1 by blast
  hence 4: "(t \<sqinter> v) \<sqinter> (u \<sqinter> w) = x"
    using 3 by (simp add: inf.absorb2 inf.assoc inf.left_commute)
  have "(t \<sqinter> v) \<squnion> (u \<sqinter> w) \<in> F \<and> (t \<sqinter> v) \<squnion> (u \<sqinter> w) \<in> G"
    using 2 3 by (metis (no_types, lifting) assms(1-2) filter_inf_closed sup.cobounded1 sup.cobounded2 filter_def)
  hence "y \<le> (t \<sqinter> v) \<squnion> (u \<sqinter> w)"
    using 1 Int_iff by blast
  hence 5: "(t \<sqinter> v) \<squnion> (u \<sqinter> w) = y"
    using 2 by (simp add: antisym inf.coboundedI1)
  have "F = \<up>(t \<sqinter> v)"
  proof
    show "F \<subseteq> \<up>(t \<sqinter> v)"
    proof
      fix z
      assume 6: "z \<in> F"
      hence "z \<in> filter_sup F G"
        unfolding filter_sup_def using 2 inf.cobounded1 by blast
      hence "x \<le> z"
        using 1 by simp
      hence 7: "(t \<sqinter> v \<sqinter> z) \<sqinter> (u \<sqinter> w) = x"
        using 4 by (metis inf.absorb1 inf.assoc inf.commute)
      have "z \<squnion> u \<in> F \<and> z \<squnion> u \<in> G \<and> z \<squnion> w \<in> F \<and> z \<squnion> w \<in> G"
        using 2 3 6 by (meson assms(1-2) filter_def sup_ge1 sup_ge2)
      hence "y \<le> (z \<squnion> u) \<sqinter> (z \<squnion> w)"
        using 1 Int_iff filter_inf_closed by auto
      hence 8: "(t \<sqinter> v \<sqinter> z) \<squnion> (u \<sqinter> w) = y"
        using 5 by (metis inf.absorb1 sup.commute sup_inf_distrib2)
      have "t \<sqinter> v \<sqinter> z = t \<sqinter> v"
        using 4 5 7 8 relative_equality by blast
      thus "z \<in> \<up>(t \<sqinter> v)"
        by (simp add: inf.orderI)
    qed
  next
    show "\<up>(t \<sqinter> v) \<subseteq> F"
    proof
      fix z
      have 9: "t \<sqinter> v \<in> F"
        using 2 3 by (simp add: assms(1) filter_inf_closed)
      assume "z \<in> \<up>(t \<sqinter> v)"
      hence "t \<sqinter> v \<le> z" by simp
      thus "z \<in> F"
        using assms(1) 9 filter_def by auto
    qed
  qed
  thus ?thesis
    by blast
qed

text \<open>
The following result is \cite[Lemma II]{GraetzerSchmidt1958}.
If both join and meet of two filters are principal filters, both filters are principal filters.
\<close>

lemma inf_sup_principal:
  assumes "filter F"
      and "filter G"
      and "is_principal_up (filter_sup F G)"
      and "is_principal_up (F \<inter> G)"
    shows "is_principal_up F \<and> is_principal_up G"
proof -
  have "filter G \<and> filter F \<and> is_principal_up (filter_sup G F) \<and> is_principal_up (G \<inter> F)"
    by (simp add: assms Int_commute filter_sup_symmetric)
  thus ?thesis
    using assms(3) inf_sup_principal_aux by blast
qed

lemma filter_sup_absorb_inf: "filter F \<Longrightarrow> filter G \<Longrightarrow> filter_sup (F \<inter> G) G = G"
  by (simp add: filter_inf filter_sup_least_upper_bound filter_sup_left_upper_bound filter_sup_symmetric subset_antisym)

lemma filter_inf_absorb_sup: "filter F \<Longrightarrow> filter G \<Longrightarrow> filter_sup F G \<inter> G = G"
  apply (rule subset_antisym)
  apply simp
  by (simp add: filter_sup_right_upper_bound)

lemma filter_inf_right_dist_sup:
  assumes "filter F"
      and "filter G"
      and "filter H"
    shows "filter_sup F G \<inter> H = filter_sup (F \<inter> H) (G \<inter> H)"
proof -
  have "filter_sup (F \<inter> H) (G \<inter> H) = filter_sup (F \<inter> H) G \<inter> filter_sup (F \<inter> H) H"
    by (simp add: assms filter_sup_left_dist_inf filter_inf)
  also have "... = filter_sup (F \<inter> H) G \<inter> H"
    using assms(1,3) filter_sup_absorb_inf by simp
  also have "... = filter_sup F G \<inter> filter_sup G H \<inter> H"
    using assms filter_sup_left_dist_inf filter_sup_symmetric by simp
  also have "... = filter_sup F G \<inter> H"
    by (simp add: assms(2-3) filter_inf_absorb_sup semilattice_inf_class.inf_assoc)
  finally show ?thesis
    by simp
qed

text \<open>
The following result generalises \cite[10.11]{DaveyPriestley2002} to distributive lattices as remarked after that section.
\<close>

lemma ultra_filter_prime:
  assumes "ultra_filter F"
    shows "prime_filter F"
proof -
  {
    fix x y
    assume 1: "x \<squnion> y \<in> F \<and> x \<notin> F"
    let ?G = "\<Up>{ z . \<exists>w\<in>F . x \<sqinter> w = z }"
    have 2: "filter ?G"
      using assms filter_inf_filter by simp
    have "x \<in> ?G"
      using 1 by auto
    hence 3: "F \<noteq> ?G"
      using 1 by auto
    have "F \<subseteq> ?G"
      using inf_le2 order_trans by blast
    hence "?G = UNIV"
      using 2 3 assms by blast
    then obtain z where 4: "z \<in> F \<and> x \<sqinter> z \<le> y"
      by blast
    hence "y \<sqinter> z = (x \<squnion> y) \<sqinter> z"
      by (simp add: inf_sup_distrib2 sup_absorb2)
    also have "... \<in> F"
      using 1 4 assms filter_inf_closed by auto
    finally have "y \<in> F"
      using assms by (simp add: filter_def)
  }
  thus ?thesis
    using assms by blast
qed

lemma up_dist_inf_inter:
  assumes "is_up_set S"
    shows "\<up>(x \<sqinter> y) \<inter> S = filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
proof
  show "\<up>(x \<sqinter> y) \<inter> S \<subseteq> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
  proof
    fix z
    let ?x = "x \<squnion> z"
    let ?y = "y \<squnion> z"
    assume "z \<in> \<up>(x \<sqinter> y) \<inter> S"
    hence 1: "x \<sqinter> y \<le> z \<and> z \<in> S"
      by auto
    hence "?x \<in> (\<up>x \<inter> S) \<and> ?y \<in> (\<up>y \<inter> S) \<and> ?x \<sqinter> ?y \<le> z"
      using assms sup_absorb2 sup_inf_distrib2 by fastforce
    thus "z \<in> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
      using filter_sup_def 1 by fastforce
  qed
next
  show "filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S \<subseteq> \<up>(x \<sqinter> y) \<inter> S"
  proof
    fix z
    assume "z \<in> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
    then obtain u v where 2: "u\<in>\<up>x \<and> v\<in>\<up>y \<and> u \<sqinter> v \<le> z \<and> z \<in> S"
      using filter_sup_def by auto
    hence "x \<sqinter> y \<le> z"
      using order.trans inf_mono by blast
    thus "z \<in> \<up>(x \<sqinter> y) \<inter> S"
      using 2 by blast
  qed
qed

end

context distrib_lattice_bot
begin

lemma prime_filter:
  "proper_filter F \<Longrightarrow> \<exists>G . prime_filter G \<and> F \<subseteq> G"
  by (metis ultra_filter ultra_filter_prime)

end

context distrib_lattice_top
begin

lemma complemented_filter_inf_principal:
  assumes "filter_complements F G"
    shows "is_principal_up (F \<inter> \<up>x)"
proof -
  have 1: "filter F \<and> filter G"
    by (simp add: assms)
  hence 2: "filter (F \<inter> \<up>x) \<and> filter (G \<inter> \<up>x)"
    by (simp add: filter_inf)
  have "(F \<inter> \<up>x) \<inter> (G \<inter> \<up>x) = {top}"
    using assms Int_assoc Int_insert_left_if1 inf_bot_left inf_sup_aci(3) top_in_upset inf.idem by auto
  hence 3: "is_principal_up ((F \<inter> \<up>x) \<inter> (G \<inter> \<up>x))"
    using up_top by blast
  have "filter_sup (F \<inter> \<up>x) (G \<inter> \<up>x) = filter_sup F G \<inter> \<up>x"
    using 1 filter_inf_right_dist_sup up_filter by auto
  also have "... = \<up>x"
    by (simp add: assms)
  finally have "is_principal_up (filter_sup (F \<inter> \<up>x) (G \<inter> \<up>x))"
    by auto
  thus ?thesis
    using 1 2 3 inf_sup_principal_aux by blast
qed

end

text \<open>
The set of filters over a distributive lattice with a greatest element forms a bounded distributive lattice.
\<close>

instantiation filter :: (distrib_lattice_top) bounded_distrib_lattice
begin

instance
  apply intro_classes
  apply transfer
  by (simp add: filter_sup_left_dist_inf)

end

end