module Data.Interval.Borel (
  Borel,
  borel,
  intervalSet,
  Data.Interval.Borel.empty,
  singleton,
  Data.Interval.Borel.null,
  insert,
  whole,
  cutout,
  clip,
  member,
  notMember,
  union,
  unions,
  difference,
  symmetricDifference,
  complement,
  intersection,
  intersections,
  hull,
) where

import Algebra.Heyting
import Algebra.Lattice
import Data.Interval (Interval)
import Data.Interval qualified as I
import Data.OneOrTwo (OneOrTwo (..))
import Data.Semiring (Ring, Semiring)
import Data.Semiring qualified as Semiring
import Data.Set qualified as Set

-- | The 'Borel' sets on a type are the sets generated by its open intervals.
-- It forms a 'Heyting' algebra with 'union' as join and 'intersection' as meet,
-- and a 'Ring' with 'symmetricDifference' as addition and 'intersection' as
-- multiplication (and 'complement' as negation). In fact the algebra is Boolean
-- as the operation @x '==>' y = 'complement' x '\/' y@.
--
-- It is a monoid that is convenient for agglomerating
-- groups of intervals, such as for calculating the overall timespan
-- of a group of events. However, it is agnostic of
-- how many times each given point has been covered.
-- To keep track of this data, use 'Data.Interval.Layers'.
newtype Borel x = Borel (Set (Interval x))
  deriving (Borel x -> Borel x -> Bool
(Borel x -> Borel x -> Bool)
-> (Borel x -> Borel x -> Bool) -> Eq (Borel x)
forall x. Ord x => Borel x -> Borel x -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Borel x -> Borel x -> Bool
$c/= :: forall x. Ord x => Borel x -> Borel x -> Bool
== :: Borel x -> Borel x -> Bool
$c== :: forall x. Ord x => Borel x -> Borel x -> Bool
Eq, Eq (Borel x)
Eq (Borel x)
-> (Borel x -> Borel x -> Ordering)
-> (Borel x -> Borel x -> Bool)
-> (Borel x -> Borel x -> Bool)
-> (Borel x -> Borel x -> Bool)
-> (Borel x -> Borel x -> Bool)
-> (Borel x -> Borel x -> Borel x)
-> (Borel x -> Borel x -> Borel x)
-> Ord (Borel x)
Borel x -> Borel x -> Bool
Borel x -> Borel x -> Ordering
Borel x -> Borel x -> Borel x
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall x. Ord x => Eq (Borel x)
forall x. Ord x => Borel x -> Borel x -> Bool
forall x. Ord x => Borel x -> Borel x -> Ordering
forall x. Ord x => Borel x -> Borel x -> Borel x
min :: Borel x -> Borel x -> Borel x
$cmin :: forall x. Ord x => Borel x -> Borel x -> Borel x
max :: Borel x -> Borel x -> Borel x
$cmax :: forall x. Ord x => Borel x -> Borel x -> Borel x
>= :: Borel x -> Borel x -> Bool
$c>= :: forall x. Ord x => Borel x -> Borel x -> Bool
> :: Borel x -> Borel x -> Bool
$c> :: forall x. Ord x => Borel x -> Borel x -> Bool
<= :: Borel x -> Borel x -> Bool
$c<= :: forall x. Ord x => Borel x -> Borel x -> Bool
< :: Borel x -> Borel x -> Bool
$c< :: forall x. Ord x => Borel x -> Borel x -> Bool
compare :: Borel x -> Borel x -> Ordering
$ccompare :: forall x. Ord x => Borel x -> Borel x -> Ordering
$cp1Ord :: forall x. Ord x => Eq (Borel x)
Ord, Int -> Borel x -> ShowS
[Borel x] -> ShowS
Borel x -> String
(Int -> Borel x -> ShowS)
-> (Borel x -> String) -> ([Borel x] -> ShowS) -> Show (Borel x)
forall x. (Ord x, Show x) => Int -> Borel x -> ShowS
forall x. (Ord x, Show x) => [Borel x] -> ShowS
forall x. (Ord x, Show x) => Borel x -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Borel x] -> ShowS
$cshowList :: forall x. (Ord x, Show x) => [Borel x] -> ShowS
show :: Borel x -> String
$cshow :: forall x. (Ord x, Show x) => Borel x -> String
showsPrec :: Int -> Borel x -> ShowS
$cshowsPrec :: forall x. (Ord x, Show x) => Int -> Borel x -> ShowS
Show, (forall x. Borel x -> Rep (Borel x) x)
-> (forall x. Rep (Borel x) x -> Borel x) -> Generic (Borel x)
forall x. Rep (Borel x) x -> Borel x
forall x. Borel x -> Rep (Borel x) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall x x. Rep (Borel x) x -> Borel x
forall x x. Borel x -> Rep (Borel x) x
$cto :: forall x x. Rep (Borel x) x -> Borel x
$cfrom :: forall x x. Borel x -> Rep (Borel x) x
Generic, Typeable)

instance (Ord x) => One (Borel x) where
  type OneItem _ = Interval x
  one :: OneItem (Borel x) -> Borel x
one = OneItem (Borel x) -> Borel x
forall x. Ord x => Interval x -> Borel x
singleton

instance (Ord x) => Semigroup (Borel x) where
  Borel Set (Interval x)
is <> :: Borel x -> Borel x -> Borel x
<> Borel Set (Interval x)
js = Set (Interval x) -> Borel x
forall x. Set (Interval x) -> Borel x
Borel (Set (Interval x) -> Set (Interval x)
forall x. Ord x => Set (Interval x) -> Set (Interval x)
unionsSet (Set (Interval x)
is Set (Interval x) -> Set (Interval x) -> Set (Interval x)
forall a. Semigroup a => a -> a -> a
<> Set (Interval x)
js))

instance (Ord x) => Monoid (Borel x) where mempty :: Borel x
mempty = Set (Interval x) -> Borel x
forall x. Set (Interval x) -> Borel x
Borel Set (Interval x)
forall a. Monoid a => a
mempty

instance (Ord x, Lattice x) => Lattice (Borel x) where
  \/ :: Borel x -> Borel x -> Borel x
(\/) = Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
union
  /\ :: Borel x -> Borel x -> Borel x
(/\) = Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
intersection

instance (Ord x, Lattice x) => BoundedMeetSemiLattice (Borel x) where
  top :: Borel x
top = Borel x
forall x. Ord x => Borel x
whole

instance (Ord x, Lattice x) => BoundedJoinSemiLattice (Borel x) where
  bottom :: Borel x
bottom = Borel x
forall a. Monoid a => a
mempty

instance (Ord x, Lattice x) => Heyting (Borel x) where
  Borel x
x ==> :: Borel x -> Borel x -> Borel x
==> Borel x
y = Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x
complement Borel x
x Borel x -> Borel x -> Borel x
forall a. Lattice a => a -> a -> a
\/ Borel x
y

instance (Ord x, Lattice x) => Semiring (Borel x) where
  plus :: Borel x -> Borel x -> Borel x
plus = Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
symmetricDifference
  times :: Borel x -> Borel x -> Borel x
times = Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
intersection
  zero :: Borel x
zero = Borel x
forall a. Monoid a => a
mempty
  one :: Borel x
one = Borel x
forall x. Ord x => Borel x
whole

instance (Ord x, Lattice x) => Ring (Borel x) where
  negate :: Borel x -> Borel x
negate = Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x
complement

-- | Consider the 'Borel' set identified by a list of 'Interval's.
borel :: (Ord x) => [Interval x] -> Borel x
borel :: [Interval x] -> Borel x
borel = Set (Interval x) -> Borel x
forall x. Set (Interval x) -> Borel x
Borel (Set (Interval x) -> Borel x)
-> ([Interval x] -> Set (Interval x)) -> [Interval x] -> Borel x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Interval x] -> Set (Interval x)
forall a. Ord a => [a] -> Set a
Set.fromList ([Interval x] -> Set (Interval x))
-> ([Interval x] -> [Interval x])
-> [Interval x]
-> Set (Interval x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Interval x] -> [Interval x]
forall x. Ord x => [Interval x] -> [Interval x]
I.unions

-- | Turn a 'Borel' set into a 'Set.Set' of 'Interval's.
intervalSet :: (Ord x) => Borel x -> Set (Interval x)
intervalSet :: Borel x -> Set (Interval x)
intervalSet (Borel Set (Interval x)
is) = Set (Interval x) -> Set (Interval x)
forall x. Ord x => Set (Interval x) -> Set (Interval x)
unionsSet Set (Interval x)
is

unionsSet :: (Ord x) => Set (Interval x) -> Set (Interval x)
unionsSet :: Set (Interval x) -> Set (Interval x)
unionsSet = [Interval x] -> Set (Interval x)
forall a. Eq a => [a] -> Set a
Set.fromAscList ([Interval x] -> Set (Interval x))
-> (Set (Interval x) -> [Interval x])
-> Set (Interval x)
-> Set (Interval x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Interval x] -> [Interval x]
forall x. Ord x => [Interval x] -> [Interval x]
I.unionsAsc ([Interval x] -> [Interval x])
-> (Set (Interval x) -> [Interval x])
-> Set (Interval x)
-> [Interval x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Interval x) -> [Interval x]
forall a. Set a -> [a]
Set.toAscList

-- | The empty 'Borel' set.
empty :: (Ord x) => Borel x
empty :: Borel x
empty = Set (Interval x) -> Borel x
forall x. Set (Interval x) -> Borel x
Borel Set (Interval x)
forall a. Set a
Set.empty

-- | The 'Borel' set consisting of a single 'Interval'.
singleton :: (Ord x) => Interval x -> Borel x
singleton :: Interval x -> Borel x
singleton Interval x
x = Set (Interval x) -> Borel x
forall x. Set (Interval x) -> Borel x
Borel (Interval x -> Set (Interval x)
forall a. a -> Set a
Set.singleton Interval x
x)

-- | Is this 'Borel' set empty?
null :: Borel x -> Bool
null :: Borel x -> Bool
null (Borel Set (Interval x)
is) = Set (Interval x) -> Bool
forall a. Set a -> Bool
Set.null Set (Interval x)
is

-- | Insert an 'Interval' into a 'Borel' set, agglomerating along the way.
insert :: (Ord x) => Interval x -> Borel x -> Borel x
insert :: Interval x -> Borel x -> Borel x
insert Interval x
i (Borel Set (Interval x)
is) = Set (Interval x) -> Borel x
forall x. Set (Interval x) -> Borel x
Borel (Set (Interval x) -> Set (Interval x)
forall x. Ord x => Set (Interval x) -> Set (Interval x)
unionsSet (Interval x -> Set (Interval x) -> Set (Interval x)
forall a. Ord a => a -> Set a -> Set a
Set.insert Interval x
i Set (Interval x)
is))

-- | The maximal 'Borel' set, that covers the entire range.
whole :: (Ord x) => Borel x
whole :: Borel x
whole = Set (Interval x) -> Borel x
forall x. Set (Interval x) -> Borel x
Borel (OneItem (Set (Interval x)) -> Set (Interval x)
forall x. One x => OneItem x -> x
Prelude.one OneItem (Set (Interval x))
forall x. Ord x => Interval x
I.Whole)

-- | Completely remove an 'Interval' from a 'Borel' set.
cutout :: (Ord x) => Interval x -> Borel x -> Borel x
cutout :: Interval x -> Borel x -> Borel x
cutout Interval x
i (Borel Set (Interval x)
is) =
  ((Interval x -> Borel x) -> Set (Interval x) -> Borel x)
-> Set (Interval x) -> (Interval x -> Borel x) -> Borel x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Interval x -> Borel x) -> Set (Interval x) -> Borel x
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Set (Interval x)
is ((Interval x -> Borel x) -> Borel x)
-> (Interval x -> Borel x) -> Borel x
forall a b. (a -> b) -> a -> b
$
    (Interval x -> Interval x -> Maybe (OneOrTwo (Interval x))
forall x.
Ord x =>
Interval x -> Interval x -> Maybe (OneOrTwo (Interval x))
I.\\ Interval x
i) (Interval x -> Maybe (OneOrTwo (Interval x)))
-> (Maybe (OneOrTwo (Interval x)) -> Borel x)
-> Interval x
-> Borel x
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
      Maybe (OneOrTwo (Interval x))
Nothing -> Borel x
forall a. Monoid a => a
mempty
      Just (One Interval x
j) -> [Interval x] -> Borel x
forall x. Ord x => [Interval x] -> Borel x
borel [Interval x
j]
      Just (Two Interval x
j Interval x
k) -> [Interval x] -> Borel x
forall x. Ord x => [Interval x] -> Borel x
borel [Interval x
j, Interval x
k]

-- | Is this point 'I.within' any connected component of the 'Borel' set?
member :: (Ord x) => x -> Borel x -> Bool
member :: x -> Borel x -> Bool
member x
x (Borel Set (Interval x)
is) = (Interval x -> Bool) -> Set (Interval x) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (x -> Interval x -> Bool
forall x. Ord x => x -> Interval x -> Bool
I.within x
x) Set (Interval x)
is

-- | Is this point not 'I.within' any connected component of the 'Borel' set?
notMember :: (Ord x) => x -> Borel x -> Bool
notMember :: x -> Borel x -> Bool
notMember x
x = Bool -> Bool
not (Bool -> Bool) -> (Borel x -> Bool) -> Borel x -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Borel x -> Bool
forall x. Ord x => x -> Borel x -> Bool
member x
x

-- | A synonym for '(<>)'.
union :: (Ord x) => Borel x -> Borel x -> Borel x
union :: Borel x -> Borel x -> Borel x
union = Borel x -> Borel x -> Borel x
forall a. Semigroup a => a -> a -> a
(<>)

-- | A synonym for 'fold'.
unions :: (Ord x) => [Borel x] -> Borel x
unions :: [Borel x] -> Borel x
unions = [Borel x] -> Borel x
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold

-- | Remove all intervals of the second set from the first.
difference :: (Ord x) => Borel x -> Borel x -> Borel x
difference :: Borel x -> Borel x -> Borel x
difference Borel x
is (Borel Set (Interval x)
js) = (Interval x -> Borel x -> Borel x)
-> Borel x -> Set (Interval x) -> Borel x
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Interval x -> Borel x -> Borel x
forall x. Ord x => Interval x -> Borel x -> Borel x
cutout Borel x
is Set (Interval x)
js

-- | Take the symmetric difference of two 'Borel' sets.
symmetricDifference :: (Ord x) => Borel x -> Borel x -> Borel x
symmetricDifference :: Borel x -> Borel x -> Borel x
symmetricDifference Borel x
is Borel x
js = Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
difference Borel x
is Borel x
js Borel x -> Borel x -> Borel x
forall a. Semigroup a => a -> a -> a
<> Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
difference Borel x
js Borel x
is

-- | Take the 'Borel' set consisting of each point not in the given one.
complement :: (Ord x) => Borel x -> Borel x
complement :: Borel x -> Borel x
complement = Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
difference Borel x
forall x. Ord x => Borel x
whole

-- | Given an 'Interval' @i@, @'clip' i@ will trim a 'Borel' set
-- so that its 'hull' is contained in @i@.
clip :: (Ord x) => Interval x -> Borel x -> Borel x
clip :: Interval x -> Borel x -> Borel x
clip Interval x
i (Borel Set (Interval x)
js) =
  (Interval x -> Borel x -> Borel x)
-> Borel x -> Set (Interval x) -> Borel x
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Borel x -> Borel x -> Borel x
forall a. Semigroup a => a -> a -> a
(<>) (Borel x -> Borel x -> Borel x)
-> (Interval x -> Borel x) -> Interval x -> Borel x -> Borel x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Borel x -> (Interval x -> Borel x) -> Maybe (Interval x) -> Borel x
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Borel x
forall a. Monoid a => a
mempty Interval x -> Borel x
forall x. One x => OneItem x -> x
one (Maybe (Interval x) -> Borel x)
-> (Interval x -> Maybe (Interval x)) -> Interval x -> Borel x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval x -> Interval x -> Maybe (Interval x)
forall x. Ord x => Interval x -> Interval x -> Maybe (Interval x)
I.intersect Interval x
i) Borel x
forall a. Monoid a => a
mempty Set (Interval x)
js

-- | Take the intersection of two 'Borel' sets.
intersection :: (Ord x) => Borel x -> Borel x -> Borel x
intersection :: Borel x -> Borel x -> Borel x
intersection Borel x
is (Borel Set (Interval x)
js) = (Interval x -> Borel x) -> Set (Interval x) -> Borel x
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Interval x -> Borel x -> Borel x
forall x. Ord x => Interval x -> Borel x -> Borel x
`clip` Borel x
is) Set (Interval x)
js

-- | Take the intersection of a list of 'Borel' sets.
intersections :: (Ord x) => [Borel x] -> Borel x
intersections :: [Borel x] -> Borel x
intersections [] = Borel x
forall a. Monoid a => a
mempty
intersections [Borel x
i] = Borel x
i
intersections (Borel x
i : Borel x
j : [Borel x]
js) = Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
intersection (Borel x -> Borel x -> Borel x
forall x. Ord x => Borel x -> Borel x -> Borel x
intersection Borel x
i Borel x
j) ([Borel x] -> Borel x
forall x. Ord x => [Borel x] -> Borel x
intersections [Borel x]
js)

-- | Take the smallest spanning 'Interval' of a 'Borel' set,
-- provided that it is not the empty set.
hull :: (Ord x) => Borel x -> Maybe (Interval x)
hull :: Borel x -> Maybe (Interval x)
hull (Borel Set (Interval x)
is)
  | Set (Interval x) -> Bool
forall a. Set a -> Bool
Set.null Set (Interval x)
is = Maybe (Interval x)
forall a. Maybe a
Nothing
  | Bool
otherwise = Interval x -> Maybe (Interval x)
forall a. a -> Maybe a
Just (Interval x -> Maybe (Interval x))
-> Interval x -> Maybe (Interval x)
forall a b. (a -> b) -> a -> b
$ (Interval x -> Set (Interval x) -> Interval x)
-> (Interval x, Set (Interval x)) -> Interval x
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Interval x -> Interval x -> Interval x)
-> Interval x -> Set (Interval x) -> Interval x
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Interval x -> Interval x -> Interval x
forall x. Ord x => Interval x -> Interval x -> Interval x
I.hull) (Set (Interval x) -> (Interval x, Set (Interval x))
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set (Interval x)
is)