> {-# LANGUAGE CPP #-}
> module Balanced(
>     Binding((:->)), key, prio, PSQ,
>     -- constructors and insertion
>     empty, single, insert, fromOrdList,
>     -- destructors and deletion
>     MinView(Empty, Min), minView, delete,
>     -- observers
>     lookup, toOrdList, atMost, atMostRange,
>     -- modifier
>     adjust)
> where
> import Prelude hiding (lookup

#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)

>                       ,(<>)

#endif

>                       )
> import ErrorUtil(internalError)

 import Basic hiding (guard)
 import Sequ hiding (empty, single)
 import qualified Sequ

> infixr 5 <>


\paragraph{Constructors and insertion}

> empty                         :: PSQ k p
> single                        :: Binding k p -> PSQ k p
> insert                        :: (Ord k, Ord p) => Binding k p -> PSQ k p -> PSQ k p
> fromOrdList                   :: Ord p => [Binding k p] -> PSQ k p

\paragraph{Destructors and deletion}

> data MinView k p              =  Empty | Min (Binding k p) (PSQ k p)
> minView                       :: (Ord k, Ord p) => PSQ k p -> MinView k p
> delete                        :: (Ord k, Ord p) => k -> PSQ k p -> PSQ k p

\paragraph{Observer}

> lookup                        :: (Ord k, Ord p) => k -> PSQ k p -> Maybe p
> toOrdList                     :: (Ord k, Ord p) => PSQ k p -> [Binding k p]
> atMost                        :: Ord p => p -> PSQ k p -> [Binding k p]
> atMostRange                   :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> [Binding k p]

\paragraph{Modifier}

> adjust                        :: (Ord k, Ord p) => (p -> p) -> k -> PSQ k p -> PSQ k p

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsection{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                   =  internalError "left: empty loser tree"
> left  (LLoser _ _ _ tl _ _tr)        =  tl
> left  (RLoser _ _ _ tl _ _tr)        =  tl
> right Start                   =  internalError "right: empty loser tree"
> right (LLoser _ _ _ _tl _ tr)        =  tr
> right (RLoser _ _ _ _tl _ tr)        =  tr

> maxKey                        :: PSQ k p -> k
> maxKey Void                   =  internalError "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

\paragraph{Balancing}

Balance factor.

> omega                                :: Int
> omega                                =  2

> lbalance, rbalance           :: 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, lbalanceRight, rbalanceLeft, rbalanceRight
>     :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p
> 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 (right l) < size (left 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 (right l) < size (left l)    =  rsingleRight k p l m r
>   | otherwise                         =  rdoubleRight k p l m r

> lsingleLeft, lsingleRight, rsingleLeft, rsingleRight
>     :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p
> 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
> lsingleLeft _ _ _ _ Start = internalError "lsingleLeft"
>
> 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
> rsingleLeft _ _ _ _ Start = internalError "rsingleLeft"
>
> 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)
> lsingleRight _ _ Start _ _ = internalError "lsingleRight"
>
> 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)
> rsingleRight _ _ Start _ _ = internalError "rsingleRight"

> ldoubleLeft, ldoubleRight, rdoubleLeft, rdoubleRight
>     :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p
> 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)
> ldoubleLeft _ _ _ _ Start = internalError "ldoubleLeft"
>
> 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
> ldoubleRight _ _ Start _ _ = internalError "ldoubleRight"
>
> 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)
> rdoubleLeft _ _ _ _ Start = internalError "rdoubleLeft"
>
> 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
> rdoubleRight _ _ Start _ _ = internalError "rdoubleRight"

\paragraph{Playing a match}

> play                          :: 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 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.
%if False

{- #INLINE tourView #-}

%endif

> data TourView k p             =  Null | Single k p | Play (PSQ k p) (PSQ k p)
>
> tourView                      :: 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'

\paragraph{Constructors and insertion}

> empty                         =  Void
>
> single (k :-> p)              =  single' k p
>
> single'                        :: 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 . map single

\paragraph{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'

\paragraph{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                        -> s_empty
>   Single k p                  -> s_single (k :-> p)
>   tl `Play` tr                -> toOrdLists tl <> toOrdLists tr
>
> atMost pt q                        =  toList (atMosts pt q)
>
> atMosts                       :: Ord p => p -> PSQ k p -> Sequ (Binding k p)
> atMosts _pt Void              =  s_empty
> atMosts pt (Winner k p t _)   =  prune k p t
>   where
>   prune k p t
>     | p > pt                    =  s_empty
>     | otherwise               =  traverse k p t
>   traverse k p Start          =  s_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 =  s_empty
> atMostRanges pt range@(kl, kr) (Winner k p t _)
>                              =  prune k p t
>   where
>   prune k p t
>     | p > pt                        =  s_empty
>     | otherwise               =  traverse k p t
>   traverse k p Start
>     | k `inrange` range        =  s_single (k :-> p)
>     | otherwise               =  s_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)

\paragraph{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

--------------- Basic ---------------

> data Binding k p              =  k :-> p
>     deriving(Show)
>
> key                           :: Binding k p -> k
> key  (k :-> _p)               =  k
>
> prio                          :: Binding k p -> p
> prio (_k :-> p)               =  p

Folding a list in a binary-subdivision scheme.

> foldm                         :: (a -> a -> a) -> a -> [a] -> a
> foldm (*) e x
>   | null x                    =  e
>   | otherwise                 =  fst (recFn (length x) x)
>   where recFn 1 (a : as)      =  (a, as)
>         recFn n as            =  (a1 * a2, as2)
>           where m             =  n `div` 2
>                 (a1, as1)     =  recFn (n - m) as
>                 (a2, as2)     =  recFn m       as1

> inrange                        :: (Ord a) => a -> (a, a) -> Bool
> a `inrange` (l, r)                =  l <= a && a <= r

--------------- Sequ ---------------

> s_empty                       :: Sequ a
>
> s_single                      :: a -> Sequ a
>
> (<>)                          :: Sequ a -> Sequ a -> Sequ a
>
> -- fromList                      :: [a] -> Sequ a
>
> -- fromListT                     :: ([a] -> [a]) -> Sequ a
>
> toList                        :: Sequ a -> [a]

% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -
\subsection{Implementation}
% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - -

> {-
> newtype Sequ a                =  Sequ ([a] -> [a])
>
> s_empty                       =  Sequ (\as -> as)
>
> s_single a                    =  Sequ (\as -> a : as)
>
> Sequ x1 <> Sequ x2            =  Sequ (\as -> x1 (x2 as))
>
> fromList as                   =  Sequ (\as' -> as ++ as')
>
> -- fromListT as                  =  Sequ as
>
> toList (Sequ x)               =  x []
> -}
>
> data Sequ a                        =  SEmpty | SUnit a | SFork (Sequ a) (Sequ a)
>
> s_empty                       =  SEmpty
>
> s_single a                    =  SUnit a
>
> x1 <> x2                         =  SFork x1 x2
>
> -- fromList xs                   =  foldr (<>) SEmpty (map s_single xs)
>
> toList as                     =  acc as []
>   where acc SEmpty r = r
>         acc (SUnit x) r = x : r
>         acc (SFork s1 s2) r = acc s1 (acc s2 r)
>


> instance Show a => Show (Sequ a) where
>     showsPrec d a             =  showsPrec d (toList a)

Derived function(s).

> guard                         :: Bool -> Sequ a -> Sequ a
> guard False _as               =  s_empty
> guard True  as                =  as