1 files changed, 110 insertions, 0 deletions

diff --git a/src/Data/Word64RangeMap.hs b/src/Data/Word64RangeMap.hs
new file mode 100644
index 00000000..141feb8c
--- /dev/null
+++ b/src/Data/Word64RangeMap.hs
@@ -0,0 +1,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