From 16851ba2417933dd83ee1e7b91964e7e58b78d85 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Wed, 23 May 2018 07:05:35 +0000 Subject: Word64Rangemap fixes and improvements --- src/Data/Word64RangeMap.hs | 170 ++++++++++++++++++++++++++++++++------------- 1 file changed, 121 insertions(+), 49 deletions(-) (limited to 'src/Data') diff --git a/src/Data/Word64RangeMap.hs b/src/Data/Word64RangeMap.hs index 141feb8c..b5cbe9d1 100644 --- a/src/Data/Word64RangeMap.hs +++ b/src/Data/Word64RangeMap.hs @@ -1,52 +1,102 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} -- | -- 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 +module Data.Word64RangeMap where import Data.Word import Data.Array.Unboxed import qualified Data.Array.MArray as MA import Data.Array.MArray (MArray(..)) - +import qualified Data.Array.Base as Base +import Data.Reference import Debug.Trace import Data.Array.IO +import Data.IORef -type OuterIndex = Word64 +type OuterIndex = Int type Index = Word64 type InnerArray b = UArray Index b + +-- | Although this type includes a parameter for index, the code assumes bounds start at 0 +-- and the index has 'Integral', and 'Num' instances. +newtype RefArray r ma i e = RefArray (r (ma i e)) + -- convenient contraint kind -type RangeArray rangeArray m b = (IArray UArray b, MArray rangeArray (InnerArray b) m) +type RangeArray rangeArray m b ref = (IArray UArray b, MArray rangeArray (InnerArray b) m, Reference ref m) -- The RangeMap type, to be used with the above constraint -type RangeMap rangeArray b = rangeArray Index (InnerArray b) +type RangeMap rangeArray b ref = RefArray ref rangeArray OuterIndex (InnerArray b) + +insertArrayAt :: (MA.MArray ma e m, Reference r m, Ix i, Num i, Integral i) => RefArray r ma i e -> i -> e -> m () +insertArrayAt (RefArray ref) pos e = do + ma <- readRef ref + (0,n) <- MA.getBounds ma -- irrefutable pattern, assume array starts at 0 + (esBefore,esAt) <- splitAt (fromIntegral pos) <$> (getElems ma) + newMA <- MA.newListArray (0,n+1) (esBefore ++ [e] ++ esAt) + writeRef ref newMA +deleteArrayAt :: (MA.MArray ma e m, Reference r m, Ix i, Num i, Integral i) => RefArray r ma i e -> i -> m () +deleteArrayAt (RefArray ref) pos = do + ma <- readRef ref + (0,n) <- MA.getBounds ma -- irrefutable pattern, assume array starts at 0 + (esBefore,esAt) <- splitAt (fromIntegral pos) <$> getElems ma + newMA <- MA.newListArray (0,n-1) (esBefore ++ drop 1 esAt) + writeRef ref newMA + +readRefArray (RefArray x) = readRef x +writeRefArray (RefArray x) y = writeRef x y + +{- +instance (Reference r m, MArray ma e m) => MArray (RefArray r ma) e m where + getBounds (RefArray r) = readRef r >>= Base.getBounds + getNumElements (RefArray r) = readRef r >>= Base.getNumElements + unsafeRead (RefArray r) i = readRef r >>= \x -> Base.unsafeRead x i + unsafeWrite (RefArray r) i e = modifyRef r (\x -> Base.unsafeWrite x i e >> return (x,())) +-} + +-- | a sample RangeMap for easier debugging +getX :: IO (RangeMap IOArray Word8 IORef) +getX = RefArray <$> + (newIORef =<< + newListArray (0,2) + [ listArray (15,20) [15..20] + , listArray (100,105) [100..105] + , listArray (106,107) [106..107] + ]) -- | a sample RangeMap for easier debugging -getM :: IO (RangeMap IOArray Word8) -getM = newListArray (0,3) [ listArray (0,5) [0..5] +getY :: IO (RangeMap IOArray Word8 IORef) +getY = RefArray <$> + (newIORef =<< + 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 :: RangeArray ra m b ref => Index -> RangeMap ra b ref -> m (Either OuterIndex (OuterIndex,InnerArray b)) lookupArray i r = do - (zr,nr) <- getBounds r -- bounds of mutable range array + ra <- readRefArray r + (zr,nr) <- getBounds ra -- 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 +lookupArrayHelper :: RangeArray ra m b ref => Index -> RangeMap ra b ref -> OuterIndex{- current position -} -> OuterIndex{- smallest possible -} -> OuterIndex{- largest possible -} -> m (Either OuterIndex (OuterIndex,InnerArray b)) -lookupArrayHelper i ra pos min max = do +lookupArrayHelper i r pos min max = do {- trace ("lookupArrayHelper " ++ show i ++ " " ++ "ra " ++ show pos ++ " " ++ show min ++ " " ++ show max) (return ()) -} + ra <- readRefArray r ca <- MA.readArray ra pos -- current array let beforeOrAfter i (x,y) | i < x = LT beforeOrAfter i (x,y) | i > y = GT @@ -55,8 +105,8 @@ lookupArrayHelper i ra pos min max = do 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 + u = isUnequalMod2 r (max - min) {- trace ("u = " ++ show t + ++ " min=" ++ show min ++ " max=" ++ show max ++ " pos'=" ++ show pos' ++ " r=" ++ show r @@ -64,47 +114,69 @@ lookupArrayHelper i ra pos min max = do 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)) + boundsRA <- getBounds ra + case beforeOrAfter pos boundsRA of + EQ -> 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)) 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) + GT -> {- trace (s ++ "GT") $ -} f pos max (\pos' r' -> lookupArrayHelper i r (pos'+r') pos max) (checkAndReturn (pos + 1)) + LT -> {- trace (s ++ "LT") $ -} f min pos (\pos' r' -> lookupArrayHelper i r 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 +insertWhereItGoes :: RangeArray ra m e ref => InnerArray e -> RangeMap ra e ref -> m (Either (OuterIndex, InnerArray e) ()) +insertWhereItGoes e r = 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 + outerArray <- readRefArray r + (outerZ,outerN) <- MA.getBounds outerArray + let inside x (low,hi) = x >= low && x <= hi -- flip inRange + lr <- lookupArray i r + case lr of + Left ii -> + trace "(insertWhereItGoes) Left ii case" + $if ii <= outerN -- is there a next array? 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 + y <- MA.readArray outerArray (ii) + let boundsy = show (bounds y) + insideStr = show j ++ " inside " ++ boundsy + outsideStr = show j ++ " outside " ++ boundsy + if j `inside` bounds y -- does the final bound of inserted array overlap next array? + then trace insideStr $ return (Left (ii,y)) -- TODO, actually could shrink y or e + else trace outsideStr $ Right <$> insertArrayAt r ii e + else Right <$> insertArrayAt r ii e + Right x -> + trace "(insertWhereItGoes) Right x case" + $return (Left x) + +lookupInRangeMap :: RangeArray ra m e ref => Index -> RangeMap ra e ref -> m (Maybe e) +lookupInRangeMap k r = do + b <- lookupArray k r case b of Right (_,ar) -> return (Just (ar ! k)) Left _ -> return Nothing + + +deleteRange :: RangeArray ra m e ref => (Index,Index) + -> RangeMap ra e ref + -> m (Either OuterIndex (OuterIndex,InnerArray e)) + +deleteRange (z,n) r = do + result <- lookupArray z r + case result of + Left _ -> return result + Right (outerIndex,a) | bounds a /= (z,n) -> return (Left outerIndex) + Right (outerIndex,a) | bounds a == (z,n) -> do + outerArray <- readRefArray r + (zz,nn) <- getBounds outerArray + as <- map (\(i,e) -> (if i > outerIndex then i - 1 else i, e)) + . filter ((/=outerIndex) . fst) + <$> getAssocs outerArray + mutAr <- MA.newListArray (zz,nn-1) (map snd as) + writeRefArray r mutAr + return result -- cgit v1.2.3