{-# LANGUAGE Unsafe #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Data.Struct.Internal.Order where

import Control.Exception
import Control.Monad
import Control.Monad.Primitive
import Control.Monad.ST
import Data.Bits
import Data.Struct.Internal
import Data.Struct.Internal.Label (Label, Key)
import qualified Data.Struct.Label as Label
import qualified Data.Struct.Internal.Label as Label (key)
import Data.Word

--------------------------------------------------------------------------------
-- * Order Maintenance
--------------------------------------------------------------------------------

-- | This structure maintains an order-maintenance structure as two levels of list-labeling.
--
-- The upper labeling scheme holds @(n / log w)@ elements in a universe of size @w^2@, operating in O(log n) amortized time per operation.
--
-- It is accelerated by an indirection structure where each smaller universe holds O(log w) elements, with total label space @2^log w = w@ and O(1) expected update cost, so we
-- can charge rebuilds to the upper structure to the lower structure.
--
-- Every insert to the upper structure is amortized across @O(log w)@ operations below.
--
-- This means that inserts are O(1) amortized, while comparisons remain O(1) worst-case.

newtype Order a s = Order { Order a s -> Object s
runOrder :: Object s }

instance Eq (Order a s) where == :: Order a s -> Order a s -> Bool
(==) = Order a s -> Order a s -> Bool
forall (t :: * -> *) s. Struct t => t s -> t s -> Bool
eqStruct

instance Struct (Order a)

key :: Field (Order a) Key
key :: Field (Order a) Key
key = Int -> Field (Order a) Key
forall k (s :: k) a. Int -> Field s a
field Int
0
{-# INLINE key #-}

value :: Field (Order a) a
value :: Field (Order a) a
value = Int -> Field (Order a) a
forall k (s :: k) a. Int -> Field s a
field Int
1
{-# INLINE value #-}

next :: Slot (Order a) (Order a)
next :: Slot (Order a) (Order a)
next = Int -> Slot (Order a) (Order a)
forall k1 k2 (s :: k1) (t :: k2). Int -> Slot s t
slot Int
2
{-# INLINE next #-}

prev :: Slot (Order a) (Order a)
prev :: Slot (Order a) (Order a)
prev = Int -> Slot (Order a) (Order a)
forall k1 k2 (s :: k1) (t :: k2). Int -> Slot s t
slot Int
3
{-# INLINE prev #-}

parent :: Slot (Order a) Label
parent :: Slot (Order a) Label
parent = Int -> Slot (Order a) Label
forall k1 k2 (s :: k1) (t :: k2). Int -> Slot s t
slot Int
4
{-# INLINE parent #-}

makeOrder :: PrimMonad m => Label (PrimState m) -> Key -> a -> Order a (PrimState m) -> Order a (PrimState m) -> m (Order a (PrimState m))
makeOrder :: Label (PrimState m)
-> Key
-> a
-> Order a (PrimState m)
-> Order a (PrimState m)
-> m (Order a (PrimState m))
makeOrder Label (PrimState m)
mom Key
a a
v Order a (PrimState m)
p Order a (PrimState m)
n = ST (PrimState m) (Order a (PrimState m))
-> m (Order a (PrimState m))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Order a (PrimState m))
 -> m (Order a (PrimState m)))
-> ST (PrimState m) (Order a (PrimState m))
-> m (Order a (PrimState m))
forall a b. (a -> b) -> a -> b
$ do
  Order a (PrimState m)
this <- Int -> ST (PrimState m) (Order a (PrimState (ST (PrimState m))))
forall (m :: * -> *) (t :: * -> *).
(PrimMonad m, Struct t) =>
Int -> m (t (PrimState m))
alloc Int
5
  Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this Label (PrimState m)
Label (PrimState (ST (PrimState m)))
mom
  Field (Order a) Key
-> Order a (PrimState (ST (PrimState m)))
-> Key
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> a -> m ()
setField Field (Order a) Key
forall a. Field (Order a) Key
key Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this Key
a
  Field (Order a) a
-> Order a (PrimState (ST (PrimState m)))
-> a
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> a -> m ()
setField Field (Order a) a
forall a. Field (Order a) a
value Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this a
v
  Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
prev Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
p
  Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
next Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n
  Order a (PrimState m) -> ST (PrimState m) (Order a (PrimState m))
forall (m :: * -> *) a. Monad m => a -> m a
return Order a (PrimState m)
this
{-# INLINE makeOrder #-}

-- | O(1) compareM, O(1) amortized insert
compareM :: PrimMonad m => Order a (PrimState m) -> Order a (PrimState m) -> m Ordering
compareM :: Order a (PrimState m) -> Order a (PrimState m) -> m Ordering
compareM Order a (PrimState m)
i Order a (PrimState m)
j
  | Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
i Bool -> Bool -> Bool
|| Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
j = NullPointerException -> m Ordering
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
  | Bool
otherwise = ST (PrimState m) Ordering -> m Ordering
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) Ordering -> m Ordering)
-> ST (PrimState m) Ordering -> m Ordering
forall a b. (a -> b) -> a -> b
$ do
  Label (PrimState m)
ui <- Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
i
  Label (PrimState m)
uj <- Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
j
  Ordering
xs <- Label (PrimState (ST (PrimState m)))
-> Label (PrimState (ST (PrimState m)))
-> ST (PrimState m) Ordering
forall (m :: * -> *).
PrimMonad m =>
Label (PrimState m) -> Label (PrimState m) -> m Ordering
Label.compareM Label (PrimState m)
Label (PrimState (ST (PrimState m)))
ui Label (PrimState m)
Label (PrimState (ST (PrimState m)))
uj
  case Ordering
xs of
    Ordering
EQ -> Key -> Key -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Key -> Key -> Ordering)
-> ST (PrimState m) Key -> ST (PrimState m) (Key -> Ordering)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field (Order a) Key
-> Order a (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field (Order a) Key
forall a. Field (Order a) Key
key Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
i ST (PrimState m) (Key -> Ordering)
-> ST (PrimState m) Key -> ST (PrimState m) Ordering
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field (Order a) Key
-> Order a (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field (Order a) Key
forall a. Field (Order a) Key
key Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
j
    Ordering
x -> Ordering -> ST (PrimState m) Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
x
{-# INLINE compareM #-}

insertAfter :: PrimMonad m => Order a (PrimState m) -> a -> m (Order a (PrimState m))
insertAfter :: Order a (PrimState m) -> a -> m (Order a (PrimState m))
insertAfter Order a (PrimState m)
n0 a
a1 = ST (PrimState m) (Order a (PrimState m))
-> m (Order a (PrimState m))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Order a (PrimState m))
 -> m (Order a (PrimState m)))
-> ST (PrimState m) (Order a (PrimState m))
-> m (Order a (PrimState m))
forall a b. (a -> b) -> a -> b
$ do
  Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
n0) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ NullPointerException -> ST (PrimState m) ()
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
  Label (PrimState m)
mom <- Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n0
  Key
k0 <- Field (Order a) Key
-> Order a (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field (Order a) Key
forall a. Field (Order a) Key
key Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n0
  Order a (PrimState m)
n2 <- Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Order a (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
next Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n0
  Key
k2 <- if Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
n2 then Key -> ST (PrimState m) Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
forall a. Bounded a => a
maxBound else Field (Order a) Key
-> Order a (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field (Order a) Key
forall a. Field (Order a) Key
key Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n2
  let !k1 :: Key
k1 = Key
k0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key -> Int -> Key
forall a. Bits a => a -> Int -> a
unsafeShiftR (Key
k2 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
k0) Int
1
  Order a (PrimState m)
n1 <- Label (PrimState (ST (PrimState m)))
-> Key
-> a
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Order a (PrimState (ST (PrimState m))))
forall (m :: * -> *) a.
PrimMonad m =>
Label (PrimState m)
-> Key
-> a
-> Order a (PrimState m)
-> Order a (PrimState m)
-> m (Order a (PrimState m))
makeOrder Label (PrimState m)
Label (PrimState (ST (PrimState m)))
mom Key
k1 a
a1 Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n0 Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n2
  Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
n2) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
prev Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n2 Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n1
  Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
next Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n0 Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n1
  Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Key
k0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
k2) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ Label (PrimState m) -> Order a (PrimState m) -> ST (PrimState m) ()
forall s a. Label s -> Order a s -> ST s ()
rewind Label (PrimState m)
mom Order a (PrimState m)
n0 -- we have a collision, rebalance
  Order a (PrimState m) -> ST (PrimState m) (Order a (PrimState m))
forall (m :: * -> *) a. Monad m => a -> m a
return Order a (PrimState m)
n1
 where
  -- find the smallest sibling
  rewind :: Label s -> Order a s -> ST s ()
  rewind :: Label s -> Order a s -> ST s ()
rewind Label s
mom Order a s
this = do
    Order a s
p <- Slot (Order a) (Order a)
-> Order a (PrimState (ST s)) -> ST s (Order a (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
prev Order a s
Order a (PrimState (ST s))
this
    if Order a s -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a s
p then Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
forall s a.
Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
rebalance Label s
mom Label s
mom Order a s
this Key
0 Int
64
    else do
      Label s
dad <- Slot (Order a) Label
-> Order a (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a s
Order a (PrimState (ST s))
p
      if Label s
mom Label s -> Label s -> Bool
forall a. Eq a => a -> a -> Bool
== Label s
dad then Label s -> Order a s -> ST s ()
forall s a. Label s -> Order a s -> ST s ()
rewind Label s
mom Order a s
p
      else Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
forall s a.
Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
rebalance Label s
mom Label s
mom Order a s
p Key
0 Int
64

  -- break up the family
  rebalance :: Label s -> Label s -> Order a s -> Word64 -> Int -> ST s ()
  rebalance :: Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
rebalance Label s
mom Label s
dad Order a s
this Key
k Int
j = Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Order a s -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a s
this) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
    Label s
guardian <- Slot (Order a) Label
-> Order a (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a s
Order a (PrimState (ST s))
this
    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Label s
mom Label s -> Label s -> Bool
forall a. Eq a => a -> a -> Bool
== Label s
guardian) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
      Field (Order a) Key -> Order a (PrimState (ST s)) -> Key -> ST s ()
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> a -> m ()
setField Field (Order a) Key
forall a. Field (Order a) Key
key Order a s
Order a (PrimState (ST s))
this Key
k
      Slot (Order a) Label
-> Order a (PrimState (ST s))
-> Label (PrimState (ST s))
-> ST s ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a s
Order a (PrimState (ST s))
this Label s
Label (PrimState (ST s))
dad
      Order a s
n <- Slot (Order a) (Order a)
-> Order a (PrimState (ST s)) -> ST s (Order a (PrimState (ST s)))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
next Order a s
Order a (PrimState (ST s))
this
      if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
forall s a.
Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
rebalance Label s
mom Label s
dad Order a s
n (Key
k Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
deltaU) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      else do
        Label s
stepdad <- Label (PrimState (ST s)) -> ST s (Label (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Label (PrimState m) -> m (Label (PrimState m))
Label.insertAfter Label s
Label (PrimState (ST s))
dad
        Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
forall s a.
Label s -> Label s -> Order a s -> Key -> Int -> ST s ()
rebalance Label s
mom Label s
stepdad Order a s
n Key
deltaU Int
logU

delete :: PrimMonad m => Order a (PrimState m) -> m ()
delete :: Order a (PrimState m) -> m ()
delete Order a (PrimState m)
this = ST (PrimState m) () -> m ()
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
this) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ NullPointerException -> ST (PrimState m) ()
forall a e. Exception e => e -> a
throw NullPointerException
NullPointerException
  Label (PrimState m)
mom <- Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this

  Order a (PrimState m)
p <- Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Order a (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
prev Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this
  Order a (PrimState m)
n <- Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Order a (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
next Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this

  Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
prev Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this Order a (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
  Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
next Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this Order a (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil

  Bool
x <- if Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
p then Bool -> ST (PrimState m) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do
    Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
next Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
p Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n
    Label (PrimState m)
pmom <- Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
p
    Bool -> ST (PrimState m) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Label (PrimState m)
mom Label (PrimState m) -> Label (PrimState m) -> Bool
forall a. Eq a => a -> a -> Bool
== Label (PrimState m)
pmom)

  Bool
y <- if Order a (PrimState m) -> Bool
forall (t :: * -> *) s. Struct t => t s -> Bool
isNil Order a (PrimState m)
n then Bool -> ST (PrimState m) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  else do
    Slot (Order a) (Order a)
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) ()
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> y (PrimState m) -> m ()
set Slot (Order a) (Order a)
forall a. Slot (Order a) (Order a)
prev Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
p
    Label (PrimState m)
nmom <- Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
n
    Bool -> ST (PrimState m) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Label (PrimState m)
mom Label (PrimState m) -> Label (PrimState m) -> Bool
forall a. Eq a => a -> a -> Bool
== Label (PrimState m)
nmom)

  Bool -> ST (PrimState m) () -> ST (PrimState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
x Bool -> Bool -> Bool
|| Bool
y) (ST (PrimState m) () -> ST (PrimState m) ())
-> ST (PrimState m) () -> ST (PrimState m) ()
forall a b. (a -> b) -> a -> b
$ Label (PrimState (ST (PrimState m))) -> ST (PrimState m) ()
forall (m :: * -> *). PrimMonad m => Label (PrimState m) -> m ()
Label.delete Label (PrimState m)
Label (PrimState (ST (PrimState m)))
mom
{-# INLINE delete #-}

logU :: Int
logU :: Int
logU = Int
64

loglogU :: Int
loglogU :: Int
loglogU = Int
6

deltaU :: Key
deltaU :: Key
deltaU = Key -> Int -> Key
forall a. Bits a => a -> Int -> a
unsafeShiftR Key
forall a. Bounded a => a
maxBound Int
loglogU -- U / log U

new :: PrimMonad m => a -> m (Order a (PrimState m))
new :: a -> m (Order a (PrimState m))
new a
a = ST (PrimState m) (Order a (PrimState m))
-> m (Order a (PrimState m))
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Order a (PrimState m))
 -> m (Order a (PrimState m)))
-> ST (PrimState m) (Order a (PrimState m))
-> m (Order a (PrimState m))
forall a b. (a -> b) -> a -> b
$ do
  Label (PrimState m)
l <- ST (PrimState m) (Label (PrimState m))
forall (m :: * -> *). PrimMonad m => m (Label (PrimState m))
Label.new
  Label (PrimState (ST (PrimState m)))
-> Key
-> a
-> Order a (PrimState (ST (PrimState m)))
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Order a (PrimState (ST (PrimState m))))
forall (m :: * -> *) a.
PrimMonad m =>
Label (PrimState m)
-> Key
-> a
-> Order a (PrimState m)
-> Order a (PrimState m)
-> m (Order a (PrimState m))
makeOrder Label (PrimState m)
Label (PrimState (ST (PrimState m)))
l (Key -> Int -> Key
forall a. Bits a => a -> Int -> a
unsafeShiftR Key
forall a. Bounded a => a
maxBound Int
1) a
a Order a (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil Order a (PrimState (ST (PrimState m)))
forall (t :: * -> *) s. Struct t => t s
Nil
{-# INLINE new #-}

keys :: PrimMonad m => Order a (PrimState m) -> m (Key, Key)
keys :: Order a (PrimState m) -> m (Key, Key)
keys Order a (PrimState m)
this = ST (PrimState m) (Key, Key) -> m (Key, Key)
forall (m :: * -> *) a. PrimMonad m => ST (PrimState m) a -> m a
st (ST (PrimState m) (Key, Key) -> m (Key, Key))
-> ST (PrimState m) (Key, Key) -> m (Key, Key)
forall a b. (a -> b) -> a -> b
$ do
  Label (PrimState m)
mom <- Slot (Order a) Label
-> Order a (PrimState (ST (PrimState m)))
-> ST (PrimState m) (Label (PrimState (ST (PrimState m))))
forall (m :: * -> *) (x :: * -> *) (y :: * -> *).
(PrimMonad m, Struct x, Struct y) =>
Slot x y -> x (PrimState m) -> m (y (PrimState m))
get Slot (Order a) Label
forall a. Slot (Order a) Label
parent Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this
  (,) (Key -> Key -> (Key, Key))
-> ST (PrimState m) Key -> ST (PrimState m) (Key -> (Key, Key))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field Label Key
-> Label (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field Label Key
Label.key Label (PrimState m)
Label (PrimState (ST (PrimState m)))
mom ST (PrimState m) (Key -> (Key, Key))
-> ST (PrimState m) Key -> ST (PrimState m) (Key, Key)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Field (Order a) Key
-> Order a (PrimState (ST (PrimState m))) -> ST (PrimState m) Key
forall (m :: * -> *) (x :: * -> *) a.
(PrimMonad m, Struct x) =>
Field x a -> x (PrimState m) -> m a
getField Field (Order a) Key
forall a. Field (Order a) Key
key Order a (PrimState m)
Order a (PrimState (ST (PrimState m)))
this
{-# INLINE keys #-}