{-# LANGUAGE
      DerivingVia,
      PatternSynonyms,
      StandaloneDeriving
  #-}

-- | Partial orders
module Data.PartialOrd (
  -- * Comparisons in partial orders
  PartialOrdering(..),
  fromOrd,
  toMaybeOrd,
  fromMaybeOrd,
  fromLeqGeq,
  fromCompare,
  isLeq,
  isGeq,
  reversePartial,
  -- * Partial orderings
  PartialOrd(..),
  comparable,
  -- * Special partial orderings
  FullyOrd(..),
  Discrete(..),
  -- * Maxima and minima
  Maxima(..),
  maxima,
  Minima(..),
  minima,
  -- * Partial orders on lists
  Infix(..),
  Prefix(..),
  Suffix(..),
  Subseq(..),
  -- * Partial orders on Either
  Join(..),
  Disjoint(..),
  -- * Partial orders on Map
  PointwisePositive(..),
  ) where

import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import Data.List (isInfixOf, isPrefixOf, isSuffixOf, isSubsequenceOf)
import qualified Data.Map.Strict as M
import Data.Map.Internal (Map(..))
import Data.Monoid ()
import Data.Ord (Down(..))
import Data.Semigroup ()
import Data.Set (Set)
import qualified Data.Set as S
import Data.Void (Void, absurd)


-- | A data type representing relationships between two objects in a
-- poset: they can be related (by EQ', LT' or GT'; like EQ, LT or GT),
-- or unrelated (NT').
data PartialOrdering = EQ' | LT' | GT' | NT'
  deriving (PartialOrdering -> PartialOrdering -> Bool
(PartialOrdering -> PartialOrdering -> Bool)
-> (PartialOrdering -> PartialOrdering -> Bool)
-> Eq PartialOrdering
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PartialOrdering -> PartialOrdering -> Bool
== :: PartialOrdering -> PartialOrdering -> Bool
$c/= :: PartialOrdering -> PartialOrdering -> Bool
/= :: PartialOrdering -> PartialOrdering -> Bool
Eq, Int -> PartialOrdering -> ShowS
[PartialOrdering] -> ShowS
PartialOrdering -> String
(Int -> PartialOrdering -> ShowS)
-> (PartialOrdering -> String)
-> ([PartialOrdering] -> ShowS)
-> Show PartialOrdering
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialOrdering -> ShowS
showsPrec :: Int -> PartialOrdering -> ShowS
$cshow :: PartialOrdering -> String
show :: PartialOrdering -> String
$cshowList :: [PartialOrdering] -> ShowS
showList :: [PartialOrdering] -> ShowS
Show)

-- | Convert an ordering into a partial ordering
fromOrd :: Ordering -> PartialOrdering
fromOrd :: Ordering -> PartialOrdering
fromOrd Ordering
EQ = PartialOrdering
EQ'
fromOrd Ordering
LT = PartialOrdering
LT'
fromOrd Ordering
GT = PartialOrdering
GT'

-- | Lift a `compare` to a `compare'`
fromCompare :: Ord a => a -> a -> PartialOrdering
fromCompare :: forall a. Ord a => a -> a -> PartialOrdering
fromCompare a
x a
y = Ordering -> PartialOrdering
fromOrd (Ordering -> PartialOrdering) -> Ordering -> PartialOrdering
forall a b. (a -> b) -> a -> b
$ a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y

-- | Convert a partial ordering to an ordering
toMaybeOrd :: PartialOrdering -> Maybe Ordering
toMaybeOrd :: PartialOrdering -> Maybe Ordering
toMaybeOrd PartialOrdering
EQ' = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
EQ
toMaybeOrd PartialOrdering
LT' = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
LT
toMaybeOrd PartialOrdering
GT' = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
GT
toMaybeOrd PartialOrdering
NT' = Maybe Ordering
forall a. Maybe a
Nothing

-- | Convert an ordering into a partial ordering
fromMaybeOrd :: Maybe Ordering -> PartialOrdering
fromMaybeOrd :: Maybe Ordering -> PartialOrdering
fromMaybeOrd (Just Ordering
EQ) = PartialOrdering
EQ'
fromMaybeOrd (Just Ordering
LT) = PartialOrdering
LT'
fromMaybeOrd (Just Ordering
GT) = PartialOrdering
GT'
fromMaybeOrd Maybe Ordering
Nothing   = PartialOrdering
NT'

-- | Convert from `leq` and `geq` to a partial ordering
fromLeqGeq :: Bool -> Bool -> PartialOrdering
fromLeqGeq :: Bool -> Bool -> PartialOrdering
fromLeqGeq Bool
True Bool
True = PartialOrdering
EQ'
fromLeqGeq Bool
True Bool
False = PartialOrdering
LT'
fromLeqGeq Bool
False Bool
True = PartialOrdering
GT'
fromLeqGeq Bool
False Bool
False = PartialOrdering
NT'

isLeq :: PartialOrdering -> Bool
isLeq :: PartialOrdering -> Bool
isLeq PartialOrdering
EQ' = Bool
True
isLeq PartialOrdering
LT' = Bool
True
isLeq PartialOrdering
_ = Bool
False

isGeq :: PartialOrdering -> Bool
isGeq :: PartialOrdering -> Bool
isGeq PartialOrdering
EQ' = Bool
True
isGeq PartialOrdering
GT' = Bool
True
isGeq PartialOrdering
_ = Bool
False

reversePartial :: PartialOrdering -> PartialOrdering
reversePartial :: PartialOrdering -> PartialOrdering
reversePartial PartialOrdering
EQ' = PartialOrdering
EQ'
reversePartial PartialOrdering
LT' = PartialOrdering
GT'
reversePartial PartialOrdering
GT' = PartialOrdering
LT'
reversePartial PartialOrdering
NT' = PartialOrdering
NT'


-- | A typeclass expressing partially ordered types: any two elements
-- are related by a `PartialOrdering`.
--
-- In some cases `leq` can be quicker to run than `compare`. The
-- provided implementations such as `PartialOrd (a,b)` take advantage
-- of this.
class PartialOrd a where
  {-# MINIMAL compare' | leq #-}

  compare' :: a -> a -> PartialOrdering
  compare' a
a a
b = Bool -> Bool -> PartialOrdering
fromLeqGeq (a
a a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` a
b) (a
a a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
`geq` a
b)

  leq :: a -> a -> Bool
  a
a `leq` a
b = case a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
a a
b of
    PartialOrdering
LT' -> Bool
True
    PartialOrdering
EQ' -> Bool
True
    PartialOrdering
_   -> Bool
False

  geq :: a -> a -> Bool
  a
a `geq` a
b = a
b a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` a
a


-- | A helper type for constructing partial orderings from total
-- orderings (using deriving via)
newtype FullyOrd a = FullyOrd {
  forall a. FullyOrd a -> a
getOrd :: a
} deriving (FullyOrd a -> FullyOrd a -> Bool
(FullyOrd a -> FullyOrd a -> Bool)
-> (FullyOrd a -> FullyOrd a -> Bool) -> Eq (FullyOrd a)
forall a. Eq a => FullyOrd a -> FullyOrd a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => FullyOrd a -> FullyOrd a -> Bool
== :: FullyOrd a -> FullyOrd a -> Bool
$c/= :: forall a. Eq a => FullyOrd a -> FullyOrd a -> Bool
/= :: FullyOrd a -> FullyOrd a -> Bool
Eq, Eq (FullyOrd a)
Eq (FullyOrd a) =>
(FullyOrd a -> FullyOrd a -> Ordering)
-> (FullyOrd a -> FullyOrd a -> Bool)
-> (FullyOrd a -> FullyOrd a -> Bool)
-> (FullyOrd a -> FullyOrd a -> Bool)
-> (FullyOrd a -> FullyOrd a -> Bool)
-> (FullyOrd a -> FullyOrd a -> FullyOrd a)
-> (FullyOrd a -> FullyOrd a -> FullyOrd a)
-> Ord (FullyOrd a)
FullyOrd a -> FullyOrd a -> Bool
FullyOrd a -> FullyOrd a -> Ordering
FullyOrd a -> FullyOrd a -> FullyOrd a
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 a. Ord a => Eq (FullyOrd a)
forall a. Ord a => FullyOrd a -> FullyOrd a -> Bool
forall a. Ord a => FullyOrd a -> FullyOrd a -> Ordering
forall a. Ord a => FullyOrd a -> FullyOrd a -> FullyOrd a
$ccompare :: forall a. Ord a => FullyOrd a -> FullyOrd a -> Ordering
compare :: FullyOrd a -> FullyOrd a -> Ordering
$c< :: forall a. Ord a => FullyOrd a -> FullyOrd a -> Bool
< :: FullyOrd a -> FullyOrd a -> Bool
$c<= :: forall a. Ord a => FullyOrd a -> FullyOrd a -> Bool
<= :: FullyOrd a -> FullyOrd a -> Bool
$c> :: forall a. Ord a => FullyOrd a -> FullyOrd a -> Bool
> :: FullyOrd a -> FullyOrd a -> Bool
$c>= :: forall a. Ord a => FullyOrd a -> FullyOrd a -> Bool
>= :: FullyOrd a -> FullyOrd a -> Bool
$cmax :: forall a. Ord a => FullyOrd a -> FullyOrd a -> FullyOrd a
max :: FullyOrd a -> FullyOrd a -> FullyOrd a
$cmin :: forall a. Ord a => FullyOrd a -> FullyOrd a -> FullyOrd a
min :: FullyOrd a -> FullyOrd a -> FullyOrd a
Ord, Int -> FullyOrd a -> ShowS
[FullyOrd a] -> ShowS
FullyOrd a -> String
(Int -> FullyOrd a -> ShowS)
-> (FullyOrd a -> String)
-> ([FullyOrd a] -> ShowS)
-> Show (FullyOrd a)
forall a. Show a => Int -> FullyOrd a -> ShowS
forall a. Show a => [FullyOrd a] -> ShowS
forall a. Show a => FullyOrd a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FullyOrd a -> ShowS
showsPrec :: Int -> FullyOrd a -> ShowS
$cshow :: forall a. Show a => FullyOrd a -> String
show :: FullyOrd a -> String
$cshowList :: forall a. Show a => [FullyOrd a] -> ShowS
showList :: [FullyOrd a] -> ShowS
Show)

instance (Ord a) => PartialOrd (FullyOrd a) where
  compare' :: FullyOrd a -> FullyOrd a -> PartialOrdering
compare' (FullyOrd a
x) (FullyOrd a
y) = Ordering -> PartialOrdering
fromOrd (Ordering -> PartialOrdering) -> Ordering -> PartialOrdering
forall a b. (a -> b) -> a -> b
$ a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y


-- | A helper type for constructing partial orderings where everything
-- is equal or incomparable.
newtype Discrete a = Discrete {
  forall a. Discrete a -> a
getDiscrete :: a
} deriving (Discrete a -> Discrete a -> Bool
(Discrete a -> Discrete a -> Bool)
-> (Discrete a -> Discrete a -> Bool) -> Eq (Discrete a)
forall a. Eq a => Discrete a -> Discrete a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Discrete a -> Discrete a -> Bool
== :: Discrete a -> Discrete a -> Bool
$c/= :: forall a. Eq a => Discrete a -> Discrete a -> Bool
/= :: Discrete a -> Discrete a -> Bool
Eq, Int -> Discrete a -> ShowS
[Discrete a] -> ShowS
Discrete a -> String
(Int -> Discrete a -> ShowS)
-> (Discrete a -> String)
-> ([Discrete a] -> ShowS)
-> Show (Discrete a)
forall a. Show a => Int -> Discrete a -> ShowS
forall a. Show a => [Discrete a] -> ShowS
forall a. Show a => Discrete a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Discrete a -> ShowS
showsPrec :: Int -> Discrete a -> ShowS
$cshow :: forall a. Show a => Discrete a -> String
show :: Discrete a -> String
$cshowList :: forall a. Show a => [Discrete a] -> ShowS
showList :: [Discrete a] -> ShowS
Show)

instance (Eq a) => PartialOrd (Discrete a) where
  compare' :: Discrete a -> Discrete a -> PartialOrdering
compare' (Discrete a
x) (Discrete a
y)
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y    = PartialOrdering
EQ'
    | Bool
otherwise = PartialOrdering
NT'


-- | A comparison (less than or equal, greater than or equal) holds if
-- and only if it does on both arguments.
instance Semigroup PartialOrdering where
  PartialOrdering
NT' <> :: PartialOrdering -> PartialOrdering -> PartialOrdering
<> PartialOrdering
_   = PartialOrdering
NT'
  PartialOrdering
EQ' <> PartialOrdering
x   = PartialOrdering
x
  PartialOrdering
_   <> PartialOrdering
NT' = PartialOrdering
NT'
  PartialOrdering
x   <> PartialOrdering
EQ' = PartialOrdering
x
  PartialOrdering
LT' <> PartialOrdering
LT' = PartialOrdering
LT'
  PartialOrdering
GT' <> PartialOrdering
GT' = PartialOrdering
GT'
  PartialOrdering
_   <> PartialOrdering
_   = PartialOrdering
NT'

instance Monoid PartialOrdering where
  mempty :: PartialOrdering
mempty = PartialOrdering
EQ'


-- | Are they LT', EQ', GT'
comparable :: PartialOrd a => a -> a -> Bool
comparable :: forall a. PartialOrd a => a -> a -> Bool
comparable a
a a
b = case a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
a a
b of
  PartialOrdering
NT' -> Bool
False
  PartialOrdering
_   -> Bool
True

-- | It's hard to imagine another sensible instance
deriving via FullyOrd Int instance PartialOrd Int

-- | It's hard to imagine another sensible instance
deriving via FullyOrd Integer instance PartialOrd Integer


instance PartialOrd () where
  compare' :: () -> () -> PartialOrdering
compare' ()
_ ()
_ = PartialOrdering
EQ'

instance PartialOrd Void where
  compare' :: Void -> Void -> PartialOrdering
compare' = Void -> Void -> PartialOrdering
forall a. Void -> a
absurd


-- | This is equivalent to
--
--   >   compare' (a,b) (c,d) = compare' a c <> compare' b d
--
--   but may be more efficient: if compare' a c is LT' or GT' we need less
--   information about b and d.
instance (PartialOrd a, PartialOrd b) => PartialOrd (a,b) where
  compare' :: (a, b) -> (a, b) -> PartialOrdering
compare' (a
a1,b
b1) (a
a2,b
b2) = case a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
a1 a
a2 of
    PartialOrdering
NT' -> PartialOrdering
NT'
    PartialOrdering
EQ' -> b -> b -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' b
b1 b
b2
    PartialOrdering
LT' -> if b
b1 b -> b -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` b
b2 then PartialOrdering
LT' else PartialOrdering
NT'
    PartialOrdering
GT' -> if b
b1 b -> b -> Bool
forall a. PartialOrd a => a -> a -> Bool
`geq` b
b2 then PartialOrdering
GT' else PartialOrdering
NT'
  (a
a1,b
b1) leq :: (a, b) -> (a, b) -> Bool
`leq` (a
a2,b
b2) = a
a1 a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` a
a2 Bool -> Bool -> Bool
&& b
b1 b -> b -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` b
b2

instance (PartialOrd a, PartialOrd b, PartialOrd c) => PartialOrd (a,b,c) where
  compare' :: (a, b, c) -> (a, b, c) -> PartialOrdering
compare' (a
a1,b
b1,c
c1) (a
a2,b
b2,c
c2) = ((a, b), c) -> ((a, b), c) -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' ((a
a1,b
b1),c
c1) ((a
a2,b
b2),c
c2)
  (a
a1,b
b1,c
c1) leq :: (a, b, c) -> (a, b, c) -> Bool
`leq` (a
a2,b
b2,c
c2) = a
a1 a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` a
a2 Bool -> Bool -> Bool
&& b
b1 b -> b -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` b
b2 Bool -> Bool -> Bool
&& c
c1 c -> c -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` c
c2

instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d) => PartialOrd (a,b,c,d) where
  compare' :: (a, b, c, d) -> (a, b, c, d) -> PartialOrdering
compare' (a
a1,b
b1,c
c1,d
d1) (a
a2,b
b2,c
c2,d
d2) = (((a, b), c), d) -> (((a, b), c), d) -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' (((a
a1,b
b1),c
c1),d
d1) (((a
a2,b
b2),c
c2),d
d2)
  (a
a1,b
b1,c
c1,d
d1) leq :: (a, b, c, d) -> (a, b, c, d) -> Bool
`leq` (a
a2,b
b2,c
c2,d
d2) = a
a1 a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` a
a2 Bool -> Bool -> Bool
&& b
b1 b -> b -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` b
b2 Bool -> Bool -> Bool
&& c
c1 c -> c -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` c
c2 Bool -> Bool -> Bool
&& d
d1 d -> d -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` d
d2

instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e) => PartialOrd (a,b,c,d,e) where
  compare' :: (a, b, c, d, e) -> (a, b, c, d, e) -> PartialOrdering
compare' (a
a1,b
b1,c
c1,d
d1,e
e1) (a
a2,b
b2,c
c2,d
d2,e
e2) = ((((a, b), c), d), e) -> ((((a, b), c), d), e) -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' ((((a
a1,b
b1),c
c1),d
d1),e
e1) ((((a
a2,b
b2),c
c2),d
d2),e
e2)
  (a
a1,b
b1,c
c1,d
d1,e
e1) leq :: (a, b, c, d, e) -> (a, b, c, d, e) -> Bool
`leq` (a
a2,b
b2,c
c2,d
d2,e
e2) = a
a1 a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` a
a2 Bool -> Bool -> Bool
&& b
b1 b -> b -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` b
b2 Bool -> Bool -> Bool
&& c
c1 c -> c -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` c
c2 Bool -> Bool -> Bool
&& d
d1 d -> d -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` d
d2 Bool -> Bool -> Bool
&& e
e1 e -> e -> Bool
forall a. PartialOrd a => a -> a -> Bool
`leq` e
e2



-- | All elements on the left are less than all those on the right
newtype Join a b = Join {
  forall a b. Join a b -> Either a b
getJoin :: Either a b
}

instance (PartialOrd a, PartialOrd b) => PartialOrd (Join a b) where
  compare' :: Join a b -> Join a b -> PartialOrdering
compare' (Join (Left a
_)) (Join (Right b
_)) = PartialOrdering
LT'
  compare' (Join (Right b
_)) (Join (Left a
_)) = PartialOrdering
GT'
  compare' (Join (Left a
x)) (Join (Left a
y)) = a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
x a
y
  compare' (Join (Right b
x)) (Join (Right b
y)) = b -> b -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' b
x b
y

-- | All elements on the left are incomparable with all those on the right
newtype Disjoint a b = Disjoint {
  forall a b. Disjoint a b -> Either a b
getDisjoint :: Either a b
}

instance (PartialOrd a, PartialOrd b) => PartialOrd (Disjoint a b) where
  compare' :: Disjoint a b -> Disjoint a b -> PartialOrdering
compare' (Disjoint (Left a
_)) (Disjoint (Right b
_)) = PartialOrdering
NT'
  compare' (Disjoint (Right b
_)) (Disjoint (Left a
_)) = PartialOrdering
NT'
  compare' (Disjoint (Left a
x)) (Disjoint (Left a
y)) = a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
x a
y
  compare' (Disjoint (Right b
x)) (Disjoint (Right b
y)) = b -> b -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' b
x b
y


-- | Sets, with the subset partial order
instance Ord a => PartialOrd (Set a) where
  leq :: Set a -> Set a -> Bool
leq = Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
S.isSubsetOf

  compare' :: Set a -> Set a -> PartialOrdering
compare' Set a
u Set a
v = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Set a -> Int
forall a. Set a -> Int
S.size Set a
u) (Set a -> Int
forall a. Set a -> Int
S.size Set a
v) of
    Ordering
LT -> if Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
S.isSubsetOf Set a
u Set a
v then PartialOrdering
LT' else PartialOrdering
NT'
    Ordering
GT -> if Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
S.isSubsetOf Set a
v Set a
u then PartialOrdering
GT' else PartialOrdering
NT'
    Ordering
EQ -> if Set a
u Set a -> Set a -> Bool
forall a. Eq a => a -> a -> Bool
== Set a
v then PartialOrdering
EQ' else PartialOrdering
NT'

-- | Sets of integers, with the subset partial order
instance PartialOrd IntSet where
  leq :: IntSet -> IntSet -> Bool
leq = IntSet -> IntSet -> Bool
IS.isSubsetOf

  compare' :: IntSet -> IntSet -> PartialOrdering
compare' IntSet
u IntSet
v = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (IntSet -> Int
IS.size IntSet
u) (IntSet -> Int
IS.size IntSet
v) of
    Ordering
LT -> if IntSet -> IntSet -> Bool
IS.isSubsetOf IntSet
u IntSet
v then PartialOrdering
LT' else PartialOrdering
NT'
    Ordering
GT -> if IntSet -> IntSet -> Bool
IS.isSubsetOf IntSet
u IntSet
v then PartialOrdering
GT' else PartialOrdering
NT'
    Ordering
EQ -> if IntSet
u IntSet -> IntSet -> Bool
forall a. Eq a => a -> a -> Bool
== IntSet
v then PartialOrdering
EQ' else PartialOrdering
NT'


-- | Lists partially ordered by infix inclusion
newtype Infix a = Infix {
  forall a. Infix a -> [a]
unInfix :: [a]
} deriving (Infix a -> Infix a -> Bool
(Infix a -> Infix a -> Bool)
-> (Infix a -> Infix a -> Bool) -> Eq (Infix a)
forall a. Eq a => Infix a -> Infix a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Infix a -> Infix a -> Bool
== :: Infix a -> Infix a -> Bool
$c/= :: forall a. Eq a => Infix a -> Infix a -> Bool
/= :: Infix a -> Infix a -> Bool
Eq, Int -> Infix a -> ShowS
[Infix a] -> ShowS
Infix a -> String
(Int -> Infix a -> ShowS)
-> (Infix a -> String) -> ([Infix a] -> ShowS) -> Show (Infix a)
forall a. Show a => Int -> Infix a -> ShowS
forall a. Show a => [Infix a] -> ShowS
forall a. Show a => Infix a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Infix a -> ShowS
showsPrec :: Int -> Infix a -> ShowS
$cshow :: forall a. Show a => Infix a -> String
show :: Infix a -> String
$cshowList :: forall a. Show a => [Infix a] -> ShowS
showList :: [Infix a] -> ShowS
Show)

instance Eq a => PartialOrd (Infix a) where
  Infix [a]
a leq :: Infix a -> Infix a -> Bool
`leq` Infix [a]
b = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf [a]
a [a]
b


-- | Lists partially ordered by prefix inclusion
newtype Prefix a = Prefix {
  forall a. Prefix a -> [a]
unPrefix :: [a]
} deriving (Prefix a -> Prefix a -> Bool
(Prefix a -> Prefix a -> Bool)
-> (Prefix a -> Prefix a -> Bool) -> Eq (Prefix a)
forall a. Eq a => Prefix a -> Prefix a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Prefix a -> Prefix a -> Bool
== :: Prefix a -> Prefix a -> Bool
$c/= :: forall a. Eq a => Prefix a -> Prefix a -> Bool
/= :: Prefix a -> Prefix a -> Bool
Eq, Int -> Prefix a -> ShowS
[Prefix a] -> ShowS
Prefix a -> String
(Int -> Prefix a -> ShowS)
-> (Prefix a -> String) -> ([Prefix a] -> ShowS) -> Show (Prefix a)
forall a. Show a => Int -> Prefix a -> ShowS
forall a. Show a => [Prefix a] -> ShowS
forall a. Show a => Prefix a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Prefix a -> ShowS
showsPrec :: Int -> Prefix a -> ShowS
$cshow :: forall a. Show a => Prefix a -> String
show :: Prefix a -> String
$cshowList :: forall a. Show a => [Prefix a] -> ShowS
showList :: [Prefix a] -> ShowS
Show)

instance Eq a => PartialOrd (Prefix a) where
  compare' :: Prefix a -> Prefix a -> PartialOrdering
compare' (Prefix [a]
a) (Prefix [a]
b) = let
    inner :: [a] -> [a] -> PartialOrdering
inner [] [] = PartialOrdering
EQ'
    inner [] [a]
_ = PartialOrdering
LT'
    inner [a]
_ [] = PartialOrdering
GT'
    inner (a
x:[a]
xs) (a
y:[a]
ys)
      | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y    = [a] -> [a] -> PartialOrdering
inner [a]
xs [a]
ys
      | Bool
otherwise = PartialOrdering
NT'
    in [a] -> [a] -> PartialOrdering
forall {a}. Eq a => [a] -> [a] -> PartialOrdering
inner [a]
a [a]
b
  Prefix [a]
a leq :: Prefix a -> Prefix a -> Bool
`leq` Prefix [a]
b = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
a [a]
b


-- | Lists partially ordered by suffix inclusion
newtype Suffix a = Suffix {
  forall a. Suffix a -> [a]
unSuffix :: [a]
} deriving (Suffix a -> Suffix a -> Bool
(Suffix a -> Suffix a -> Bool)
-> (Suffix a -> Suffix a -> Bool) -> Eq (Suffix a)
forall a. Eq a => Suffix a -> Suffix a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Suffix a -> Suffix a -> Bool
== :: Suffix a -> Suffix a -> Bool
$c/= :: forall a. Eq a => Suffix a -> Suffix a -> Bool
/= :: Suffix a -> Suffix a -> Bool
Eq, Int -> Suffix a -> ShowS
[Suffix a] -> ShowS
Suffix a -> String
(Int -> Suffix a -> ShowS)
-> (Suffix a -> String) -> ([Suffix a] -> ShowS) -> Show (Suffix a)
forall a. Show a => Int -> Suffix a -> ShowS
forall a. Show a => [Suffix a] -> ShowS
forall a. Show a => Suffix a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Suffix a -> ShowS
showsPrec :: Int -> Suffix a -> ShowS
$cshow :: forall a. Show a => Suffix a -> String
show :: Suffix a -> String
$cshowList :: forall a. Show a => [Suffix a] -> ShowS
showList :: [Suffix a] -> ShowS
Show)

instance Eq a => PartialOrd (Suffix a) where
  Suffix [a]
a leq :: Suffix a -> Suffix a -> Bool
`leq` Suffix [a]
b = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [a]
a [a]
b


-- | Lists partially ordered by the subsequence relation
newtype Subseq a = Subseq {
  forall a. Subseq a -> [a]
unSubseq :: [a]
} deriving (Subseq a -> Subseq a -> Bool
(Subseq a -> Subseq a -> Bool)
-> (Subseq a -> Subseq a -> Bool) -> Eq (Subseq a)
forall a. Eq a => Subseq a -> Subseq a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Subseq a -> Subseq a -> Bool
== :: Subseq a -> Subseq a -> Bool
$c/= :: forall a. Eq a => Subseq a -> Subseq a -> Bool
/= :: Subseq a -> Subseq a -> Bool
Eq, Int -> Subseq a -> ShowS
[Subseq a] -> ShowS
Subseq a -> String
(Int -> Subseq a -> ShowS)
-> (Subseq a -> String) -> ([Subseq a] -> ShowS) -> Show (Subseq a)
forall a. Show a => Int -> Subseq a -> ShowS
forall a. Show a => [Subseq a] -> ShowS
forall a. Show a => Subseq a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Subseq a -> ShowS
showsPrec :: Int -> Subseq a -> ShowS
$cshow :: forall a. Show a => Subseq a -> String
show :: Subseq a -> String
$cshowList :: forall a. Show a => [Subseq a] -> ShowS
showList :: [Subseq a] -> ShowS
Show)

instance Eq a => PartialOrd (Subseq a) where
  Subseq [a]
a leq :: Subseq a -> Subseq a -> Bool
`leq` Subseq [a]
b = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSubsequenceOf [a]
a [a]
b


-- | Sets of incomparable elements, with a monoidal structure obtained
-- by taking the maximal ones.
--
-- Unfortunately, we need a full ordering for these to work (since
-- they use sets), though we don't assume this ordering has any
-- compatibility with the partial order. The monoid structures are
-- most efficient with pre-reduced sets as the left-hand argument.
newtype Maxima a = Maxima {
  forall a. Maxima a -> Set a
maxSet :: Set a
}

instance (Ord a, PartialOrd a) => Semigroup (Maxima a) where
  Maxima Set a
s1 <> :: Maxima a -> Maxima a -> Maxima a
<> Maxima Set a
s2 = let
    noLarger :: Set a -> a -> Bool
noLarger Set a
s a
x = Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
LT') (PartialOrdering -> Bool) -> (a -> PartialOrdering) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
x) ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
s
    s2' :: Set a
s2' = (a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Set a -> a -> Bool
forall {a}. PartialOrd a => Set a -> a -> Bool
noLarger Set a
s1) Set a
s2
    s1' :: Set a
s1' = (a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Set a -> a -> Bool
forall {a}. PartialOrd a => Set a -> a -> Bool
noLarger Set a
s2') Set a
s1
    in Set a -> Maxima a
forall a. Set a -> Maxima a
Maxima (Set a -> Maxima a) -> Set a -> Maxima a
forall a b. (a -> b) -> a -> b
$ Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
s1' Set a
s2'

instance (Ord a, PartialOrd a) => Monoid (Maxima a) where
  mempty :: Maxima a
mempty = Set a -> Maxima a
forall a. Set a -> Maxima a
Maxima Set a
forall a. Set a
S.empty
  mappend :: Maxima a -> Maxima a -> Maxima a
mappend = Maxima a -> Maxima a -> Maxima a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Find the maxima of a list (passing it through the machinery above)
maxima :: (Foldable f, Ord a, PartialOrd a) => f a -> Set a
maxima :: forall (f :: * -> *) a.
(Foldable f, Ord a, PartialOrd a) =>
f a -> Set a
maxima = Maxima a -> Set a
forall a. Maxima a -> Set a
maxSet (Maxima a -> Set a) -> (f a -> Maxima a) -> f a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maxima a) -> f a -> Maxima a
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Set a -> Maxima a
forall a. Set a -> Maxima a
Maxima (Set a -> Maxima a) -> (a -> Set a) -> a -> Maxima a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a
forall a. a -> Set a
S.singleton)


-- | As above, but with minima
newtype Minima a = Minima {
  forall a. Minima a -> Set a
minSet :: Set a
}

instance (Ord a, PartialOrd a) => Semigroup (Minima a) where
  Minima Set a
s1 <> :: Minima a -> Minima a -> Minima a
<> Minima Set a
s2 = let
    noSmaller :: Set a -> a -> Bool
noSmaller Set a
s a
x = Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((PartialOrdering -> PartialOrdering -> Bool
forall a. Eq a => a -> a -> Bool
== PartialOrdering
GT') (PartialOrdering -> Bool) -> (a -> PartialOrdering) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
x) ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
s
    s2' :: Set a
s2' = (a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Set a -> a -> Bool
forall {a}. PartialOrd a => Set a -> a -> Bool
noSmaller Set a
s1) Set a
s2
    s1' :: Set a
s1' = (a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Set a -> a -> Bool
forall {a}. PartialOrd a => Set a -> a -> Bool
noSmaller Set a
s2') Set a
s1
    in Set a -> Minima a
forall a. Set a -> Minima a
Minima (Set a -> Minima a) -> Set a -> Minima a
forall a b. (a -> b) -> a -> b
$ Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union Set a
s1' Set a
s2'

instance (Ord a, PartialOrd a) => Monoid (Minima a) where
  mempty :: Minima a
mempty = Set a -> Minima a
forall a. Set a -> Minima a
Minima Set a
forall a. Set a
S.empty
  mappend :: Minima a -> Minima a -> Minima a
mappend = Minima a -> Minima a -> Minima a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Find the minima of a list (passing it through the machinery above)
minima :: (Foldable f, Ord a, PartialOrd a) => f a -> Set a
minima :: forall (f :: * -> *) a.
(Foldable f, Ord a, PartialOrd a) =>
f a -> Set a
minima = Minima a -> Set a
forall a. Minima a -> Set a
minSet (Minima a -> Set a) -> (f a -> Minima a) -> f a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Minima a) -> f a -> Minima a
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Set a -> Minima a
forall a. Set a -> Minima a
Minima (Set a -> Minima a) -> (a -> Set a) -> a -> Minima a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a
forall a. a -> Set a
S.singleton)


-- | Maps partially ordered for pointwise comparison, where empty
-- values are considered minimal.
--
-- This is commonplace, but by no means the only conceivably ordering
-- on Map.
newtype PointwisePositive k v = PointwisePositive {
  forall k v. PointwisePositive k v -> Map k v
getPointwisePositive :: Map k v
}

instance (Ord k, PartialOrd v) => PartialOrd (PointwisePositive k v) where

  -- We reimplement the merge because of the possibility of early exit
  -- (in the case where mv2 is Nothing).
  leq :: PointwisePositive k v -> PointwisePositive k v -> Bool
leq = let
    inner :: Map k a -> Map k a -> Bool
inner Map k a
Tip Map k a
_ = Bool
True
    inner (Bin Int
_ k
k1 a
v1 Map k a
l1 Map k a
r1) Map k a
m2 = case k -> Map k a -> (Map k a, Maybe a, Map k a)
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
M.splitLookup k
k1 Map k a
m2 of
      (Map k a
l2, Maybe a
mv2, Map k a
r2) -> case Maybe a
mv2 of
        Maybe a
Nothing -> Bool
False
        Just a
v2 -> Map k a -> Map k a -> Bool
inner Map k a
l1 Map k a
l2 Bool -> Bool -> Bool
&& a -> a -> Bool
forall a. PartialOrd a => a -> a -> Bool
leq a
v1 a
v2 Bool -> Bool -> Bool
&& Map k a -> Map k a -> Bool
inner Map k a
r1 Map k a
r2
    start :: PointwisePositive k a -> PointwisePositive k a -> Bool
start (PointwisePositive Map k a
m1) (PointwisePositive Map k a
m2) = Map k a -> Map k a -> Bool
forall {k} {a}. (Ord k, PartialOrd a) => Map k a -> Map k a -> Bool
inner Map k a
m1 Map k a
m2
    in PointwisePositive k v -> PointwisePositive k v -> Bool
forall k v.
(Ord k, PartialOrd v) =>
PointwisePositive k v -> PointwisePositive k v -> Bool
start

  -- We reimplement the merge because of the possibility for
  -- shortcutting (via the call to compare')
  compare' :: PointwisePositive k v -> PointwisePositive k v -> PartialOrdering
compare' = let
    inner :: Map k v -> Map k v -> PartialOrdering
inner Map k v
Tip Map k v
Tip = PartialOrdering
EQ'
    inner Map k v
Tip (Bin Int
_ k
_ v
_ Map k v
_ Map k v
_) = PartialOrdering
LT'
    inner (Bin Int
_ k
k1 v
v1 Map k v
l1 Map k v
r1) Map k v
m2 = case k -> Map k v -> (Map k v, Maybe v, Map k v)
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
M.splitLookup k
k1 Map k v
m2 of
      (Map k v
l2, Maybe v
mv2, Map k v
r2) -> case Maybe v
mv2 of
        Maybe v
Nothing -> if PointwisePositive k v -> PointwisePositive k v -> Bool
forall a. PartialOrd a => a -> a -> Bool
geq (Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
l1) (Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
l2) Bool -> Bool -> Bool
&& PointwisePositive k v -> PointwisePositive k v -> Bool
forall a. PartialOrd a => a -> a -> Bool
geq (Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
r1) (Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
r2) then PartialOrdering
GT' else PartialOrdering
NT'
        Just v
v2 -> (PointwisePositive k v, v, PointwisePositive k v)
-> (PointwisePositive k v, v, PointwisePositive k v)
-> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' (Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
l1,v
v1,Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
r1) (Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
l2,v
v2,Map k v -> PointwisePositive k v
forall k v. Map k v -> PointwisePositive k v
PointwisePositive Map k v
r2)
    start :: PointwisePositive k v -> PointwisePositive k v -> PartialOrdering
start (PointwisePositive Map k v
m1) (PointwisePositive Map k v
m2) = Map k v -> Map k v -> PartialOrdering
forall {k} {v}.
(Ord k, PartialOrd v) =>
Map k v -> Map k v -> PartialOrdering
inner Map k v
m1 Map k v
m2
    in PointwisePositive k v -> PointwisePositive k v -> PartialOrdering
forall k v.
(Ord k, PartialOrd v) =>
PointwisePositive k v -> PointwisePositive k v -> PartialOrdering
start


instance PartialOrd a => PartialOrd (Down a) where
  compare' :: Down a -> Down a -> PartialOrdering
compare' (Down a
x) (Down a
y) = a -> a -> PartialOrdering
forall a. PartialOrd a => a -> a -> PartialOrdering
compare' a
y a
x