684 lines
20 KiB
Haskell
684 lines
20 KiB
Haskell
{- Copied from http://hackage.haskell.org/package/PSQueue-1.1/docs/src/Data-PSQueue.html -}
|
|
|
|
{- |
|
|
|
|
A /priority search queue/ (henceforth /queue/) efficiently supports the
|
|
opperations of both a search tree and a priority queue. A 'Binding' is a
|
|
product of a key and a priority. Bindings can be inserted, deleted, modified
|
|
and queried in logarithmic time, and the binding with the least priority can be
|
|
retrieved in constant time. A queue can be built from a list of bindings,
|
|
sorted by keys, in linear time.
|
|
|
|
This implementation is due to Ralf Hinze.
|
|
|
|
* Hinze, R., /A Simple Implementation Technique for Priority Search Queues/, ICFP 2001, pp. 110-121
|
|
|
|
<http://citeseer.ist.psu.edu/hinze01simple.html>
|
|
|
|
-}
|
|
|
|
-- Some modifications by Scott Dillard
|
|
|
|
|
|
module PSQueue
|
|
(
|
|
-- * Binding Type
|
|
Binding((:->))
|
|
, key
|
|
, prio
|
|
-- * Priority Search Queue Type
|
|
, PSQ
|
|
-- * Query
|
|
, size
|
|
, null
|
|
, lookup
|
|
-- * Construction
|
|
, empty
|
|
, singleton
|
|
-- * Insertion
|
|
, insert
|
|
, insertWith
|
|
, insertWithKey
|
|
, insertBinding
|
|
, insertBindingWith
|
|
, insertBindingWithKey
|
|
-- * Delete/Update
|
|
, delete
|
|
, adjust
|
|
, adjustWithKey
|
|
, update
|
|
, updateWithKey
|
|
, alter
|
|
-- * Conversion
|
|
, keys
|
|
, toList
|
|
, toAscList
|
|
, toDescList
|
|
, fromList
|
|
, fromAscList
|
|
, fromDistinctAscList
|
|
-- * Priority Queue
|
|
, findMin
|
|
, deleteMin
|
|
, minView
|
|
, atMost
|
|
, atMostRange
|
|
-- * Fold
|
|
, foldr
|
|
, foldl
|
|
) where
|
|
|
|
import Prelude hiding (lookup,null,foldl,foldr)
|
|
import qualified Prelude as P
|
|
|
|
{-
|
|
-- testing
|
|
import Test.QuickCheck
|
|
import Data.List (sort)
|
|
-}
|
|
|
|
|
|
|
|
|
|
-- | @k :-> p@ binds the key @k@ with the priority @p@.
|
|
data Binding k p = k :-> p deriving (Eq,Ord,Show,Read)
|
|
|
|
infix 0 :->
|
|
|
|
-- | The key of a binding
|
|
key :: Binding k p -> k
|
|
key (k :-> _) = k
|
|
|
|
-- | The priority of a binding
|
|
prio :: Binding k p -> p
|
|
prio (_ :-> p) = p
|
|
|
|
|
|
|
|
-- | A mapping from keys @k@ to priorites @p@.
|
|
|
|
data PSQ k p = Void | Winner k p (LTree k p) k
|
|
|
|
instance (Show k, Show p, Ord k, Ord p) => Show (PSQ k p) where
|
|
show = show . toAscList
|
|
--show Void = "[]"
|
|
--show (Winner k1 p lt k2) = "Winner "++show k1++" "++show p++" ("++show lt++") "++show k2
|
|
|
|
|
|
|
|
|
|
-- | /O(1)/ The number of bindings in a queue.
|
|
size :: PSQ k p -> Int
|
|
size Void = 0
|
|
size (Winner _ _ lt _) = 1 + size' lt
|
|
|
|
-- | /O(1)/ True if the queue is empty.
|
|
null :: PSQ k p -> Bool
|
|
null Void = True
|
|
null (Winner _ _ _ _) = False
|
|
|
|
-- | /O(log n)/ The priority of a given key, or Nothing if the key is not
|
|
-- bound.
|
|
lookup :: (Ord k, Ord p) => k -> PSQ k p -> Maybe p
|
|
lookup k q =
|
|
case tourView q of
|
|
Null -> fail "PSQueue.lookup: Empty queue"
|
|
Single k' p
|
|
| k == k' -> return p
|
|
| otherwise -> fail "PSQueue.lookup: Key not found"
|
|
tl `Play` tr
|
|
| k <= maxKey tl -> lookup k tl
|
|
| otherwise -> lookup k tr
|
|
|
|
|
|
|
|
empty :: (Ord k, Ord p) => PSQ k p
|
|
empty = Void
|
|
|
|
-- | O(1) Build a queue with one binding.
|
|
singleton :: (Ord k, Ord p) => k -> p -> PSQ k p
|
|
singleton k p = Winner k p Start k
|
|
|
|
|
|
-- | /O(log n)/ Insert a Binding into the queue.
|
|
insertBinding :: (Ord k, Ord p) => Binding k p -> PSQ k p -> PSQ k p
|
|
insertBinding (k :-> p) q = insert k p q
|
|
|
|
|
|
-- | /O(log n)/ Insert a binding into the queue.
|
|
insert :: (Ord k, Ord p) => k -> p -> PSQ k p -> PSQ k p
|
|
insert k p q =
|
|
case tourView q of
|
|
Null -> singleton k p
|
|
Single k' p' ->
|
|
case compare k k' of
|
|
LT -> singleton k p `play` singleton k' p'
|
|
EQ -> singleton k p
|
|
GT -> singleton k' p' `play` singleton k p
|
|
tl `Play` tr
|
|
| k <= maxKey tl -> insert k p tl `play` tr
|
|
| otherwise -> tl `play` insert k p tr
|
|
|
|
|
|
-- | /O(log n)/ Insert a Binding with a combining function.
|
|
insertBindingWith :: (Ord k, Ord p) => (p->p->p) -> Binding k p -> PSQ k p -> PSQ k p
|
|
insertBindingWith f = insertBindingWithKey (\_ p p' -> f p p')
|
|
|
|
-- | /O(log n)/ Insert a Binding with a combining function.
|
|
insertBindingWithKey :: (Ord k, Ord p) => (k->p->p->p) -> Binding k p -> PSQ k p -> PSQ k p
|
|
insertBindingWithKey f (k :-> p) q = insertWithKey f k p q
|
|
|
|
-- | /O(log n)/ Insert a binding with a combining function.
|
|
insertWith :: (Ord k, Ord p) => (p->p->p) -> k -> p -> PSQ k p -> PSQ k p
|
|
insertWith f = insertWithKey (\_ p p'-> f p p')
|
|
|
|
-- | /O(log n)/ Insert a binding with a combining function.
|
|
insertWithKey :: (Ord k, Ord p) => (k->p->p->p) -> k -> p -> PSQ k p -> PSQ k p
|
|
insertWithKey f k p q =
|
|
case tourView q of
|
|
Null -> singleton k p
|
|
Single k' p' ->
|
|
case compare k k' of
|
|
LT -> singleton k p `play` singleton k' p'
|
|
EQ -> singleton k (f k p p')
|
|
GT -> singleton k' p' `play` singleton k p
|
|
tl `Play` tr
|
|
| k <= maxKey tl -> insertWithKey f k p tl `unsafePlay` tr
|
|
| otherwise -> tl `unsafePlay` insertWithKey f k p tr
|
|
|
|
|
|
|
|
-- | /O(log n)/ Remove a binding from the queue.
|
|
delete :: (Ord k, Ord p) => k -> PSQ k p -> PSQ k p
|
|
delete k q =
|
|
case tourView q of
|
|
Null -> empty
|
|
Single k' p
|
|
| k == k' -> empty
|
|
| otherwise -> singleton k' p
|
|
tl `Play` tr
|
|
| k <= maxKey tl -> delete k tl `play` tr
|
|
| otherwise -> tl `play` delete k tr
|
|
|
|
-- | /O(log n)/ Adjust the priority of a key.
|
|
adjust :: (Ord p, Ord k) => (p -> p) -> k -> PSQ k p -> PSQ k p
|
|
adjust f = adjustWithKey (\_ p -> f p)
|
|
|
|
-- | /O(log n)/ Adjust the priority of a key.
|
|
adjustWithKey :: (Ord k, Ord p) => (k -> p -> p) -> k -> PSQ k p -> PSQ k p
|
|
adjustWithKey f k q =
|
|
case tourView q of
|
|
Null -> empty
|
|
Single k' p
|
|
| k == k' -> singleton k' (f k p)
|
|
| otherwise -> singleton k' p
|
|
tl `Play` tr
|
|
| k <= maxKey tl -> adjustWithKey f k tl `unsafePlay` tr
|
|
| otherwise -> tl `unsafePlay` adjustWithKey f k tr
|
|
|
|
|
|
-- | /O(log n)/ The expression (@update f k q@) updates the
|
|
-- priority @p@ bound @k@ (if it is in the queue). If (@f p@) is 'Nothing',
|
|
-- the binding is deleted. If it is (@'Just' z@), the key @k@ is bound
|
|
-- to the new priority @z@.
|
|
|
|
update :: (Ord k, Ord p) => (p -> Maybe p) -> k -> PSQ k p -> PSQ k p
|
|
update f = updateWithKey (\_ p -> f p)
|
|
|
|
-- | /O(log n)/. The expression (@updateWithKey f k q@) updates the
|
|
-- priority @p@ bound @k@ (if it is in the queue). If (@f k p@) is 'Nothing',
|
|
-- the binding is deleted. If it is (@'Just' z@), the key @k@ is bound
|
|
-- to the new priority @z@.
|
|
|
|
updateWithKey :: (Ord k, Ord p) => (k -> p -> Maybe p) -> k -> PSQ k p -> PSQ k p
|
|
updateWithKey f k q =
|
|
case tourView q of
|
|
Null -> empty
|
|
Single k' p
|
|
| k==k' -> case f k p of
|
|
Nothing -> empty
|
|
Just p' -> singleton k p'
|
|
| otherwise -> singleton k' p
|
|
tl `Play` tr
|
|
| k <= maxKey tl -> updateWithKey f k tl `unsafePlay` tr
|
|
| otherwise -> tl `unsafePlay` updateWithKey f k tr
|
|
|
|
|
|
-- | /O(log n)/. The expression (@'alter' f k q@) alters the priority @p@ bound to @k@, or absence thereof.
|
|
-- alter can be used to insert, delete, or update a priority in a queue.
|
|
alter :: (Ord k, Ord p) => (Maybe p -> Maybe p) -> k -> PSQ k p -> PSQ k p
|
|
alter f k q =
|
|
case tourView q of
|
|
Null ->
|
|
case f Nothing of
|
|
Nothing -> empty
|
|
Just p -> singleton k p
|
|
Single k' p
|
|
| k == k' -> case f (Just p) of
|
|
Nothing -> empty
|
|
Just p' -> singleton k' p'
|
|
| otherwise -> case f Nothing of
|
|
Nothing -> singleton k' p
|
|
Just p' -> insert k p' $ singleton k' p
|
|
tl `Play` tr
|
|
| k <= maxKey tl -> alter f k tl `unsafePlay` tr
|
|
| otherwise -> tl `unsafePlay` alter f k tr
|
|
|
|
|
|
|
|
-- | /O(n)/ The keys of a priority queue
|
|
keys :: (Ord k, Ord p) => PSQ k p -> [k]
|
|
keys = map key . toList
|
|
|
|
-- | /O(n log n)/ Build a queue from a list of bindings.
|
|
fromList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p
|
|
fromList = P.foldr (\(k:->p) q -> insert k p q) empty
|
|
|
|
-- | /O(n)/ Build a queue from a list of bindings in order of
|
|
-- ascending keys. The precondition that the keys are ascending is not checked.
|
|
fromAscList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p
|
|
fromAscList = fromDistinctAscList . stripEq
|
|
where stripEq [] = []
|
|
stripEq (x:xs) = stripEq' x xs
|
|
stripEq' x' [] = [x']
|
|
stripEq' x' (x:xs)
|
|
| x' == x = stripEq' x' xs
|
|
| otherwise = x' : stripEq' x xs
|
|
|
|
-- | /O(n)/ Build a queue from a list of distinct bindings in order of
|
|
-- ascending keys. The precondition that keys are distinct and ascending is not checked.
|
|
fromDistinctAscList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p
|
|
fromDistinctAscList = foldm unsafePlay empty . map (\(k:->p) -> singleton k p)
|
|
|
|
-- Folding a list in a binary-subdivision scheme.
|
|
foldm :: (a -> a -> a) -> a -> [a] -> a
|
|
foldm (*) e x
|
|
| P.null x = e
|
|
| otherwise = fst (rec (length x) x)
|
|
where rec 1 (a : as) = (a, as)
|
|
rec n as = (a1 * a2, as2)
|
|
where m = n `div` 2
|
|
(a1, as1) = rec (n - m) as
|
|
(a2, as2) = rec m as1
|
|
|
|
-- | /O(n)/ Convert a queue to a list.
|
|
toList :: (Ord k, Ord p) => PSQ k p -> [Binding k p]
|
|
toList = toAscList
|
|
|
|
-- | /O(n)/ Convert a queue to a list in ascending order of keys.
|
|
toAscList :: (Ord k, Ord p) => PSQ k p -> [Binding k p]
|
|
toAscList q = seqToList (toAscLists q)
|
|
|
|
toAscLists :: (Ord k, Ord p) => PSQ k p -> Sequ (Binding k p)
|
|
toAscLists q = case tourView q of
|
|
Null -> mempty
|
|
Single k p -> singleSequ (k :-> p)
|
|
tl `Play` tr -> toAscLists tl <> toAscLists tr
|
|
|
|
-- | /O(n)/ Convert a queue to a list in descending order of keys.
|
|
toDescList :: (Ord k, Ord p) => PSQ k p -> [ Binding k p ]
|
|
toDescList q = seqToList (toDescLists q)
|
|
|
|
toDescLists :: (Ord k, Ord p) => PSQ k p -> Sequ (Binding k p)
|
|
toDescLists q = case tourView q of
|
|
Null -> mempty
|
|
Single k p -> singleSequ (k :-> p)
|
|
tl `Play` tr -> toDescLists tr <> toDescLists tl
|
|
|
|
|
|
-- | /O(1)/ The binding with the lowest priority.
|
|
findMin :: (Ord k, Ord p) => PSQ k p -> Maybe (Binding k p)
|
|
findMin Void = Nothing
|
|
findMin (Winner k p t m) = Just (k :-> p)
|
|
|
|
-- | /O(log n)/ Remove the binding with the lowest priority.
|
|
deleteMin :: (Ord k, Ord p) => PSQ k p -> PSQ k p
|
|
deleteMin Void = Void
|
|
deleteMin (Winner k p t m) = secondBest t m
|
|
|
|
-- | /O(log n)/ Retrieve the binding with the least priority, and the rest of
|
|
-- the queue stripped of that binding.
|
|
minView :: (Ord k, Ord p) => PSQ k p -> Maybe (Binding k p, PSQ k p)
|
|
minView Void = Nothing
|
|
minView (Winner k p t m) = Just ( k :-> p , secondBest t m )
|
|
|
|
secondBest :: (Ord k, Ord p) => LTree k p -> k -> PSQ k p
|
|
secondBest Start _m = Void
|
|
secondBest (LLoser _ k p tl m tr) m' = Winner k p tl m `play` secondBest tr m'
|
|
secondBest (RLoser _ k p tl m tr) m' = secondBest tl m `play` Winner k p tr m'
|
|
|
|
|
|
|
|
-- | /O(r(log n - log r)/ @atMost p q@ is a list of all the bindings in @q@ with
|
|
-- priority less than @p@, in order of ascending keys.
|
|
-- Effectively,
|
|
--
|
|
-- @
|
|
-- atMost p' q = filter (\\(k:->p) -> p<=p') . toList
|
|
-- @
|
|
atMost :: (Ord k, Ord p) => p -> PSQ k p -> [Binding k p]
|
|
atMost pt q = seqToList (atMosts pt q)
|
|
|
|
atMosts :: (Ord k, Ord p) => p -> PSQ k p -> Sequ (Binding k p)
|
|
atMosts _pt Void = mempty
|
|
atMosts pt (Winner k p t _) = prune k p t
|
|
where
|
|
prune k p t
|
|
| p > pt = mempty
|
|
| otherwise = traverse k p t
|
|
traverse k p Start = singleSequ (k :-> p)
|
|
traverse k p (LLoser _ k' p' tl _m tr) = prune k' p' tl <> traverse k p tr
|
|
traverse k p (RLoser _ k' p' tl _m tr) = traverse k p tl <> prune k' p' tr
|
|
|
|
-- | /O(r(log n - log r))/ @atMostRange p (l,u) q@ is a list of all the bindings in
|
|
-- @q@ with a priority less than @p@ and a key in the range @(l,u)@ inclusive.
|
|
-- Effectively,
|
|
--
|
|
-- @
|
|
-- atMostRange p' (l,u) q = filter (\\(k:->p) -> l<=k && k<=u ) . 'atMost' p'
|
|
-- @
|
|
atMostRange :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> [Binding k p]
|
|
atMostRange pt (kl, kr) q = seqToList (atMostRanges pt (kl, kr) q)
|
|
|
|
atMostRanges :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> Sequ (Binding k p)
|
|
|
|
atMostRanges _pt _range Void = mempty
|
|
atMostRanges pt range@(kl, kr) (Winner k p t _) = prune k p t
|
|
where
|
|
prune k p t
|
|
| p > pt = mempty
|
|
| otherwise = traverse k p t
|
|
traverse k p Start
|
|
| k `inrange` range = singleSequ (k :-> p)
|
|
| otherwise = mempty
|
|
traverse k p (LLoser _ k' p' tl m tr) =
|
|
guard (kl <= m) (prune k' p' tl) <> guard (m <= kr) (traverse k p tr)
|
|
traverse k p (RLoser _ k' p' tl m tr) =
|
|
guard (kl <= m) (traverse k p tl) <> guard (m <= kr) (prune k' p' tr)
|
|
|
|
inrange :: (Ord a) => a -> (a, a) -> Bool
|
|
a `inrange` (l, r) = l <= a && a <= r
|
|
|
|
|
|
|
|
|
|
-- | Right fold over the bindings in the queue, in key order.
|
|
foldr :: (Ord k,Ord p) => (Binding k p -> b -> b) -> b -> PSQ k p -> b
|
|
foldr f z q =
|
|
case tourView q of
|
|
Null -> z
|
|
Single k p -> f (k:->p) z
|
|
l`Play`r -> foldr f (foldr f z r) l
|
|
|
|
|
|
-- | Left fold over the bindings in the queue, in key order.
|
|
foldl :: (Ord k,Ord p) => (b -> Binding k p -> b) -> b -> PSQ k p -> b
|
|
foldl f z q =
|
|
case tourView q of
|
|
Null -> z
|
|
Single k p -> f z (k:->p)
|
|
l`Play`r -> foldl f (foldl f z l) r
|
|
|
|
|
|
|
|
|
|
-----------------------
|
|
------- Internals -----
|
|
----------------------
|
|
|
|
type Size = Int
|
|
|
|
data LTree k p = Start
|
|
| LLoser {-# UNPACK #-}!Size !k !p (LTree k p) !k (LTree k p)
|
|
| RLoser {-# UNPACK #-}!Size !k !p (LTree k p) !k (LTree k p)
|
|
|
|
|
|
size' :: LTree k p -> Size
|
|
size' Start = 0
|
|
size' (LLoser s _ _ _ _ _) = s
|
|
size' (RLoser s _ _ _ _ _) = s
|
|
|
|
left, right :: LTree a b -> LTree a b
|
|
|
|
left Start = error "left: empty loser tree"
|
|
left (LLoser _ _ _ tl _ _ ) = tl
|
|
left (RLoser _ _ _ tl _ _ ) = tl
|
|
|
|
right Start = error "right: empty loser tree"
|
|
right (LLoser _ _ _ _ _ tr) = tr
|
|
right (RLoser _ _ _ _ _ tr) = tr
|
|
|
|
maxKey :: PSQ k p -> k
|
|
maxKey Void = error "maxKey: empty queue"
|
|
maxKey (Winner _k _p _t m) = m
|
|
|
|
lloser, rloser :: k -> p -> LTree k p -> k -> LTree k p -> LTree k p
|
|
lloser k p tl m tr = LLoser (1 + size' tl + size' tr) k p tl m tr
|
|
rloser k p tl m tr = RLoser (1 + size' tl + size' tr) k p tl m tr
|
|
|
|
--balance factor
|
|
omega :: Int
|
|
omega = 4
|
|
|
|
lbalance, rbalance ::
|
|
(Ord k, Ord p) => k-> p -> LTree k p -> k -> LTree k p -> LTree k p
|
|
|
|
lbalance k p l m r
|
|
| size' l + size' r < 2 = lloser k p l m r
|
|
| size' r > omega * size' l = lbalanceLeft k p l m r
|
|
| size' l > omega * size' r = lbalanceRight k p l m r
|
|
| otherwise = lloser k p l m r
|
|
|
|
rbalance k p l m r
|
|
| size' l + size' r < 2 = rloser k p l m r
|
|
| size' r > omega * size' l = rbalanceLeft k p l m r
|
|
| size' l > omega * size' r = rbalanceRight k p l m r
|
|
| otherwise = rloser k p l m r
|
|
|
|
lbalanceLeft k p l m r
|
|
| size' (left r) < size' (right r) = lsingleLeft k p l m r
|
|
| otherwise = ldoubleLeft k p l m r
|
|
|
|
lbalanceRight k p l m r
|
|
| size' (left l) > size' (right l) = lsingleRight k p l m r
|
|
| otherwise = ldoubleRight k p l m r
|
|
|
|
|
|
rbalanceLeft k p l m r
|
|
| size' (left r) < size' (right r) = rsingleLeft k p l m r
|
|
| otherwise = rdoubleLeft k p l m r
|
|
|
|
rbalanceRight k p l m r
|
|
| size' (left l) > size' (right l) = rsingleRight k p l m r
|
|
| otherwise = rdoubleRight k p l m r
|
|
|
|
|
|
|
|
|
|
lsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3)
|
|
| p1 <= p2 = lloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3
|
|
| otherwise = lloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3
|
|
|
|
lsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =
|
|
rloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3
|
|
|
|
rsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) =
|
|
rloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3
|
|
|
|
rsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =
|
|
rloser k2 p2 (rloser k1 p1 t1 m1 t2) m2 t3
|
|
|
|
lsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =
|
|
lloser k2 p2 t1 m1 (lloser k1 p1 t2 m2 t3)
|
|
|
|
lsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 =
|
|
lloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3)
|
|
|
|
rsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =
|
|
lloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3)
|
|
|
|
rsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3
|
|
| p1 <= p2 = rloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3)
|
|
| otherwise = rloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3)
|
|
|
|
|
|
|
|
ldoubleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) =
|
|
lsingleLeft k1 p1 t1 m1 (lsingleRight k2 p2 t2 m2 t3)
|
|
|
|
ldoubleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =
|
|
lsingleLeft k1 p1 t1 m1 (rsingleRight k2 p2 t2 m2 t3)
|
|
|
|
ldoubleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =
|
|
lsingleRight k1 p1 (lsingleLeft k2 p2 t1 m1 t2) m2 t3
|
|
|
|
ldoubleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 =
|
|
lsingleRight k1 p1 (rsingleLeft k2 p2 t1 m1 t2) m2 t3
|
|
|
|
rdoubleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) =
|
|
rsingleLeft k1 p1 t1 m1 (lsingleRight k2 p2 t2 m2 t3)
|
|
|
|
rdoubleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) =
|
|
rsingleLeft k1 p1 t1 m1 (rsingleRight k2 p2 t2 m2 t3)
|
|
|
|
rdoubleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 =
|
|
rsingleRight k1 p1 (lsingleLeft k2 p2 t1 m1 t2) m2 t3
|
|
|
|
rdoubleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 =
|
|
rsingleRight k1 p1 (rsingleLeft k2 p2 t1 m1 t2) m2 t3
|
|
|
|
|
|
play :: (Ord k, Ord p) => PSQ k p -> PSQ k p -> PSQ k p
|
|
|
|
Void `play` t' = t'
|
|
t `play` Void = t
|
|
|
|
Winner k p t m `play` Winner k' p' t' m'
|
|
| p <= p' = Winner k p (rbalance k' p' t m t') m'
|
|
| otherwise = Winner k' p' (lbalance k p t m t') m'
|
|
|
|
unsafePlay :: (Ord k, Ord p) => PSQ k p -> PSQ k p -> PSQ k p
|
|
|
|
Void `unsafePlay` t' = t'
|
|
t `unsafePlay` Void = t
|
|
|
|
Winner k p t m `unsafePlay` Winner k' p' t' m'
|
|
| p <= p' = Winner k p (rbalance k' p' t m t') m'
|
|
| otherwise = Winner k' p' (lbalance k p t m t') m'
|
|
|
|
|
|
|
|
data TourView k p = Null | Single k p | PSQ k p `Play` PSQ k p
|
|
|
|
tourView :: (Ord k) => PSQ k p -> TourView k p
|
|
|
|
tourView Void = Null
|
|
tourView (Winner k p Start _m) = Single k p
|
|
|
|
tourView (Winner k p (RLoser _ k' p' tl m tr) m') =
|
|
Winner k p tl m `Play` Winner k' p' tr m'
|
|
|
|
tourView (Winner k p (LLoser _ k' p' tl m tr) m') =
|
|
Winner k' p' tl m `Play` Winner k p tr m'
|
|
|
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------
|
|
-- Hughes's efficient sequence type --
|
|
--------------------------------------
|
|
|
|
singleSequ :: a -> Sequ a
|
|
seqFromList :: [a] -> Sequ a
|
|
seqFromListT :: ([a] -> [a]) -> Sequ a
|
|
seqToList :: Sequ a -> [a]
|
|
|
|
newtype Sequ a = Sequ ([a] -> [a])
|
|
|
|
singleSequ a = Sequ (\as -> a : as)
|
|
seqFromList as = Sequ (\as' -> as ++ as')
|
|
seqFromListT as = Sequ as
|
|
seqToList (Sequ x) = x []
|
|
|
|
instance Show a => Show (Sequ a) where
|
|
showsPrec d a = showsPrec d (seqToList a)
|
|
|
|
instance Semigroup (Sequ a) where
|
|
Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as))
|
|
|
|
instance Monoid (Sequ a) where
|
|
mempty = Sequ (\as -> as)
|
|
|
|
guard :: Bool -> Sequ a -> Sequ a
|
|
guard False _as = mempty
|
|
guard True as = as
|
|
|
|
|
|
|
|
|
|
---------------------------------
|
|
------------ Tests --------------
|
|
---------------------------------
|
|
|
|
{-
|
|
|
|
isBalanced Start = True
|
|
isBalanced (LLoser s k p l m r) =
|
|
(size' l + size' r <= 2 ||(size' l<=omega*size' r && size' r<=omega*size' l))
|
|
&& isBalanced l && isBalanced r
|
|
isBalanced (RLoser s k p l m r) =
|
|
(size' l + size' r <= 2 ||(size' l<=omega*size' r && size' r<=omega*size' l))
|
|
&& isBalanced l && isBalanced r
|
|
|
|
instance (Ord k, Ord p, Arbitrary k, Arbitrary p) => Arbitrary (PSQ k p)
|
|
where
|
|
coarbitrary = undefined
|
|
arbitrary =
|
|
do ks <- arbitrary
|
|
ps <- arbitrary
|
|
return . fromList $ zipWith (:->) ks ps
|
|
|
|
prop_Balanced :: PSQ Int Int -> Bool
|
|
prop_Balanced Void = True
|
|
prop_Balanced (Winner _ _ t _) = isBalanced t
|
|
|
|
prop_OrderedKeys :: PSQ Int Int -> Bool
|
|
prop_OrderedKeys t = let ks = map key . toAscList $ t in sort ks == ks
|
|
|
|
prop_AtMost :: (PSQ Int Int,Int) -> Bool
|
|
prop_AtMost (t,p) =
|
|
let ps = map prio . atMost p $ t
|
|
in all (<=p) ps
|
|
|
|
prop_AtMostRange :: (PSQ Int Int,Int,Int,Int) -> Bool
|
|
prop_AtMostRange (t,p,l_,r_) =
|
|
let l = min (abs l_) (abs r_)
|
|
r = max (abs l_) (abs r_)
|
|
(ks,ps) = unzip . map (\b -> (key b,prio b)) . atMostRange p (l,r) $ t
|
|
in all (flip inrange (l,r)) ks && all (<=p) ps
|
|
|
|
prop_MinView :: PSQ Int Int -> Bool
|
|
prop_MinView t =
|
|
case minView t of
|
|
Nothing -> True
|
|
Just (b1,t') ->
|
|
case minView t' of
|
|
Nothing -> True
|
|
Just (b2,_) -> prio b1 <= prio b2 && prop_MinView t'
|
|
|
|
tests =
|
|
do
|
|
putStrLn "Balanced"
|
|
quickCheck prop_Balanced
|
|
putStrLn "OrderedKeys"
|
|
quickCheck prop_OrderedKeys
|
|
putStrLn "MinView"
|
|
quickCheck prop_MinView
|
|
putStrLn "AtMost"
|
|
quickCheck prop_AtMost
|
|
putStrLn "AtMostRange"
|
|
quickCheck prop_AtMostRange
|
|
-}
|