Implementation

Weight-balanced priority search pennants (based on Adams's weight-balanced trees).

>  data PSQ k p                  =  Void | Winner k p (LTree k p) k

> 

>  type Size                     =  Int

> 

>  data LTree k p                =  Start

>                                |  LLoser Size k p (LTree k p) k (LTree k p)

>                                |  RLoser Size k p (LTree k p) k (LTree k p)

> 

>  left, right                   :: LTree a b -> LTree a b

>  left  Start                   =  error "left: empty loser tree"

>  left  (LLoser _ _ _ tl _ _tr) =  tl

>  left  (RLoser _ _ _ tl _ _tr) =  tl

>  right Start                   =  error "right: empty loser tree"

>  right (LLoser _ _ _ _tl _ tr) =  tr

>  right (RLoser _ _ _ _tl _ tr) =  tr

>  maxKey                        :: PSQ k p -> k

>  maxKey Void                   =  error "maxKey: empty queue"

>  maxKey (Winner _k _p _t m)    =  m

Smart constructors.

>  start                         :: LTree k p

>  start                         =  Start

> 

>  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

> 

>  size                          :: LTree k p -> Size

>  size Start                    =  0

>  size (LLoser s _ _ _ _ _)     =  s

>  size (RLoser s _ _ _ _ _)     =  s

Balancing

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 r) < size (right r)    =  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 r) < size (right r)    =  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

Playing a match

>  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'

Note that this is the only place where lbalance and rbalance are used.

>  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'

The unsafe function unsafePlay can be used instead of play if we know that the shape of the tree has not changed or if the tree is known to be balanced.

Tournament view.

>  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'

Constructors and insertion

>  empty                         =  Void

> 

>  single (k :-> p)              =  single' k p

> 

>  single'                       :: (Ord k, Ord p) => k -> p -> PSQ k p

>  single' k p                   =  Winner k p start k

> 

>  insert b q                    =  case tourView q of

>    Null                        -> single b

>    Single k' p'

>      | key b <  k'             -> single b      `play` single' k' p'

>      | key b == k'             -> single b

>      | otherwise               -> single' k' p' `play` single b

>    tl `Play` tr

>      | key b <= maxKey tl      -> insert b tl `play` tr

>      | otherwise               -> tl `play` insert b tr

> 

>  fromOrdList                   =  foldm unsafePlay empty `o` map single

Destructors and deletion

>  minView Void                  =  Empty

>  minView (Winner k p t m)      =  Min (k :-> p) (secondBest t m)

> 

>  delete k q                    =  case tourView q of

>    Null                        -> empty

>    Single k' p

>      | k == k'                 -> empty

>      | otherwise               -> single' k' p

>    tl `Play` tr

>      | k <= maxKey tl          -> delete k tl `play` tr

>      | otherwise               -> tl `play` delete k tr

Determining the second-best player.

>  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'

Observers

>  lookup k q                    =  case tourView q of

>    Null                        -> Nothing

>    Single k' p

>      | k == k'                 -> Just p

>      | otherwise               -> Nothing

>    tl `Play` tr

>      | k <= maxKey tl          -> lookup k tl

>      | otherwise               -> lookup k tr

> 

>  toOrdList q                   =  toList (toOrdLists q)

> 

>  toOrdLists                    :: (Ord k, Ord p) => PSQ k p -> Sequ (Binding k p)

>  toOrdLists q                  =  case tourView q of

>    Null                        -> Sequ.empty

>    Single k p                  -> Sequ.single (k :-> p)

>    tl `Play` tr                -> toOrdLists tl <> toOrdLists tr

> 

>  atMost pt q                   =  toList (atMosts pt q)

> 

>  atMosts                       :: (Ord k, Ord p) => p -> PSQ k p -> Sequ (Binding k p)

>  atMosts _pt Void              =  Sequ.empty

>  atMosts pt (Winner k p t _)   =  prune k p t

>    where

>    prune k p t

>      | p > pt                  =  Sequ.empty

>      | otherwise               =  traverse k p t

>    traverse k p Start          =  Sequ.single (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

> 

> 

>  atMostRange pt (kl, kr) q     =  toList (atMostRanges pt (kl, kr) q)

>  atMostRanges                  :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> Sequ (Binding k p)

>  atMostRanges _pt _range Void =  Sequ.empty

>  atMostRanges pt range@(kl, kr) (Winner k p t _)

>                               =  prune k p t

>    where

>    prune k p t

>      | p > pt                  =  Sequ.empty

>      | otherwise               =  traverse k p t

>    traverse k p Start

>      | k `inrange` range       =  Sequ.single (k :-> p)

>      | otherwise               =  Sequ.empty

>    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)

Modifier

>  adjust f k q                  =  case tourView q of

>    Null                        -> empty

>    Single k' p

>      | k == k'                 -> single' k' (f p)

>      | otherwise               -> single' k' p

>    tl `Play` tr

>      | k <= maxKey tl          -> adjust f k tl `unsafePlay` tr

>      | otherwise               -> tl `unsafePlay` adjust f k tr