#if __GLASGOW_HASKELL__ >= 708
#endif
module Data.Vector.Map.Deamortized
( Map
, empty
, null
, singleton
, lookup
, insert
, fromList
) where
import Control.Applicative hiding (empty)
import Data.Bits
import Data.Foldable as Foldable
import qualified Data.List as List
import Data.Vector.Array
import qualified Data.Map.Strict as Map
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as GM
import GHC.Prim (RealWorld)
import Prelude hiding (null, lookup)
import System.IO.Unsafe as Unsafe
_THRESHOLD :: Int
_THRESHOLD = 1000
data Map k a = Map !(Map.Map k a) !(LA k a)
data LA k a
= M0
| M1 !(Array k) !(Array a)
| M2 !(Array k) !(Array a)
!(Array k) !(Array a)
!Int !Int
!(MArray RealWorld k) !(MArray RealWorld a)
!(LA k a)
| M3 !(Array k) !(Array a)
!(Array k) !(Array a)
!(Array k) !(Array a)
!Int !Int
!(MArray RealWorld k) !(MArray RealWorld a)
!(LA k a)
#if __GLASGOW_HASKELL__ >= 708
type role Map nominal nominal
#endif
instance (Show (Arr v v), Show (Arr k k)) => Show (LA k v) where
showsPrec _ M0 = showString "M0"
showsPrec d (M1 ka a) = showParen (d > 10) $
showString "M1 " . showsPrec 11 ka . showChar ' ' . showsPrec 11 a
showsPrec d (M2 ka a kb b ra rb _ _ xs) = showParen (d > 10) $
showString "M2 " .
showsPrec 11 ka . showChar ' ' . showsPrec 11 a . showChar ' ' .
showsPrec 11 kb . showChar ' ' . showsPrec 11 b . showChar ' ' .
showsPrec 11 ra . showChar ' ' . showsPrec 11 rb . showString " _ _ " .
showsPrec 11 xs
showsPrec d (M3 ka a kb b kc c rb rc _ _ xs) = showParen (d > 10) $
showString "M3 " .
showsPrec 11 ka . showChar ' ' . showsPrec 11 a . showChar ' ' .
showsPrec 11 kb . showChar ' ' . showsPrec 11 b . showChar ' ' .
showsPrec 11 kc . showChar ' ' . showsPrec 11 c . showChar ' ' .
showsPrec 11 rb . showChar ' ' . showsPrec 11 rc . showString " _ _ " .
showsPrec 11 xs
instance (Show (Arr v v), Show (Arr k k), Show k, Show v) => Show (Map k v) where
showsPrec d (Map n l) = showParen (d > 10) $
showString "Map " . showsPrec 11 n . showChar ' ' . showsPrec 11 l
null :: Map k v -> Bool
null (Map n M0) = Map.null n
null _ = False
empty :: Map k v
empty = Map Map.empty M0
singleton :: (Arrayed k, Arrayed v) => k -> v -> Map k v
singleton k v = Map (Map.singleton k v) M0
lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v
lookup !k (Map m0 la) = case Map.lookup k m0 of
Nothing -> go la
mv -> mv
where
go M0 = Nothing
go (M1 ka va) = lookup1 k ka va Nothing
go (M2 ka va kb vb _ _ _ _ m) = lookup1 k ka va $ lookup1 k kb vb $ go m
go (M3 ka va kb vb kc vc _ _ _ _ m) = lookup1 k ka va $ lookup1 k kb vb $ lookup1 k kc vc $ go m
lookup1 :: (Ord k, Arrayed k, Arrayed v) => k -> Array k -> Array v -> Maybe v -> Maybe v
lookup1 k ks vs r
| j <- search (\i -> ks G.! i >= k) 0 (G.length ks 1)
, ks G.! j == k = Just $ vs G.! j
| otherwise = r
insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v
insert k0 v0 (Map m0 xs0)
| n0 <= _THRESHOLD = Map (Map.insert k0 v0 m0) xs0
| otherwise = Map Map.empty $ unsafeDupablePerformIO $ inserts (G.fromListN n0 (Map.keys m0)) (G.fromListN n0 (Foldable.toList m0)) xs0
where
n0 = Map.size m0
inserts ka a M0 = return $ M1 ka a
inserts ka a (M1 kb b) = do
let n = G.length ka + G.length kb
kab <- GM.basicUnsafeNew n
ab <- GM.basicUnsafeNew n
(ra,rb) <- steps ka a kb b 0 0 kab ab
return $ M2 ka a kb b ra rb kab ab M0
inserts ka a (M2 kb b kc c rb rc kbc bc xs) = do
(rb',rc') <- steps kb b kc c rb rc kbc bc
M3 ka a kb b kc c rb' rc' kbc bc <$> stepTail xs
inserts ka a (M3 kb b _ _ _ _ _ _ kcd cd xs) = do
let n = G.length ka + G.length kb
kab <- GM.basicUnsafeNew n
ab <- GM.basicUnsafeNew n
(ra,rb) <- steps ka a kb b 0 0 kab ab
kcd' <- G.unsafeFreeze kcd
cd' <- G.unsafeFreeze cd
M2 ka a kb b ra rb kab ab <$> inserts kcd' cd' xs
stepTail (M2 kx x ky y rx ry kxy xy xs) = do
(rx',ry') <- steps kx x ky y rx ry kxy xy
M2 kx x ky y rx' ry' kxy xy <$> stepTail xs
stepTail (M3 kx x ky y kz z ry rz kyz yz xs) = do
(ry',rz') <- steps ky y kz z ry rz kyz yz
M3 kx x ky y kz z ry' rz' kyz yz <$> stepTail xs
stepTail m = return m
steps :: (Ord k, Arrayed k, Arrayed v) => Array k -> Array v -> Array k -> Array v -> Int -> Int -> MArray RealWorld k -> MArray RealWorld v -> IO (Int, Int)
steps ka a kb b ra0 rb0 kab ab = go ra0 rb0 where
n = min (ra0 + rb0 + _THRESHOLD) (GM.length kab)
na = G.length ka
nb = G.length kb
go !ra !rb
| r >= n = return (ra, rb)
| ra == na = do
k <- G.basicUnsafeIndexM kb rb
v <- G.basicUnsafeIndexM b rb
GM.basicUnsafeWrite kab r k
GM.basicUnsafeWrite ab r v
go ra (rb + 1)
| rb == nb = do
k <- G.basicUnsafeIndexM ka ra
v <- G.basicUnsafeIndexM a ra
GM.basicUnsafeWrite kab r k
GM.basicUnsafeWrite ab r v
go (ra + 1) rb
| otherwise = do
k1 <- G.basicUnsafeIndexM ka ra
k2 <- G.basicUnsafeIndexM kb rb
case compare k1 k2 of
LT -> do
v <- G.basicUnsafeIndexM a ra
GM.basicUnsafeWrite kab r k1
GM.basicUnsafeWrite ab r v
go (ra + 1) rb
EQ -> do
v <- G.basicUnsafeIndexM a ra
GM.basicUnsafeWrite kab r k1
GM.basicUnsafeWrite ab r v
go (ra + 1) (rb + 1)
GT -> do
v <- G.basicUnsafeIndexM b rb
GM.basicUnsafeWrite kab r k2
GM.basicUnsafeWrite ab r v
go ra (rb + 1)
where r = ra + rb
fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v
fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs
search :: (Int -> Bool) -> Int -> Int -> Int
search p = go where
go l h
| l == h = l
| p m = go l m
| otherwise = go (m+1) h
where hml = h l
m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6