summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Data/Word64RangeMap/Unboxed.hs195
1 files changed, 195 insertions, 0 deletions
diff --git a/src/Data/Word64RangeMap/Unboxed.hs b/src/Data/Word64RangeMap/Unboxed.hs
new file mode 100644
index 00000000..7faacb88
--- /dev/null
+++ b/src/Data/Word64RangeMap/Unboxed.hs
@@ -0,0 +1,195 @@
1{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE TupleSections #-}
5-- |
6-- A Word64RangeMap is actually a sorted array of arrays
7-- but lookup is done via binary search testing the range.
8-- One way of implementing a sparse array i suppose.
9module Data.Word64RangeMap.Unboxed where
10
11import Data.Word
12import Data.Array.Unboxed
13import qualified Data.Array.MArray as MA
14import Data.Array.MArray (MArray(..))
15import qualified Data.Array.Base as Base
16import Data.Reference
17import Debug.Trace
18import Control.Concurrent.STM
19import Control.Concurrent.STM.TArray
20import Data.Array.IO
21import Data.IORef
22
23type OuterIndex = Int
24type Index = Word64
25type InnerArray b = UArray Index b
26
27-- | Although this type includes a parameter for index, the code assumes bounds start at 0
28-- and the index has 'Integral', and 'Num' instances.
29newtype RefArray r ma i e = RefArray (r (ma i e))
30
31-- convenient contraint kind
32type RangeArray rangeArray m b ref = (IArray UArray b, MArray rangeArray (InnerArray b) m, Reference ref m)
33-- The RangeMap type, to be used with the above constraint
34type RangeMap rangeArray b ref = RefArray ref rangeArray OuterIndex (InnerArray b)
35
36insertArrayAt :: (MA.MArray ma e m, Reference r m, Ix i, Num i, Integral i) => RefArray r ma i e -> i -> e -> m ()
37insertArrayAt (RefArray ref) pos e = do
38 ma <- readRef ref
39 (0,n) <- MA.getBounds ma -- irrefutable pattern, assume array starts at 0
40 (esBefore,esAt) <- splitAt (fromIntegral pos) <$> (getElems ma)
41 newMA <- MA.newListArray (0,n+1) (esBefore ++ [e] ++ esAt)
42 writeRef ref newMA
43
44deleteArrayAt :: (MA.MArray ma e m, Reference r m, Ix i, Num i, Integral i) => RefArray r ma i e -> i -> m ()
45deleteArrayAt (RefArray ref) pos = do
46 ma <- readRef ref
47 (0,n) <- MA.getBounds ma -- irrefutable pattern, assume array starts at 0
48 (esBefore,esAt) <- splitAt (fromIntegral pos) <$> getElems ma
49 newMA <- MA.newListArray (0,n-1) (esBefore ++ drop 1 esAt)
50 writeRef ref newMA
51
52
53-- forall (ma :: * -> * -> *) i e (r :: * -> *) (m :: * -> *).
54readRefArray :: Reference r m => RefArray r ma i e -> m (ma i e)
55readRefArray (RefArray x) = readRef x
56
57-- forall (ma :: * -> * -> *) i e (r :: * -> *) (m :: * -> *).
58writeRefArray :: Reference r m => RefArray r ma i e -> ma i e -> m ()
59writeRefArray (RefArray x) y = writeRef x y
60
61{-
62instance (Reference r m, MArray ma e m) => MArray (RefArray r ma) e m where
63 getBounds (RefArray r) = readRef r >>= Base.getBounds
64 getNumElements (RefArray r) = readRef r >>= Base.getNumElements
65 unsafeRead (RefArray r) i = readRef r >>= \x -> Base.unsafeRead x i
66 unsafeWrite (RefArray r) i e = modifyRef r (\x -> Base.unsafeWrite x i e >> return (x,()))
67-}
68
69emptySTMRangeMap :: STM (RangeMap TArray a TVar)
70emptySTMRangeMap = RefArray <$>
71 (newTVar =<<
72 newListArray (0,-1) [])
73
74-- | a sample RangeMap for easier debugging
75getX :: IO (RangeMap IOArray Word8 IORef)
76getX = RefArray <$>
77 (newIORef =<<
78 newListArray (0,2)
79 [ listArray (15,20) [15..20]
80 , listArray (100,105) [100..105]
81 , listArray (106,107) [106..107]
82 ])
83-- | a sample RangeMap for easier debugging
84getY :: IO (RangeMap IOArray Word8 IORef)
85getY = RefArray <$>
86 (newIORef =<<
87 newListArray (0,3)
88 [ listArray (0,5) [0..5]
89 , listArray (15,20) [15..20]
90 , listArray (100,105) [100..105]
91 , listArray (106,107) [106..107]
92 ])
93
94lookupArray :: RangeArray ra m b ref => Index -> RangeMap ra b ref -> m (Either OuterIndex (OuterIndex,InnerArray b))
95lookupArray i r = do
96 ra <- readRefArray r
97 (zr,nr) <- getBounds ra -- bounds of mutable range array
98 let (dr,mr) = (nr+1 - zr) `divMod` 2
99 lookupArrayHelper i r (zr+dr+mr-1) zr nr
100
101lookupArrayHelper :: RangeArray ra m b ref => Index -> RangeMap ra b ref
102 -> OuterIndex{- current position -}
103 -> OuterIndex{- smallest possible -}
104 -> OuterIndex{- largest possible -}
105 -> m (Either OuterIndex (OuterIndex,InnerArray b))
106lookupArrayHelper i r pos min max = do
107 {- trace ("lookupArrayHelper " ++ show i ++ " "
108 ++ "ra "
109 ++ show pos ++ " "
110 ++ show min ++ " "
111 ++ show max) (return ()) -}
112 ra <- readRefArray r
113 ca <- MA.readArray ra pos -- current array
114 let beforeOrAfter i (x,y) | i < x = LT
115 beforeOrAfter i (x,y) | i > y = GT
116 beforeOrAfter _ _ = EQ
117 avg a b = (a + b) `divMod` 2
118 isUnequalMod2 a b = if a `mod` 2 /= b `mod` 2 then 1 else 0
119 f a b recurse finish
120 = let (pos',r) = avg a b
121 u = isUnequalMod2 r (max - min) {- trace ("u = " ++ show t
122 ++ " min=" ++ show min
123 ++ " max=" ++ show max
124 ++ " pos'=" ++ show pos'
125 ++ " r=" ++ show r
126 ) t -}
127 in if max - min + u > 1 && pos' /= pos then recurse pos' r else finish
128 s = "beforeOrAfter " ++ show i ++ " " ++ show (bounds ca) ++ " --> "
129 checkAndReturn pos = do
130 boundsRA <- getBounds ra
131 case beforeOrAfter pos boundsRA of
132 EQ -> do
133 a <- MA.readArray ra pos
134 {- trace ("checkAndReturn " ++ show pos ++ " bounds a= " ++ show (bounds a)) (return ()) -}
135 case beforeOrAfter i (bounds a) of
136 EQ -> {- trace "EQ" $ -} return (Right (pos,a))
137 LT -> {- trace "LT" $ -} return (Left pos)
138 GT -> {- trace "GT" $ -} return (Left (pos+1))
139 LT -> {- trace "LT" $ -} return (Left pos)
140 GT -> {- trace "GT" $ -} return (Left (pos+1))
141 case beforeOrAfter i (bounds ca) of
142 GT -> {- trace (s ++ "GT") $ -} f pos max (\pos' r' -> lookupArrayHelper i r (pos'+r') pos max) (checkAndReturn (pos + 1))
143 LT -> {- trace (s ++ "LT") $ -} f min pos (\pos' r' -> lookupArrayHelper i r pos' min pos) (checkAndReturn pos)
144 EQ -> {- trace (s ++ "EQ") $ -} return (Right (pos,ca))
145
146insertWhereItGoes :: RangeArray ra m e ref => InnerArray e -> RangeMap ra e ref -> m (Either (OuterIndex, InnerArray e) ())
147insertWhereItGoes e r = do
148 let (i,j) = bounds e
149 outerArray <- readRefArray r
150 (outerZ,outerN) <- MA.getBounds outerArray
151 let inside x (low,hi) = x >= low && x <= hi -- flip inRange
152 lr <- lookupArray i r
153 case lr of
154 Left ii ->
155 trace "(insertWhereItGoes) Left ii case"
156 $if ii <= outerN -- is there a next array?
157 then do
158 y <- MA.readArray outerArray (ii)
159 let boundsy = show (bounds y)
160 insideStr = show j ++ " inside " ++ boundsy
161 outsideStr = show j ++ " outside " ++ boundsy
162 if j `inside` bounds y -- does the final bound of inserted array overlap next array?
163 then trace insideStr $ return (Left (ii,y)) -- TODO, actually could shrink y or e
164 else trace outsideStr $ Right <$> insertArrayAt r ii e
165 else Right <$> insertArrayAt r ii e
166 Right x ->
167 trace "(insertWhereItGoes) Right x case"
168 $return (Left x)
169
170lookupInRangeMap :: RangeArray ra m e ref => Index -> RangeMap ra e ref -> m (Maybe e)
171lookupInRangeMap k r = do
172 b <- lookupArray k r
173 case b of
174 Right (_,ar) -> return (Just (ar ! k))
175 Left _ -> return Nothing
176
177
178deleteRange :: RangeArray ra m e ref => (Index,Index)
179 -> RangeMap ra e ref
180 -> m (Either OuterIndex (OuterIndex,InnerArray e))
181
182deleteRange (z,n) r = do
183 result <- lookupArray z r
184 case result of
185 Left _ -> return result
186 Right (outerIndex,a) | bounds a /= (z,n) -> return (Left outerIndex)
187 Right (outerIndex,a) | bounds a == (z,n) -> do
188 outerArray <- readRefArray r
189 (zz,nn) <- getBounds outerArray
190 as <- map (\(i,e) -> (if i > outerIndex then i - 1 else i, e))
191 . filter ((/=outerIndex) . fst)
192 <$> getAssocs outerArray
193 mutAr <- MA.newListArray (zz,nn-1) (map snd as)
194 writeRefArray r mutAr
195 return result
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:26:04 +0000