module Blubber.Server.World where
import Data.Functor
(
(<$>),
)
import qualified Data.List as L
import Data.Maybe
(
catMaybes,
)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import System.Random
(
StdGen,
randomR,
)
import Blubber.Server.Entity
(
Entity (MkEntity),
Blub (NeutralBlub, PlayerBlub),
entity,
intersect,
isNeutral,
fite,
mass,
position,
targetPos,
velocity,
)
import Blubber.Server.Vector
(
Vector (Vec),
(^+^),
(^-^),
(^*^),
(^/^),
magVec,
vecLimitMag,
)
data World = MkWorld
{width :: Double
,height :: Double
,players :: Map String Entity
,neutrals :: Set Entity
,entropy :: StdGen
} deriving (Show)
addNeutral :: World -> World
addNeutral w | S.size (neutrals w) < 32
&& available w b = w' {neutrals = S.insert b (neutrals w)}
| otherwise = w'
where b = MkEntity {position = Vec px py
,mass = m
,entity = NeutralBlub
}
(m, entropy') = randomR (1.0, 5.0) $ entropy w
(px, entropy'') = randomR (0.0, width w) entropy'
(py, entropy''') = randomR (0.0, height w) entropy''
w' = w {entropy = entropy'''}
addPlayer :: World -> String -> World
addPlayer w s | s `M.member` players w
/= True = if available w b
then w' {players = M.insert s b (players w)}
else addPlayer w' s
| otherwise = w
where
b = MkEntity {position = Vec px py
,mass = 10.0
,entity = PlayerBlub {velocity = Vec 0 0
,targetPos = Vec 0 0
}
}
(px, e') = randomR (0.0, width w) $ entropy w
(py, e'') = randomR (0.0, height w) e'
w' = w {entropy = e''}
delPlayer :: World -> String -> World
delPlayer w p = w {players = M.delete p (players w)}
available :: World -> Entity -> Bool
available w b = null . catMaybes $ intersect b
<$> (S.elems (neutrals w) ++ M.elems (players w))
clamp :: Ord a => a -> a -> a -> a
clamp l h = max l . min h
createWorld :: StdGen -> World
createWorld s = MkWorld
{width = 160
,height = 90
,players = M.empty
,neutrals = S.empty
,entropy = s
}
updateVel :: Double -> Entity -> Entity
updateVel dt e@(MkEntity {entity = b, mass = m})
| isNeutral e = e
| otherwise = e {entity = b {velocity = velocity b ^+^ a ^*^ dt}}
where a | magVec dv <= 0.01 = Vec 0 0
| otherwise = vecLimitMag (magVec dv / dt)
$ dv ^/^ (magVec dv * m)
dv = tv ^-^ velocity b
tv = vecLimitMag maxSpeed $ targetPos b ^*^ (maxSpeed / m)
maxSpeed = 64 / (1 + log m)
updatePos :: Double -> World -> Entity -> Entity
updatePos dt w e | isNeutral e = e
| otherwise = e {position = clampPos $ position e
^+^ velocity (entity e)
^*^ dt}
where clampPos (Vec x y) = Vec (clamp 0 (width w) x) (clamp 0 (height w) y)
decay :: Double -> Entity -> Entity
decay dt e | isNeutral e = e
| mass e > 1 = e {mass = 1 + (mass e 1) * 0.999 ** dt}
| otherwise = e
blubs :: World -> World
blubs = playerBlubbers . neutralBlubbers
playerBlubbers :: World -> World
playerBlubbers w = go (M.toList (players w)) (M.toList (players w)) w
where
go :: [(String, Entity)] -> [(String, Entity)] -> World -> World
go [] _ v = v
go _ [] v = v
go (a:as) bs v =
case playerBlubs a bs of
Nothing -> go as bs v
Just ((s, Just a') ,(t, Nothing)) ->
let z = M.delete t . M.insert s a' $ players v
in go as (L.delete a $ M.toList z) v {players = z}
Just ((s, Nothing) ,(t, Just b')) ->
let z = M.delete s . M.insert t b' $ players v
in go as (L.delete a $ M.toList z) v {players = z}
Just _ -> go as bs v
neutralBlubbers :: World -> World
neutralBlubbers w = go (M.toList (players w)) (S.toList (neutrals w)) w
where
go :: [(String, Entity)] -> [Entity] -> World -> World
go [] _ v = v
go _ [] v = v
go (a:as) bs v =
case neutralBlubs a bs of
Nothing -> go as bs v
Just ((s, a') ,b) -> let p' = M.insert s a' $ players v
n' = S.delete b $ neutrals v
in go as (L.delete b $ S.toList n')
v {players = p', neutrals = n'}
playerBlubs :: (String, Entity) -> [(String, Entity)]
-> Maybe ((String, Maybe Entity), (String, Maybe Entity))
playerBlubs _ [] = Nothing
playerBlubs (s, a) ((t, b):bs)
| s /= t = case fite (a, b) of
(Just _, Just _) -> playerBlubs (s, a) bs
(Just a', Nothing) -> Just ((s, Just a'), (t, Nothing))
(Nothing, Just b') -> Just ((s, Nothing), (t, Just b'))
(Nothing, Nothing) -> Just ((s, Nothing), (t, Nothing))
| otherwise = playerBlubs (s, a) bs
neutralBlubs :: (String, Entity) -> [Entity]
-> Maybe ((String, Entity), Entity)
neutralBlubs _ [] = Nothing
neutralBlubs (s, a) (b:bs) = case fite (a, b) of
(Just a', Nothing) -> Just ((s, a'), b)
_ -> neutralBlubs (s, a) bs
setTargetPos :: String -> Double -> Double -> World -> Map String Entity
setTargetPos p x y w =
case M.lookup p (players w) of
Just e | isNeutral e -> players w
| otherwise -> M.insert p e {entity = (entity e)
{targetPos = Vec x y}} (players w)
Nothing -> players w
updateWorld :: Double -> World -> World
updateWorld dt w =
blubs w {players = M.map (decay dt . updatePos dt w
. updateVel dt) (players w)}
handleInput :: Ord c => [(c, (Double, Double))] -> Map c String -> World
-> World
handleInput [] _ w = w
handleInput ((c,(x, y)):as) cs w =
case M.lookup c cs of
Just p -> handleInput as cs $ w {players = setTargetPos p x y w}
Nothing -> handleInput as cs w