3425

1 
module Store(


2 
ElemIndex(),


3 
MStore(),


4 
IStore(),


5 
newStore,


6 
addElem,


7 
removeElem,


8 
readElem,


9 
writeElem,


10 
modifyElem,


11 
firstIndex,


12 
withIStore,


13 
withIStore2,


14 
(!),


15 
indices


16 
) where


17 


18 
import qualified Data.Array.IArray as IA


19 
import qualified Data.Array.IO as IOA


20 
import qualified Data.IntSet as IntSet


21 
import Data.IORef


22 
import Control.Monad


23 


24 


25 
newtype ElemIndex = ElemIndex Int

3435

26 
deriving (Eq, Show, Read)

3425

27 
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))


28 
newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)


29 


30 


31 
firstIndex :: ElemIndex


32 
firstIndex = ElemIndex 0


33 


34 
 MStore code


35 
initialSize :: Int


36 
initialSize = 10


37 


38 


39 
growFunc :: Int > Int


40 
growFunc a = a * 3 `div` 2


41 


42 


43 
newStore :: IO (MStore e)


44 
newStore = do


45 
newar < IOA.newArray_ (0, initialSize  1)


46 
new < newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize  1], newar)


47 
return (MStore new)


48 


49 


50 
growStore :: MStore e > IO ()


51 
growStore (MStore ref) = do


52 
(busyElems, freeElems, arr) < readIORef ref


53 
(_, m') < IOA.getBounds arr


54 
let newM' = growFunc (m' + 1)  1


55 
newArr < IOA.newArray_ (0, newM')


56 
sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i  i < [0..m']]


57 
writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr)


58 


59 


60 
growIfNeeded :: MStore e > IO ()


61 
growIfNeeded m@(MStore ref) = do


62 
(_, freeElems, _) < readIORef ref


63 
when (IntSet.null freeElems) $ growStore m


64 


65 


66 
addElem :: MStore e > e > IO ElemIndex


67 
addElem m@(MStore ref) element = do


68 
growIfNeeded m


69 
(busyElems, freeElems, arr) < readIORef ref


70 
let (n, freeElems') = IntSet.deleteFindMin freeElems


71 
IOA.writeArray arr n element


72 
writeIORef ref (IntSet.insert n busyElems, freeElems', arr)


73 
return $ ElemIndex n


74 


75 


76 
removeElem :: MStore e > ElemIndex > IO ()


77 
removeElem (MStore ref) (ElemIndex n) = do


78 
(busyElems, freeElems, arr) < readIORef ref


79 
IOA.writeArray arr n undefined


80 
writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)


81 


82 


83 
readElem :: MStore e > ElemIndex > IO e


84 
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) > IOA.readArray arr n


85 


86 


87 
writeElem :: MStore e > ElemIndex > e > IO ()


88 
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) > IOA.writeArray arr n el


89 


90 


91 
modifyElem :: MStore e > (e > e) > ElemIndex > IO ()


92 
modifyElem (MStore ref) f (ElemIndex n) = do


93 
(_, _, arr) < readIORef ref


94 
IOA.readArray arr n >>= (IOA.writeArray arr n) . f


95 


96 


97 
 A way to use see MStore elements in pure code via IStore


98 
m2i :: MStore e > IO (IStore e)


99 
m2i (MStore ref) = do


100 
(a, _, c') < readIORef ref


101 
c < IOA.unsafeFreeze c'


102 
return $ IStore (a, c)


103 


104 
withIStore :: MStore e > (IStore e > a) > IO a


105 
withIStore m f = liftM f (m2i m)


106 


107 


108 
withIStore2 :: MStore e1 > MStore e2 > (IStore e1 > IStore e2 > a) > IO a


109 
withIStore2 m1 m2 f = do


110 
i1 < m2i m1


111 
i2 < m2i m2


112 
return $ f i1 i2


113 


114 


115 
 IStore code


116 
(!) :: IStore e > ElemIndex > e


117 
(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i


118 


119 
indices :: IStore e > [ElemIndex]


120 
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy
