gameServer/Store.hs
author nemo
Thu, 06 May 2010 03:12:42 +0000
changeset 3431 e36dffdf7b82
parent 3425 ead2ed20dfd4
child 3435 4e4f88a7bdf2
permissions -rw-r--r--
trying to unbreak what I broke
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
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    26
    deriving (Eq)
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
instance Show ElemIndex where
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    31
    show (ElemIndex i) = 'i' : show i
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    32
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    33
firstIndex :: ElemIndex
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    34
firstIndex = ElemIndex 0
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    35
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    36
-- MStore code
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    37
initialSize :: Int
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    38
initialSize = 10
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    39
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    40
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    41
growFunc :: Int -> Int
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    42
growFunc a = a * 3 `div` 2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    43
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    44
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    45
newStore :: IO (MStore e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    46
newStore = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    47
    newar <- IOA.newArray_ (0, initialSize - 1)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    48
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    49
    return (MStore new)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    50
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    51
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    52
growStore :: MStore e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    53
growStore (MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    54
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    55
    (_, m') <- IOA.getBounds arr
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    56
    let newM' = growFunc (m' + 1) - 1
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    57
    newArr <- IOA.newArray_ (0, newM')
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    58
    sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']]
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    59
    writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    60
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    61
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    62
growIfNeeded :: MStore e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    63
growIfNeeded m@(MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    64
    (_, freeElems, _) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    65
    when (IntSet.null freeElems) $ growStore m
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    66
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    67
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    68
addElem :: MStore e -> e -> IO ElemIndex
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    69
addElem m@(MStore ref) element = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    70
    growIfNeeded m
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    71
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    72
    let (n, freeElems') = IntSet.deleteFindMin freeElems
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    73
    IOA.writeArray arr n element
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    74
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    75
    return $ ElemIndex n
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    76
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    77
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    78
removeElem :: MStore e -> ElemIndex -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    79
removeElem (MStore ref) (ElemIndex n) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    80
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    81
    IOA.writeArray arr n undefined
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    82
    writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    83
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    84
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    85
readElem :: MStore e -> ElemIndex -> IO e
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    86
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    87
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    88
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    89
writeElem :: MStore e -> ElemIndex -> e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    90
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    91
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    92
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    93
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    94
modifyElem (MStore ref) f (ElemIndex n) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    95
    (_, _, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    96
    IOA.readArray arr n >>= (IOA.writeArray arr n) . f
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    97
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    98
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    99
-- A way to use see MStore elements in pure code via IStore
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   100
m2i :: MStore e -> IO (IStore e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   101
m2i (MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   102
    (a, _, c') <- readIORef ref 
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   103
    c <- IOA.unsafeFreeze c'
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   104
    return $ IStore (a, c)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   105
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   106
withIStore :: MStore e -> (IStore e -> a) -> IO a
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   107
withIStore m f = liftM f (m2i m)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   108
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   109
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   110
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   111
withIStore2 m1 m2 f = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   112
    i1 <- m2i m1
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   113
    i2 <- m2i m2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   114
    return $ f i1 i2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   115
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   116
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   117
-- IStore code
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   118
(!) :: IStore e -> ElemIndex -> e
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   119
(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   120
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   121
indices :: IStore e -> [ElemIndex]
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   122
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy