--------------------------------------------------------------------------------
-- |
-- Module : Data.OrdSeq
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
--------------------------------------------------------------------------------
module Data.OrdSeq
( OrdSeq
, Compare
, insertBy
, insert
, splitBy
, splitOn
, splitMonotonic
, deleteAll
, deleteAllBy
, fromListBy
, fromListByOrd
, fromAscList
, lookupBy
, memberBy
, mapMonotonic
, viewl
, viewr
, minView
, lookupMin
, maxView
, lookupMax
) where
import Control.Lens (bimap)
import Data.FingerTree hiding (null, viewl, viewr)
import qualified Data.FingerTree as FT
import qualified Data.Foldable as F
import Data.Maybe (fromJust, isJust, listToMaybe)
import Test.QuickCheck (Arbitrary (arbitrary))
--------------------------------------------------------------------------------
data Key a = NoKey | Key { getKey :: !a } deriving (Show,Eq,Ord)
instance Semigroup (Key a) where
k <> NoKey = k
_ <> k = k
instance Monoid (Key a) where
mempty = NoKey
k `mappend` k' = k <> k'
liftCmp :: (a -> a -> Ordering) -> Key a -> Key a -> Ordering
liftCmp _ NoKey NoKey = EQ
liftCmp _ NoKey (Key _) = LT
liftCmp _ (Key _) NoKey = GT
liftCmp cmp (Key x) (Key y) = x `cmp` y
newtype Elem a = Elem a deriving (Eq,Ord,Traversable,Foldable,Functor)
instance Show a => Show (Elem a) where
show (Elem x) = "Elem " <> show x
-- | Sequence of ordered elements.
newtype OrdSeq a = OrdSeq { _asFingerTree :: FingerTree (Key a) (Elem a) }
deriving (Eq)
instance Show a => Show (OrdSeq a) where
show s = "fromAscList " ++ show (F.toList s)
instance Semigroup (OrdSeq a) where
(OrdSeq s) <> (OrdSeq t) = OrdSeq $ s `mappend` t
instance Monoid (OrdSeq a) where
mempty = OrdSeq mempty
mappend = (<>)
instance Foldable OrdSeq where
foldMap f = foldMap (foldMap f) . _asFingerTree
null = null . _asFingerTree
length = length . _asFingerTree
minimum = fromJust . lookupMin
maximum = fromJust . lookupMax
instance (Arbitrary a, Ord a) => Arbitrary (OrdSeq a) where
arbitrary = fromListByOrd <$> arbitrary
instance Measured (Key a) (Elem a) where
measure (Elem x) = Key x
-- | Signature for functions that give the ordering of two values.
type Compare a = a -> a -> Ordering
-- | Insert into a monotone OrdSeq.
--
-- pre: the comparator maintains monotonicity
--
-- \(O(\log n)\)
insertBy :: Compare a -> a -> OrdSeq a -> OrdSeq a
insertBy cmp x (OrdSeq s) = OrdSeq $ l `mappend` (Elem x <| r)
where
(l,r) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ, GT]) s
-- | Insert into a sorted OrdSeq
--
-- \(O(\log n)\)
insert :: Ord a => a -> OrdSeq a -> OrdSeq a
insert = insertBy compare
-- | \( O(\log n) \). Delete all elements that compare as equal to @x@.
deleteAllBy :: Compare a -> a -> OrdSeq a -> OrdSeq a
deleteAllBy cmp x s = l <> r
where
(l,_,r) = splitBy cmp x s
-- (l,m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s
-- (_,r) = split (\v -> liftCmp cmp v (Key x) == GT) m
-- | \(O(\log n)\)
splitBy :: Compare a -> a -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a)
splitBy cmp x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r)
where
(l, m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s
(m',r) = split (\v -> liftCmp cmp v (Key x) == GT) m
{- HLINT ignore splitOn -}
-- | Given a monotonic function f that maps a to b, split the sequence s
-- depending on the b values. I.e. the result (l,m,r) is such that
--
-- * @all (< x) . fmap f $ l@
-- * @all (== x) . fmap f $ m@
-- * @all (> x) . fmap f $ r@
--
-- >>> splitOn id 3 $ fromAscList [1..5]
-- (fromAscList [1,2],fromAscList [3],fromAscList [4,5])
-- >>> splitOn fst 2 $ fromAscList [(0,"-"),(1,"A"),(2,"B"),(2,"C"),(3,"D"),(4,"E")]
-- (fromAscList [(0,"-"),(1,"A")],fromAscList [(2,"B"),(2,"C")],fromAscList [(3,"D"),(4,"E")])
splitOn :: Ord b => (a -> b) -> b -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a)
splitOn f x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r)
where
(l, m) = split (\(Key v) -> compare (f v) x `elem` [EQ,GT]) s
(m',r) = split (\(Key v) -> compare (f v) x == GT) m
-- | Given a monotonic predicate p, splits the sequence s into two sequences
-- (as,bs) such that all (not p) as and all p bs
--
-- \(O(\log n)\)
splitMonotonic :: (a -> Bool) -> OrdSeq a -> (OrdSeq a, OrdSeq a)
splitMonotonic p = bimap OrdSeq OrdSeq . split (p . getKey) . _asFingerTree
-- | Deletes all elements from the OrdDeq
--
-- \(O(n\log n)\)
deleteAll :: Ord a => a -> OrdSeq a -> OrdSeq a
deleteAll = deleteAllBy compare
-- | inserts all eleements in order
-- \(O(n\log n)\)
fromListBy :: Compare a -> [a] -> OrdSeq a
fromListBy cmp = foldr (insertBy cmp) mempty
-- | inserts all eleements in order
-- \(O(n\log n)\)
fromListByOrd :: Ord a => [a] -> OrdSeq a
fromListByOrd = fromListBy compare
-- | \( O(n) \)
fromAscList :: [a] -> OrdSeq a
fromAscList = OrdSeq . fromList . fmap Elem
-- | \(O(\log n)\)
lookupBy :: Compare a -> a -> OrdSeq a -> Maybe a
lookupBy cmp x s = let (_,m,_) = splitBy cmp x s in listToMaybe . F.toList $ m
-- | \(O(\log n)\). Queries for the existance of any elements that compare as equal to @x@.
memberBy :: Compare a -> a -> OrdSeq a -> Bool
memberBy cmp x = isJust . lookupBy cmp x
-- | \( O(n) \) Fmap, assumes the order does not change
mapMonotonic :: (a -> b) -> OrdSeq a -> OrdSeq b
mapMonotonic f = fromAscList . map f . F.toList
-- | \(O(1)\) Gets the first element from the sequence
viewl :: OrdSeq a -> ViewL OrdSeq a
viewl = f . FT.viewl . _asFingerTree
where
f EmptyL = EmptyL
f (Elem x :< s) = x :< OrdSeq s
-- | \(O(1)\) Gets the last element from the sequence
viewr :: OrdSeq a -> ViewR OrdSeq a
viewr = f . FT.viewr . _asFingerTree
where
f EmptyR = EmptyR
f (s :> Elem x) = OrdSeq s :> x
-- | \(O(1)\)
minView :: OrdSeq a -> Maybe (a, OrdSeq a)
minView s = case viewl s of
EmptyL -> Nothing
(x :< t) -> Just (x,t)
-- | \(O(1)\)
lookupMin :: OrdSeq a -> Maybe a
lookupMin = fmap fst . minView
-- | \(O(1)\)
maxView :: OrdSeq a -> Maybe (a, OrdSeq a)
maxView s = case viewr s of
EmptyR -> Nothing
(t :> x) -> Just (x,t)
-- | \(O(1)\)
lookupMax :: OrdSeq a -> Maybe a
lookupMax = fmap fst . maxView