gameServer/Store.hs
author Wuzzy <almikes@aol.com>
Sun, 08 Oct 2017 20:24:58 +0200
changeset 12681 2e6dcd97f085
parent 11046 47a8c19ecb60
permissions -rw-r--r--
No longer jiggle sticky mines if using portable portal device This fixes the sticky mine sound playing when using portal gun while any sticky mine is placed on ground. We decided that placed sticky mines can't be teleported.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10460
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    18
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    19
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    20
module Store(
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    21
    ElemIndex(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    22
    MStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    23
    IStore(),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    24
    newStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    25
    addElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    26
    removeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    27
    readElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    28
    writeElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    29
    modifyElem,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    30
    elemExists,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    31
    firstIndex,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    32
    indicesM,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    33
    withIStore,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    34
    withIStore2,
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    35
    (!),
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    36
    indices
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    37
    ) where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    38
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    39
import qualified Data.IntSet as IntSet
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    40
import qualified Data.Vector as V
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    41
import qualified Data.Vector.Mutable as MV
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    42
import Data.IORef
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    43
import Control.Monad
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    44
import Control.DeepSeq
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    45
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    46
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    47
newtype ElemIndex = ElemIndex Int
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    48
    deriving (Eq, Show, Read, Ord, NFData)
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    49
newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, MV.IOVector e))
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    50
newtype IStore e = IStore (IntSet.IntSet, V.Vector e)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    51
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    52
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    53
firstIndex :: ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    54
firstIndex = ElemIndex 0
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    55
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    56
-- MStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    57
initialSize :: Int
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    58
initialSize = 16
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    59
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    60
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    61
growFunc :: Int -> Int
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    62
growFunc a = a * 3 `div` 2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    63
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    64
truncFunc :: Int -> Int
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    65
truncFunc a | a > growFunc initialSize = (a `div` 2)
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    66
            | otherwise = a
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    67
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    68
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    69
newStore :: IO (MStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    70
newStore = do
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    71
    newar <- MV.new initialSize
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    72
    new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    73
    return (MStore new)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    74
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    75
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    76
growStore :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    77
growStore (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    78
    (busyElems, freeElems, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    79
    let oldSize = MV.length arr
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    80
    let newSize = growFunc oldSize
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    81
    newArr <- MV.grow arr (newSize - oldSize)
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    82
    writeIORef ref (busyElems, freeElems `IntSet.union` IntSet.fromAscList [oldSize .. newSize-1], newArr)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    83
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    84
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    85
growIfNeeded :: MStore e -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    86
growIfNeeded m@(MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    87
    (_, freeElems, _) <- readIORef ref
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    88
    when (IntSet.null freeElems) $ growStore m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    89
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    90
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    91
truncateIfNeeded :: MStore e -> IO ()
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5003
diff changeset
    92
truncateIfNeeded (MStore ref) = do
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    93
    (busyElems, _, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    94
    let oldSize = MV.length arr
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    95
    let newSize = truncFunc oldSize
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    96
    when (newSize < oldSize && (not $ IntSet.null busyElems) && IntSet.findMax busyElems < newSize) $ do
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
    97
        writeIORef ref (busyElems, IntSet.fromAscList [0..newSize - 1] `IntSet.difference` busyElems, MV.take newSize arr)
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    98
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
    99
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   100
addElem :: MStore e -> e -> IO ElemIndex
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   101
addElem m@(MStore ref) element = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   102
    growIfNeeded m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   103
    (busyElems, freeElems, arr) <- readIORef ref
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
   104
    let (!n, freeElems') = IntSet.deleteFindMin freeElems
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   105
    MV.write arr n element
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   106
    writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   107
    return $ ElemIndex n
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   108
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   109
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   110
removeElem :: MStore e -> ElemIndex -> IO ()
5003
db4726bf9205 Implement Store truncating, so the memory even gets freed sometimes
unc0rr
parents: 4932
diff changeset
   111
removeElem m@(MStore ref) (ElemIndex n) = do
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   112
    (busyElems, freeElems, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   113
    MV.write arr n (error $ "Store: no element " ++ show n)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   114
    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
   115
    truncateIfNeeded m
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   116
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   117
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   118
readElem :: MStore e -> ElemIndex -> IO e
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   119
readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> MV.read arr n
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   120
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   121
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   122
writeElem :: MStore e -> ElemIndex -> e -> IO ()
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   123
writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> MV.write arr n el
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   124
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   125
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   126
modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   127
modifyElem (MStore ref) f (ElemIndex n) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   128
    (_, _, arr) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   129
    MV.read arr n >>= MV.write arr n . f
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   130
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   131
elemExists :: MStore e -> ElemIndex -> IO Bool
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   132
elemExists (MStore ref) (ElemIndex n) = do
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
   133
    (_, !free, _) <- readIORef ref
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   134
    return $ n `IntSet.notMember` free
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   135
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   136
indicesM :: MStore e -> IO [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   137
indicesM (MStore ref) = do
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
   138
    (!busy, _, _) <- readIORef ref
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   139
    return $ map ElemIndex $ IntSet.toList busy
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   140
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   141
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   142
-- A way to see MStore elements in pure code via IStore
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   143
m2i :: MStore e -> IO (IStore e)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   144
m2i (MStore ref) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   145
    (a, _, c') <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   146
    c <- V.unsafeFreeze c'
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   147
    return $ IStore (a, c)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   148
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
   149
i2m :: MStore e -> IStore e -> IO ()
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   150
i2m (MStore ref) (IStore (_, arr)) = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   151
    (b, e, _) <- readIORef ref
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   152
    a <- V.unsafeThaw arr
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   153
    writeIORef ref (b, e, a)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   154
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   155
withIStore :: MStore e -> (IStore e -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   156
withIStore m f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   157
    i <- m2i m
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   158
    let res = f i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   159
    res `seq` i2m m i
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   160
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   161
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   162
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   163
withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   164
withIStore2 m1 m2 f = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   165
    i1 <- m2i m1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   166
    i2 <- m2i m2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   167
    let res = f i1 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   168
    res `seq` i2m m1 i1
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   169
    i2m m2 i2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   170
    return res
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   171
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   172
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   173
-- IStore code
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   174
(!) :: IStore e -> ElemIndex -> e
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 6805
diff changeset
   175
(!) (IStore (_, arr)) (ElemIndex i) = (V.!) arr i
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   176
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   177
indices :: IStore e -> [ElemIndex]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
   178
indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy