gameServer/Store.hs
author Xeli
Thu, 09 Feb 2012 14:12:50 +0100
changeset 6654 120e95c10532
parent 5119 f475e10c4081
child 6805 097289be7200
permissions -rw-r--r--
use the way actions are initiated the same way as koda implemented with PascalExports, using boolean values such as upKey and enterKey, this prevents the user from being able to control the AI
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     1
module Store(
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     2
    ElemIndex(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     3
    MStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     4
    IStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     5
    newStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     6
    addElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     7
    removeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     8
    readElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     9
    writeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    10
    modifyElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    11
    elemExists,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    12
    firstIndex,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    13
    indicesM,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    14
    withIStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    15
    withIStore2,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    16
    (!),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    17
    indices
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    18
    ) where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    19
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    20
import qualified Data.Array.IArray as IA
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    21
import qualified Data.Array.IO as IOA
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    22
import qualified Data.IntSet as IntSet
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    23
import Data.IORef
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    24
import Control.Monad
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    25
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    26
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    27
newtype ElemIndex = ElemIndex Int
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    28
    deriving (Eq, Show, Read, Ord)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    29
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    30
newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    31
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    32
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    33
firstIndex :: ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    34
firstIndex = ElemIndex 0
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    35
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    36
-- MStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    37
initialSize :: Int
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    38
initialSize = 16
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    39
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    40
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    41
growFunc :: Int -> Int
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    42
growFunc a = a * 3 `div` 2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    43
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    44
truncFunc :: Int -> Int
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    45
truncFunc a | a > growFunc initialSize = (a `div` 2)
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    46
            | otherwise = a
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    47
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    48
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    49
newStore :: IO (MStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    50
newStore = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    51
    newar <- IOA.newArray_ (0, initialSize - 1)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    52
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    53
    return (MStore new)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    54
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    55
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    56
growStore :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    57
growStore (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    58
    (busyElems, freeElems, arr) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    59
    (_, m') <- IOA.getBounds arr
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    60
    let newM' = growFunc (m' + 1) - 1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    61
    newArr <- IOA.newArray_ (0, newM')
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    62
    sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    63
    writeIORef ref (busyElems, freeElems `IntSet.union` IntSet.fromAscList [m'+1..newM'], newArr)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    64
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    65
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    66
growIfNeeded :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    67
growIfNeeded m@(MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    68
    (_, freeElems, _) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    69
    when (IntSet.null freeElems) $ growStore m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    70
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    71
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    72
truncateIfNeeded :: MStore e -> IO ()
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    73
truncateIfNeeded (MStore ref) = do
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    74
    (busyElems, _, arr) <- readIORef ref
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    75
    (_, m') <- IOA.getBounds arr
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    76
    let newM' = truncFunc (m' + 1) - 1
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    77
    when (newM' < m' && (not $ IntSet.null busyElems) && IntSet.findMax busyElems <= newM') $ do
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    78
        newArr <- IOA.newArray_ (0, newM')
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    79
        sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- IntSet.toList busyElems]
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    80
        writeIORef ref (busyElems, IntSet.fromAscList [0..newM'] `IntSet.difference` busyElems, newArr)
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    81
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    82
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    83
addElem :: MStore e -> e -> IO ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    84
addElem m@(MStore ref) element = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    85
    growIfNeeded m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    86
    (busyElems, freeElems, arr) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    87
    let (n, freeElems') = IntSet.deleteFindMin freeElems
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    88
    IOA.writeArray arr n element
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    89
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    90
    return $ ElemIndex n
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    91
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    92
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    93
removeElem :: MStore e -> ElemIndex -> IO ()
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    94
removeElem m@(MStore ref) (ElemIndex n) = do
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    95
    (busyElems, freeElems, arr) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    96
    IOA.writeArray arr n (error $ "Store: no element " ++ show n)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    97
    writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    98
    truncateIfNeeded m
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    99
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   100
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   101
readElem :: MStore e -> ElemIndex -> IO e
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   102
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   103
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   104
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   105
writeElem :: MStore e -> ElemIndex -> e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   106
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   107
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   108
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   109
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   110
modifyElem (MStore ref) f (ElemIndex n) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   111
    (_, _, arr) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   112
    IOA.readArray arr n >>= IOA.writeArray arr n . f
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   113
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   114
elemExists :: MStore e -> ElemIndex -> IO Bool
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   115
elemExists (MStore ref) (ElemIndex n) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   116
    (_, free, _) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   117
    return $ n `IntSet.notMember` free
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   118
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   119
indicesM :: MStore e -> IO [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   120
indicesM (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   121
    (busy, _, _) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   122
    return $ map ElemIndex $ IntSet.toList busy
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   123
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   124
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   125
-- A way to see MStore elements in pure code via IStore
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   126
m2i :: MStore e -> IO (IStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   127
m2i (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   128
    (a, _, c') <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   129
    c <- IOA.unsafeFreeze c'
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   130
    return $ IStore (a, c)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   131
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
   132
i2m :: MStore e -> IStore e -> IO ()
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   133
i2m (MStore ref) (IStore (_, arr)) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   134
    (b, e, _) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   135
    a <- IOA.unsafeThaw arr
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   136
    writeIORef ref (b, e, a)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   137
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   138
withIStore :: MStore e -> (IStore e -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   139
withIStore m f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   140
    i <- m2i m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   141
    let res = f i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   142
    res `seq` i2m m i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   143
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   144
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   145
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   146
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   147
withIStore2 m1 m2 f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   148
    i1 <- m2i m1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   149
    i2 <- m2i m2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   150
    let res = f i1 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   151
    res `seq` i2m m1 i1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   152
    i2m m2 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   153
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   154
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   155
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   156
-- IStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   157
(!) :: IStore e -> ElemIndex -> e
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   158
(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   159
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   160
indices :: IStore e -> [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   161
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy