gameServer/Store.hs
author smaxx
Sun, 01 Aug 2010 22:05:27 +0200
changeset 3700 fabf387d9055
parent 3673 45778b16b224
child 3741 73246d25dfe1
permissions -rw-r--r--
Graphics: * Added chunk graphics for most themes
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,
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
    12
    indicesM,
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    13
    withIStore,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    14
    withIStore2,
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    15
    (!),
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    16
    indices
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    17
    ) where
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    18
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    19
import qualified Data.Array.IArray as IA
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    20
import qualified Data.Array.IO as IOA
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    21
import qualified Data.IntSet as IntSet
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    22
import Data.IORef
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    23
import Control.Monad
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    24
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    25
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    26
newtype ElemIndex = ElemIndex Int
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3501
diff changeset
    27
    deriving (Eq, Show, Read, Ord)
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    28
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    29
newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    30
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    31
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    32
firstIndex :: ElemIndex
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    33
firstIndex = ElemIndex 0
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    34
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    35
-- MStore code
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    36
initialSize :: Int
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    37
initialSize = 10
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    38
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    39
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    40
growFunc :: Int -> Int
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    41
growFunc a = a * 3 `div` 2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    42
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    43
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    44
newStore :: IO (MStore e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    45
newStore = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    46
    newar <- IOA.newArray_ (0, initialSize - 1)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    47
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    48
    return (MStore new)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    49
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    50
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    51
growStore :: MStore e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    52
growStore (MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    53
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    54
    (_, m') <- IOA.getBounds arr
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    55
    let newM' = growFunc (m' + 1) - 1
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    56
    newArr <- IOA.newArray_ (0, newM')
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    57
    sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']]
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    58
    writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    59
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    60
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    61
growIfNeeded :: MStore e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    62
growIfNeeded m@(MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    63
    (_, freeElems, _) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    64
    when (IntSet.null freeElems) $ growStore m
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    65
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    66
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    67
addElem :: MStore e -> e -> IO ElemIndex
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    68
addElem m@(MStore ref) element = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    69
    growIfNeeded m
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    70
    (busyElems, freeElems, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    71
    let (n, freeElems') = IntSet.deleteFindMin freeElems
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    72
    IOA.writeArray arr n element
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    73
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    74
    return $ ElemIndex n
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    75
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    76
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    77
removeElem :: MStore e -> ElemIndex -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    78
removeElem (MStore ref) (ElemIndex n) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    79
    (busyElems, freeElems, arr) <- readIORef ref
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    80
    IOA.writeArray arr n (error $ "Store: no element " ++ show n)
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    81
    writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    82
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    83
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    84
readElem :: MStore e -> ElemIndex -> IO e
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    85
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    86
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    87
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    88
writeElem :: MStore e -> ElemIndex -> e -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    89
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    90
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    91
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    92
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    93
modifyElem (MStore ref) f (ElemIndex n) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    94
    (_, _, arr) <- readIORef ref
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    95
    IOA.readArray arr n >>= (IOA.writeArray arr n) . f
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    96
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
    97
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
    98
indicesM :: MStore e -> IO [ElemIndex]
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
    99
indicesM (MStore ref) = do
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
   100
    (busy, _, _) <- readIORef ref
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
   101
    return $ map ElemIndex $ IntSet.toList busy
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
   102
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
   103
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   104
-- A way to use see MStore elements in pure code via IStore
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   105
m2i :: MStore e -> IO (IStore e)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   106
m2i (MStore ref) = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   107
    (a, _, c') <- readIORef ref 
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3501
diff changeset
   108
    c <- IOA.freeze c'
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   109
    return $ IStore (a, c)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   110
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3435
diff changeset
   111
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   112
withIStore :: MStore e -> (IStore e -> a) -> IO a
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   113
withIStore m f = liftM f (m2i m)
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   114
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   115
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   116
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   117
withIStore2 m1 m2 f = do
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   118
    i1 <- m2i m1
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   119
    i2 <- m2i m2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   120
    return $ f i1 i2
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   121
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   122
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   123
-- IStore code
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   124
(!) :: IStore e -> ElemIndex -> e
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   125
(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   126
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   127
indices :: IStore e -> [ElemIndex]
ead2ed20dfd4 Start the server refactoring
unc0rr
parents:
diff changeset
   128
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy