Implementation

Unbalanced priority search pennants.

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

> 

>  data LTree k p                =  Start

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

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

Here, LLoser means that the loser stems from the left subtree.

>  maxKey                        :: PSQ k p -> k

>  maxKey Void                   =  error "maxKey: empty queue"

>  maxKey (Winner _k _p _t m)    =  m

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  (RLoser k' p' t m t') m'

>    | otherwise                 =  Winner k' p' (LLoser k  p  t m t') m'

Note that the origin of the loser is now recorded in the constructor.

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

The helper function single' constructs a singleton queue from a given key and a given priority (rather than from a given binding).

>  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 play 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 `play` tr

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