1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
-- |
-- A Word64RangeMap is actually a sorted array of arrays
-- but lookup is done via binary search testing the range.
-- One way of implementing a sparse array i suppose.
module Word64RangeMap where
import Data.Word
import Data.Array.Unboxed
import qualified Data.Array.MArray as MA
import Data.Array.MArray (MArray(..))
import Debug.Trace
import Data.Array.IO
type OuterIndex = Word64
type Index = Word64
type InnerArray b = UArray Index b
-- convenient contraint kind
type RangeArray rangeArray m b = (IArray UArray b, MArray rangeArray (InnerArray b) m)
-- The RangeMap type, to be used with the above constraint
type RangeMap rangeArray b = rangeArray Index (InnerArray b)
-- | a sample RangeMap for easier debugging
getM :: IO (RangeMap IOArray Word8)
getM = newListArray (0,3) [ listArray (0,5) [0..5]
, listArray (15,20) [15..20]
, listArray (100,105) [100..105]
, listArray (106,107) [106..107]
]
lookupArray :: RangeArray ra m b => Index -> RangeMap ra b -> m (Either OuterIndex (OuterIndex,InnerArray b))
lookupArray i r = do
(zr,nr) <- getBounds r -- bounds of mutable range array
let (dr,mr) = (nr+1 - zr) `divMod` 2
lookupArrayHelper i r (zr+dr+mr) zr nr
lookupArrayHelper :: RangeArray ra m b => Index -> RangeMap ra b
-> OuterIndex{- current position -}
-> OuterIndex{- smallest possible -}
-> OuterIndex{- largest possible -}
-> m (Either OuterIndex (OuterIndex,InnerArray b))
lookupArrayHelper i ra pos min max = do
{- trace ("lookupArrayHelper " ++ show i ++ " "
++ "ra "
++ show pos ++ " "
++ show min ++ " "
++ show max) (return ()) -}
ca <- MA.readArray ra pos -- current array
let beforeOrAfter i (x,y) | i < x = LT
beforeOrAfter i (x,y) | i > y = GT
beforeOrAfter _ _ = EQ
avg a b = (a + b) `divMod` 2
isUnequalMod2 a b = if a `mod` 2 /= b `mod` 2 then 1 else 0
f a b recurse finish
= let (pos',r) = avg a b
u = isUnequalMod2 r (max - min) {- trace ("u = " ++ show t
++ " min=" ++ show min
++ " max=" ++ show max
++ " pos'=" ++ show pos'
++ " r=" ++ show r
) t -}
in if max - min + u > 1 && pos' /= pos then recurse pos' r else finish
s = "beforeOrAfter " ++ show i ++ " " ++ show (bounds ca) ++ " --> "
checkAndReturn pos = do
a <- MA.readArray ra pos
{- trace ("checkAndReturn " ++ show pos ++ " bounds a= " ++ show (bounds a)) (return ()) -}
case beforeOrAfter i (bounds a) of
EQ -> {- trace "EQ" $ -} return (Right (pos,a))
LT -> {- trace "LT" $ -} return (Left pos)
GT -> {- trace "GT" $ -} return (Left (pos+1))
case beforeOrAfter i (bounds ca) of
GT -> {- trace (s ++ "GT") $ -} f pos max (\pos' r -> lookupArrayHelper i ra (pos'+r) pos max) (checkAndReturn (pos + 1))
LT -> {- trace (s ++ "LT") $ -} f min pos (\pos' r -> lookupArrayHelper i ra pos' min pos) (checkAndReturn pos)
EQ -> {- trace (s ++ "EQ") $ -} return (Right (pos,ca))
-- | up to the caller to ensure the inserted array does not overlap with others
-- and also to ensure that sort is maintained
-- TODO: Does not grow array!
insertArrayNoCheck :: RangeArray ra m b => OuterIndex -> InnerArray b -> RangeMap ra b -> m ()
insertArrayNoCheck pos e ra = do
(z,n) <- MA.getBounds ra
flip mapM_ [n .. pos + 1] $ \j -> do
x <- readArray ra (j-1)
writeArray ra j x
writeArray ra pos e
insertWhereItGoes :: RangeArray ra m e => InnerArray e -> ra Index (InnerArray e) -> m (Either (OuterIndex, InnerArray e) ())
insertWhereItGoes e ra = do
let (i,j) = bounds e
(z,n) <- MA.getBounds ra
let inside x (low,hi) = x >= low && x <= hi
r <- lookupArray i ra
case r of
Left ii -> if ii+1 <= n
then do
y <- MA.readArray ra (ii+1)
if j `inside` bounds y
then return (Left (ii+1,y)) -- TODO, actually could shrink y or e
else Right <$> insertArrayNoCheck ii e ra
else Right <$> insertArrayNoCheck ii e ra
Right x -> return (Left x)
lookupInRangeMap k ra = do
b <- lookupArray k ra
case b of
Right (_,ar) -> return (Just (ar ! k))
Left _ -> return Nothing
|
