gameServer/Store.hs
author sheepluva
Mon, 01 Nov 2010 03:05:44 +0100
changeset 4076 7ca17cb94992
parent 3901 124b4755914b
permissions -rw-r--r--
we had it with you intolerant portals\!
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3747
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     1
module Store(
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     2
    ElemIndex(),
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     3
    MStore(),
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     4
    IStore(),
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     5
    newStore,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     6
    addElem,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     7
    removeElem,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     8
    readElem,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
     9
    writeElem,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    10
    modifyElem,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    11
    elemExists,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    12
    firstIndex,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    13
    indicesM,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    14
    withIStore,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    15
    withIStore2,
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    16
    (!),
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    17
    indices
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    18
    ) where
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    19
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    20
import qualified Data.Array.IArray as IA
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    21
import qualified Data.Array.IO as IOA
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    22
import qualified Data.IntSet as IntSet
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    23
import Data.IORef
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    24
import Control.Monad
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    25
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    26
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    27
newtype ElemIndex = ElemIndex Int
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    28
    deriving (Eq, Show, Read, Ord)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    29
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    30
newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    31
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    32
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    33
firstIndex :: ElemIndex
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    34
firstIndex = ElemIndex 0
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    35
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    36
-- MStore code
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    37
initialSize :: Int
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    38
initialSize = 10
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    39
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    40
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    41
growFunc :: Int -> Int
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    42
growFunc a = a * 3 `div` 2
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    43
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    44
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    45
newStore :: IO (MStore e)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    46
newStore = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    47
    newar <- IOA.newArray_ (0, initialSize - 1)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    48
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    49
    return (MStore new)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    50
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    51
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    52
growStore :: MStore e -> IO ()
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    53
growStore (MStore ref) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    54
    (busyElems, freeElems, arr) <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    55
    (_, m') <- IOA.getBounds arr
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    56
    let newM' = growFunc (m' + 1) - 1
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    57
    newArr <- IOA.newArray_ (0, newM')
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    58
    sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']]
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    59
    writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    60
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    61
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    62
growIfNeeded :: MStore e -> IO ()
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    63
growIfNeeded m@(MStore ref) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    64
    (_, freeElems, _) <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    65
    when (IntSet.null freeElems) $ growStore m
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    66
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    67
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    68
addElem :: MStore e -> e -> IO ElemIndex
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    69
addElem m@(MStore ref) element = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    70
    growIfNeeded m
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    71
    (busyElems, freeElems, arr) <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    72
    let (n, freeElems') = IntSet.deleteFindMin freeElems
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    73
    IOA.writeArray arr n element
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    74
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    75
    return $ ElemIndex n
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    76
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    77
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    78
removeElem :: MStore e -> ElemIndex -> IO ()
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    79
removeElem (MStore ref) (ElemIndex n) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    80
    (busyElems, freeElems, arr) <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    81
    IOA.writeArray arr n (error $ "Store: no element " ++ show n)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    82
    writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    83
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    84
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    85
readElem :: MStore e -> ElemIndex -> IO e
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    86
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    87
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    88
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    89
writeElem :: MStore e -> ElemIndex -> e -> IO ()
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    90
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    91
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    92
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    93
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    94
modifyElem (MStore ref) f (ElemIndex n) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    95
    (_, _, arr) <- readIORef ref
3901
124b4755914b Show database errors in stderr
unc0rr
parents: 3747
diff changeset
    96
    IOA.readArray arr n >>= IOA.writeArray arr n . f
3747
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    97
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    98
elemExists :: MStore e -> ElemIndex -> IO Bool
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
    99
elemExists (MStore ref) (ElemIndex n) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   100
    (_, free, _) <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   101
    return $ n `IntSet.notMember` free
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   102
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   103
indicesM :: MStore e -> IO [ElemIndex]
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   104
indicesM (MStore ref) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   105
    (busy, _, _) <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   106
    return $ map ElemIndex $ IntSet.toList busy
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   107
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   108
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   109
-- A way to see MStore elements in pure code via IStore
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   110
m2i :: MStore e -> IO (IStore e)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   111
m2i (MStore ref) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   112
    (a, _, c') <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   113
    c <- IOA.unsafeFreeze c'
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   114
    return $ IStore (a, c)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   115
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   116
i2m :: (MStore e) -> IStore e -> IO ()
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   117
i2m (MStore ref) (IStore (_, arr)) = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   118
    (b, e, _) <- readIORef ref
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   119
    a <- IOA.unsafeThaw arr
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   120
    writeIORef ref (b, e, a)
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   121
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   122
withIStore :: MStore e -> (IStore e -> a) -> IO a
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   123
withIStore m f = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   124
    i <- m2i m
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   125
    let res = f i
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   126
    res `seq` i2m m i
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   127
    return res
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   128
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   129
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   130
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   131
withIStore2 m1 m2 f = do
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   132
    i1 <- m2i m1
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   133
    i2 <- m2i m2
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   134
    let res = f i1 i2
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   135
    res `seq` i2m m1 i1
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   136
    i2m m2 i2
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   137
    return res
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   138
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   139
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   140
-- IStore code
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   141
(!) :: IStore e -> ElemIndex -> e
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   142
(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   143
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   144
indices :: IStore e -> [ElemIndex]
76a197793b62 Some more that were not native
nemo
parents: 3741
diff changeset
   145
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy