gameServer/Store.hs
author nemo
Mon, 10 May 2010 00:56:16 +0000
changeset 3453 d65657c94bb9
parent 3435 4e4f88a7bdf2
child 3501 a3159a410e5c
permissions -rw-r--r--
tweak
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     1
module Store(
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     2
    ElemIndex(),
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     3
    MStore(),
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     4
    IStore(),
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     5
    newStore,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     6
    addElem,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     7
    removeElem,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     8
    readElem,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
     9
    writeElem,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    10
    modifyElem,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    11
    firstIndex,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    12
    withIStore,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    13
    withIStore2,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    14
    (!),
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    15
    indices
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    16
    ) where
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    17
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    18
import qualified Data.Array.IArray as IA
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    19
import qualified Data.Array.IO as IOA
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    20
import qualified Data.IntSet as IntSet
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    21
import Data.IORef
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    22
import Control.Monad
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    23
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    24
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    25
newtype ElemIndex = ElemIndex Int
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    26
    deriving (Eq, Show, Read)
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    27
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    28
newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    29
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    30
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    31
firstIndex :: ElemIndex
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    32
firstIndex = ElemIndex 0
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    33
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    34
-- MStore code
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    35
initialSize :: Int
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    36
initialSize = 10
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    37
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    38
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    39
growFunc :: Int -> Int
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    40
growFunc a = a * 3 `div` 2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    41
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    42
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    43
newStore :: IO (MStore e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    44
newStore = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    45
    newar <- IOA.newArray_ (0, initialSize - 1)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    46
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    47
    return (MStore new)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    48
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    49
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    50
growStore :: MStore e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    51
growStore (MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    52
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    53
    (_, m') <- IOA.getBounds arr
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    54
    let newM' = growFunc (m' + 1) - 1
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    55
    newArr <- IOA.newArray_ (0, newM')
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    56
    sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']]
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    57
    writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    58
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    59
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    60
growIfNeeded :: MStore e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    61
growIfNeeded m@(MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    62
    (_, freeElems, _) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    63
    when (IntSet.null freeElems) $ growStore m
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    64
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    65
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    66
addElem :: MStore e -> e -> IO ElemIndex
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    67
addElem m@(MStore ref) element = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    68
    growIfNeeded m
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    69
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    70
    let (n, freeElems') = IntSet.deleteFindMin freeElems
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    71
    IOA.writeArray arr n element
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    72
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    73
    return $ ElemIndex n
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    74
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    75
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    76
removeElem :: MStore e -> ElemIndex -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    77
removeElem (MStore ref) (ElemIndex n) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    78
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    79
    IOA.writeArray arr n undefined
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    80
    writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    81
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    82
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    83
readElem :: MStore e -> ElemIndex -> IO e
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    84
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    85
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    86
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    87
writeElem :: MStore e -> ElemIndex -> e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    88
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    89
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    90
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    91
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    92
modifyElem (MStore ref) f (ElemIndex n) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    93
    (_, _, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    94
    IOA.readArray arr n >>= (IOA.writeArray arr n) . f
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    95
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    96
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    97
-- A way to use see MStore elements in pure code via IStore
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    98
m2i :: MStore e -> IO (IStore e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    99
m2i (MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   100
    (a, _, c') <- readIORef ref 
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   101
    c <- IOA.unsafeFreeze c'
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   102
    return $ IStore (a, c)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   103
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   104
withIStore :: MStore e -> (IStore e -> a) -> IO a
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   105
withIStore m f = liftM f (m2i m)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   106
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   107
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   108
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   109
withIStore2 m1 m2 f = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   110
    i1 <- m2i m1
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   111
    i2 <- m2i m2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   112
    return $ f i1 i2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   113
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   114
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   115
-- IStore code
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   116
(!) :: IStore e -> ElemIndex -> e
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   117
(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   118
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   119
indices :: IStore e -> [ElemIndex]
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   120
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy