{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}
module GHC.Event.PSQ
(
Elem(..)
, Key
, Prio
, PSQ
, size
, null
, lookup
, empty
, singleton
, insert
, delete
, adjust
, toList
, toAscList
, toDescList
, fromList
, findMin
, deleteMin
, minView
, atMost
) where
import GHC.Base hiding (empty)
import GHC.Num (Num(..))
import GHC.Show (Show(showsPrec))
import GHC.Event.Unique (Unique)
data Elem a = E
{ key :: {-# UNPACK #-} !Key
, prio :: {-# UNPACK #-} !Prio
, value :: a
} deriving (Eq, Show)
type Prio = Double
type Key = Unique
data PSQ a = Void
| Winner {-# UNPACK #-} !(Elem a)
!(LTree a)
{-# UNPACK #-} !Key
deriving (Eq, Show)
size :: PSQ a -> Int
size Void = 0
size (Winner _ lt _) = 1 + size' lt
null :: PSQ a -> Bool
null Void = True
null (Winner _ _ _) = False
lookup :: Key -> PSQ a -> Maybe (Prio, a)
lookup k q = case tourView q of
Null -> Nothing
Single (E k' p v)
| k == k' -> Just (p, v)
| otherwise -> Nothing
tl `Play` tr
| k <= maxKey tl -> lookup k tl
| otherwise -> lookup k tr
empty :: PSQ a
empty = Void
singleton :: Key -> Prio -> a -> PSQ a
singleton k p v = Winner (E k p v) Start k
insert :: Key -> Prio -> a -> PSQ a -> PSQ a
insert k p v q = case q of
Void -> singleton k p v
Winner (E k' p' v') Start _ -> case compare k k' of
LT -> singleton k p v `play` singleton k' p' v'
EQ -> singleton k p v
GT -> singleton k' p' v' `play` singleton k p v
Winner e (RLoser _ e' tl m tr) m'
| k <= m -> insert k p v (Winner e tl m) `play` (Winner e' tr m')
| otherwise -> (Winner e tl m) `play` insert k p v (Winner e' tr m')
Winner e (LLoser _ e' tl m tr) m'
| k <= m -> insert k p v (Winner e' tl m) `play` (Winner e tr m')
| otherwise -> (Winner e' tl m) `play` insert k p v (Winner e tr m')
delete :: Key -> PSQ a -> PSQ a
delete k q = case q of
Void -> empty
Winner (E k' p v) Start _
| k == k' -> empty
| otherwise -> singleton k' p v
Winner e (RLoser _ e' tl m tr) m'
| k <= m -> delete k (Winner e tl m) `play` (Winner e' tr m')
| otherwise -> (Winner e tl m) `play` delete k (Winner e' tr m')
Winner e (LLoser _ e' tl m tr) m'
| k <= m -> delete k (Winner e' tl m) `play` (Winner e tr m')
| otherwise -> (Winner e' tl m) `play` delete k (Winner e tr m')
adjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a
adjust f k q0 = go q0
where
go q = case q of
Void -> empty
Winner (E k' p v) Start _
| k == k' -> singleton k' (f p) v
| otherwise -> singleton k' p v
Winner e (RLoser _ e' tl m tr) m'
| k <= m -> go (Winner e tl m) `unsafePlay` (Winner e' tr m')
| otherwise -> (Winner e tl m) `unsafePlay` go (Winner e' tr m')
Winner e (LLoser _ e' tl m tr) m'
| k <= m -> go (Winner e' tl m) `unsafePlay` (Winner e tr m')
| otherwise -> (Winner e' tl m) `unsafePlay` go (Winner e tr m')
{-# INLINE adjust #-}
fromList :: [Elem a] -> PSQ a
fromList = foldr (\(E k p v) q -> insert k p v q) empty
toList :: PSQ a -> [Elem a]
toList = toAscList
toAscList :: PSQ a -> [Elem a]
toAscList q = seqToList (toAscLists q)
toAscLists :: PSQ a -> Sequ (Elem a)
toAscLists q = case tourView q of
Null -> emptySequ
Single e -> singleSequ e
tl `Play` tr -> toAscLists tl <> toAscLists tr
toDescList :: PSQ a -> [ Elem a ]
toDescList q = seqToList (toDescLists q)
toDescLists :: PSQ a -> Sequ (Elem a)
toDescLists q = case tourView q of
Null -> emptySequ
Single e -> singleSequ e
tl `Play` tr -> toDescLists tr <> toDescLists tl
findMin :: PSQ a -> Maybe (Elem a)
findMin Void = Nothing
findMin (Winner e _ _) = Just e
deleteMin :: PSQ a -> PSQ a
deleteMin Void = Void
deleteMin (Winner _ t m) = secondBest t m
minView :: PSQ a -> Maybe (Elem a, PSQ a)
minView Void = Nothing
minView (Winner e t m) = Just (e, secondBest t m)
secondBest :: LTree a -> Key -> PSQ a
secondBest Start _ = Void
secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m'
secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m'
atMost :: Prio -> PSQ a -> ([Elem a], PSQ a)
atMost pt q = let (sequ, q') = atMosts pt q
in (seqToList sequ, q')
atMosts :: Prio -> PSQ a -> (Sequ (Elem a), PSQ a)
atMosts !pt q = case q of
(Winner e _ _)
| prio e > pt -> (emptySequ, q)
Void -> (emptySequ, Void)
Winner e Start _ -> (singleSequ e, Void)
Winner e (RLoser _ e' tl m tr) m' ->
let (sequ, q') = atMosts pt (Winner e tl m)
(sequ', q'') = atMosts pt (Winner e' tr m')
in (sequ <> sequ', q' `play` q'')
Winner e (LLoser _ e' tl m tr) m' ->
let (sequ, q') = atMosts pt (Winner e' tl m)
(sequ', q'') = atMosts pt (Winner e tr m')
in (sequ <> sequ', q' `play` q'')
type Size = Int
data LTree a = Start
| LLoser {-# UNPACK #-} !Size
{-# UNPACK #-} !(Elem a)
!(LTree a)
{-# UNPACK #-} !Key
!(LTree a)
| RLoser {-# UNPACK #-} !Size
{-# UNPACK #-} !(Elem a)
!(LTree a)
{-# UNPACK #-} !Key
!(LTree a)
deriving (Eq, Show)
size' :: LTree a -> Size
size' Start = 0
size' (LLoser s _ _ _ _) = s
size' (RLoser s _ _ _ _) = s
left, right :: LTree a -> LTree a
left Start = moduleError "left" "empty loser tree"
left (LLoser _ _ tl _ _ ) = tl
left (RLoser _ _ tl _ _ ) = tl
right Start = moduleError "right" "empty loser tree"
right (LLoser _ _ _ _ tr) = tr
right (RLoser _ _ _ _ tr) = tr
maxKey :: PSQ a -> Key
maxKey Void = moduleError "maxKey" "empty queue"
maxKey (Winner _ _ m) = m
lloser, rloser :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr
rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr
omega :: Int
omega = 4
lbalance, rbalance :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
lbalance k p v l m r
| size' l + size' r < 2 = lloser k p v l m r
| size' r > omega * size' l = lbalanceLeft k p v l m r
| size' l > omega * size' r = lbalanceRight k p v l m r
| otherwise = lloser k p v l m r
rbalance k p v l m r
| size' l + size' r < 2 = rloser k p v l m r
| size' r > omega * size' l = rbalanceLeft k p v l m r
| size' l > omega * size' r = rbalanceRight k p v l m r
| otherwise = rloser k p v l m r
lbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
lbalanceLeft k p v l m r
| size' (left r) < size' (right r) = lsingleLeft k p v l m r
| otherwise = ldoubleLeft k p v l m r
lbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
lbalanceRight k p v l m r
| size' (left l) > size' (right l) = lsingleRight k p v l m r
| otherwise = ldoubleRight k p v l m r
rbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
rbalanceLeft k p v l m r
| size' (left r) < size' (right r) = rsingleLeft k p v l m r
| otherwise = rdoubleLeft k p v l m r
rbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
rbalanceRight k p v l m r
| size' (left l) > size' (right l) = rsingleRight k p v l m r
| otherwise = rdoubleRight k p v l m r
lsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3)
| p1 <= p2 = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3
| otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3
lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =
rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3
lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree"
rsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =
rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3
rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =
rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3
rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree"
lsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =
lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3)
lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =
lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)
lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree"
rsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =
lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)
rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3
| p1 <= p2 = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)
| otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)
rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree"
ldoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =
lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)
ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =
lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)
ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree"
ldoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =
lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3
ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =
lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3
ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree"
rdoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =
rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)
rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =
rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)
rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree"
rdoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a
rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =
rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3
rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =
rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3
rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree"
play :: PSQ a -> PSQ a -> PSQ a
Void `play` t' = t'
t `play` Void = t
Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m'
| p <= p' = Winner e (rbalance k' p' v' t m t') m'
| otherwise = Winner e' (lbalance k p v t m t') m'
{-# INLINE play #-}
unsafePlay :: PSQ a -> PSQ a -> PSQ a
Void `unsafePlay` t' = t'
t `unsafePlay` Void = t
Winner e@(E k p v) t m `unsafePlay` Winner e'@(E k' p' v') t' m'
| p <= p' = Winner e (rloser k' p' v' t m t') m'
| otherwise = Winner e' (lloser k p v t m t') m'
{-# INLINE unsafePlay #-}
data TourView a = Null
| Single {-# UNPACK #-} !(Elem a)
| (PSQ a) `Play` (PSQ a)
tourView :: PSQ a -> TourView a
tourView Void = Null
tourView (Winner e Start _) = Single e
tourView (Winner e (RLoser _ e' tl m tr) m') =
Winner e tl m `Play` Winner e' tr m'
tourView (Winner e (LLoser _ e' tl m tr) m') =
Winner e' tl m `Play` Winner e tr m'
moduleError :: String -> String -> a
moduleError fun msg = error ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg)
{-# NOINLINE moduleError #-}
newtype Sequ a = Sequ ([a] -> [a])
emptySequ :: Sequ a
emptySequ = Sequ (\as -> as)
singleSequ :: a -> Sequ a
singleSequ a = Sequ (\as -> a : as)
(<>) :: Sequ a -> Sequ a -> Sequ a
Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as))
infixr 5 <>
seqToList :: Sequ a -> [a]
seqToList (Sequ x) = x []
instance Show a => Show (Sequ a) where
showsPrec d a = showsPrec d (seqToList a)