{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE Safe #-}

module Data.Order.Interval (
    Interval (),
    imap,
    (...),
    iempty,
    singleton,
    contains,
    endpts,
) where

import safe Data.Bifunctor (bimap)
import safe qualified Data.Eq as Eq
import safe Data.Order
import safe Data.Order.Syntax
import safe Prelude hiding (Bounded, Eq (..), Ord (..), until)

---------------------------------------------------------------------
-- Intervals
---------------------------------------------------------------------

-- | An interval in a poset /P/.
--
-- An interval in a poset /P/ is a subset /I/ of /P/ with the following property:
--
-- \( \forall x, y \in I, z \in P: x \leq z \leq y \Rightarrow z \in I \)
data Interval a = Empty | Interval !a !a deriving (Int -> Interval a -> ShowS
[Interval a] -> ShowS
Interval a -> String
(Int -> Interval a -> ShowS)
-> (Interval a -> String)
-> ([Interval a] -> ShowS)
-> Show (Interval a)
forall a. Show a => Int -> Interval a -> ShowS
forall a. Show a => [Interval a] -> ShowS
forall a. Show a => Interval a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Interval a] -> ShowS
$cshowList :: forall a. Show a => [Interval a] -> ShowS
show :: Interval a -> String
$cshow :: forall a. Show a => Interval a -> String
showsPrec :: Int -> Interval a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Interval a -> ShowS
Show)

-- | Map over an interval.
--
-- /Note/ this is not a functor, as a non-monotonic map
-- may cause the interval to collapse to the iempty interval.
imap :: Preorder b => (a -> b) -> Interval a -> Interval b
imap :: (a -> b) -> Interval a -> Interval b
imap a -> b
f = Interval b -> ((b, b) -> Interval b) -> Maybe (b, b) -> Interval b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Interval b
forall a. Interval a
iempty ((b -> b -> Interval b) -> (b, b) -> Interval b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> b -> Interval b
forall a. Preorder a => a -> a -> Interval a
(...)) (Maybe (b, b) -> Interval b)
-> (Interval a -> Maybe (b, b)) -> Interval a -> Interval b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, a) -> (b, b)) -> Maybe (a, a) -> Maybe (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (a -> b) -> (a, a) -> (b, b)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f a -> b
f) (Maybe (a, a) -> Maybe (b, b))
-> (Interval a -> Maybe (a, a)) -> Interval a -> Maybe (b, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval a -> Maybe (a, a)
forall a. Interval a -> Maybe (a, a)
endpts

infix 3 ...

-- | Construct an interval from a pair of points.
--
-- /Note/: Endpoints are preorder-sorted. If /pcompare x y = Nothing/
-- then the resulting interval will be empty.
(...) :: Preorder a => a -> a -> Interval a
a
x ... :: a -> a -> Interval a
... a
y = case a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y of
    Just Ordering
LT -> a -> a -> Interval a
forall a. a -> a -> Interval a
Interval a
x a
y
    Just Ordering
EQ -> a -> a -> Interval a
forall a. a -> a -> Interval a
Interval a
x a
y
    Maybe Ordering
_ -> Interval a
forall a. Interval a
Empty
{-# INLINE (...) #-}

-- | The iempty interval.
--
-- >>> iempty
-- Empty
iempty :: Interval a
iempty :: Interval a
iempty = Interval a
forall a. Interval a
Empty
{-# INLINE iempty #-}

-- | Construct an interval containing a single point.
--
-- >>> singleton 1
-- 1 ... 1
singleton :: a -> Interval a
singleton :: a -> Interval a
singleton a
a = a -> a -> Interval a
forall a. a -> a -> Interval a
Interval a
a a
a
{-# INLINE singleton #-}

-- | Obtain the endpoints of an interval.
endpts :: Interval a -> Maybe (a, a)
endpts :: Interval a -> Maybe (a, a)
endpts Interval a
Empty = Maybe (a, a)
forall a. Maybe a
Nothing
endpts (Interval a
x a
y) = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
x, a
y)
{-# INLINE endpts #-}

contains :: Preorder a => Interval a -> a -> Bool
contains :: Interval a -> a -> Bool
contains Interval a
Empty a
_ = Bool
False
contains (Interval a
x a
y) a
p = a
x a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
p Bool -> Bool -> Bool
&& a
p a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
y

---------------------------------------------------------------------
-- Instances
---------------------------------------------------------------------

instance Eq a => Eq (Interval a) where
    Interval a
Empty == :: Interval a -> Interval a -> Bool
== Interval a
Empty = Bool
True
    Interval a
Empty == Interval a
_ = Bool
False
    Interval a
_ == Interval a
Empty = Bool
False
    Interval a
x a
y == Interval a
x' a
y' = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x' Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y'

-- | A < https://en.wikipedia.org/wiki/Containment_order containment order >
instance Preorder a => Preorder (Interval a) where
    Interval a
Empty <~ :: Interval a -> Interval a -> Bool
<~ Interval a
_ = Bool
True
    Interval a
_ <~ Interval a
Empty = Bool
False
    Interval a
x a
y <~ Interval a
x' a
y' = a
x' a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
x Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
y'

{-
instance Bounded 'L a => Connection k (Maybe a) (Interval a) where
  conn = Conn f g h where
    f = maybe iempty singleton
    g = maybe Nothing (Just . uncurry (\/)) . endpts
    h = maybe iempty $ \x -> minimal ... x

instance Lattice a => Connection k (Interval a) (Maybe a) where
  conn = Conn f g h where
    f = maybe Nothing (Just . uncurry (\/)) . endpts
    g = maybe iempty singleton
    h = maybe Nothing (Just . uncurry (/\)) . endpts

instance Lattice a => Lattice (Interval a) where
  (\/) = joinInterval
  (/\) = meetInterval

bottom = Empty
top = bottom ... top
joinInterval Empty i = i
joinInterval i Empty = i
joinInterval (I x y) (I x' y') = I (x /\ x') (y \/ y')

-}