module Data.ArrayBZ.Diff (
IOToDiffArray,
DiffArray,
DiffUArray,
module Data.ArrayBZ.Internals.IArray,
newDiffArray, readDiffArray, replaceDiffArray
)
where
import Data.Ix
import System.IO.Unsafe ( unsafePerformIO )
import Control.Exception ( evaluate )
import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, readMVar )
import Data.ArrayBZ.Internals.IArray
import Data.ArrayBZ.Internals.MArray
import Data.ArrayBZ.Boxed
import Data.ArrayBZ.Unboxed
import Data.HasDefaultValue
import Data.Unboxed
newtype IOToDiffArray a i e =
DiffArray {varDiffArray :: MVar (DiffArrayData a i e)}
data DiffArrayData a i e = Current (a i e)
| Diff (IOToDiffArray a i e) [(Int, e)]
type DiffArray = IOToDiffArray IOArray
type DiffUArray = IOToDiffArray IOUArray
instance HasBounds a => HasBounds (IOToDiffArray a) where
bounds a = unsafePerformIO $ boundsDiffArray a
instance IArray DiffArray e where
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray1` ies
instance (Unboxed e) => IArray DiffUArray e where
unsafeArray lu ies = unsafePerformIO $ newDiffArray lu ies
unsafeAt a i = unsafePerformIO $ a `readDiffArray` i
unsafeReplace a ies = unsafePerformIO $ a `replaceDiffArray2` ies
instance (Ix i, Show i, Show e) => Show (DiffArray i e) where
showsPrec = showsIArray
instance (Ix i, Show i, Show e, Unboxed e, HasDefaultValue e) => Show (DiffUArray i e) where
showsPrec = showsIArray
instance (Ix i, Eq i, Eq e) => Eq (DiffArray i e) where
(==) = eqIArray
instance (Ix i, Ord i, Ord e) => Ord (DiffArray i e) where
compare = cmpIArray
instance (Ix i, Eq i, Eq e, Unboxed e, HasDefaultValue e) => Eq (DiffUArray i e) where
(==) = eqIArray
instance (Ix i, Ord i, Ord e, Unboxed e, HasDefaultValue e) => Ord (DiffUArray i e) where
compare = cmpIArray
newDiffArray :: (MArray a e IO, Ix i)
=> (i,i)
-> [(Int, e)]
-> IO (IOToDiffArray a i e)
newDiffArray (l,u) ies = do
a <- newArray_ (l,u)
sequence_ [unsafeWrite a i e | (i, e) <- ies]
var <- newMVar (Current a)
return (DiffArray var)
readDiffArray :: (MArray a e IO, Ix i)
=> IOToDiffArray a i e
-> Int
-> IO e
a `readDiffArray` i = do
d <- readMVar (varDiffArray a)
case d of
Current a' -> unsafeRead a' i
Diff a' ies -> maybe (readDiffArray a' i) return (lookup i ies)
replaceDiffArray :: (MArray a e IO, Ix i)
=> IOToDiffArray a i e
-> [(Int, e)]
-> IO (IOToDiffArray a i e)
a `replaceDiffArray` ies = do
d <- takeMVar (varDiffArray a)
case d of
Current a' -> case ies of
[] -> do
putMVar (varDiffArray a) d
return a
_:_ -> do
diff <- sequence [do e <- unsafeRead a' i; return (i, e)
| (i, _) <- ies]
sequence_ [unsafeWrite a' i e | (i, e) <- ies]
var' <- newMVar (Current a')
putMVar (varDiffArray a) (Diff (DiffArray var') diff)
return (DiffArray var')
Diff _ _ -> do
putMVar (varDiffArray a) d
a' <- thawDiffArray a
sequence_ [unsafeWrite a' i e | (i, e) <- ies]
var' <- newMVar (Current a')
return (DiffArray var')
replaceDiffArray1 :: (MArray a e IO, Ix i)
=> IOToDiffArray a i e
-> [(Int, e)]
-> IO (IOToDiffArray a i e)
a `replaceDiffArray1` ies = do
mapM_ (evaluate . fst) ies
a `replaceDiffArray` ies
replaceDiffArray2 :: (MArray a e IO, Ix i)
=> IOToDiffArray a i e
-> [(Int, e)]
-> IO (IOToDiffArray a i e)
a `replaceDiffArray2` ies = do
mapM_ (\(a,b) -> do evaluate a; evaluate b) ies
a `replaceDiffArray` ies
boundsDiffArray :: (HasBounds a, Ix ix)
=> IOToDiffArray a ix e
-> IO (ix,ix)
boundsDiffArray a = do
d <- readMVar (varDiffArray a)
case d of
Current a' -> return (bounds a')
Diff a' _ -> boundsDiffArray a'
freezeDiffArray :: (MArray a e IO, Ix ix)
=> a ix e
-> IO (IOToDiffArray a ix e)
freezeDiffArray a = do
lu <- getBounds a
a' <- newArray_ lu
sequence_ [unsafeRead a i >>= unsafeWrite a' i | i <- [0 .. rangeSize lu 1]]
var <- newMVar (Current a')
return (DiffArray var)
unsafeFreezeDiffArray :: (MArray a e IO, Ix ix)
=> a ix e
-> IO (IOToDiffArray a ix e)
unsafeFreezeDiffArray a = do
var <- newMVar (Current a)
return (DiffArray var)
thawDiffArray :: (MArray a e IO, Ix ix)
=> IOToDiffArray a ix e
-> IO (a ix e)
thawDiffArray a = do
d <- readMVar (varDiffArray a)
case d of
Current a' -> do
lu <- getBounds a'
a'' <- newArray_ lu
sequence_ [unsafeRead a' i >>= unsafeWrite a'' i | i <- [0 .. rangeSize lu 1]]
return a''
Diff a' ies -> do
a'' <- thawDiffArray a'
sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
return a''
unsafeThawDiffArray :: (MArray a e IO, Ix ix)
=> IOToDiffArray a ix e
-> IO (a ix e)
unsafeThawDiffArray a = do
d <- readMVar (varDiffArray a)
case d of
Current a' -> return a'
Diff a' ies -> do
a'' <- unsafeThawDiffArray a'
sequence_ [unsafeWrite a'' i e | (i, e) <- ies]
return a''