blubber-server-0.0.1: src/Blubber/Server/World.hs
{-# LANGUAGE DeriveGeneric #-}
{- |
Module : $Header$
Description : The blubber world.
Copyright : (c) plaimi 2015
License : AGPL-3
Maintainer : blubber@plaimi.net
-} 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,
)
-- | The 'World' in which the 'Entity's reside.
data World = MkWorld
{width :: Double
-- ^ The width of the 'World'.
,height :: Double
-- ^ The height of the 'World'.
,players :: Map String Entity
-- ^ The 'PlayerBlob's in the 'World' indexed on their names.
,neutrals :: Set Entity
-- ^ The 'NeutralBlob's in the 'World'.
,entropy :: StdGen
-- ^ The 'entropy' of the 'World', for randomising things.
} deriving (Show)
addNeutral :: World -> World
-- | Try to add a 'NeutralBlub' to the 'World', if there is room for it. But
-- don't try *very* hard.
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
-- | Add a 'PlayerBlub' belonging to the name in the passed in 'String', lest
-- it already has a 'PlayerBlub', in which case it's just ignored.
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
-- | Delete a 'PlayerBlub' belonging to the name in the passed in 'String',
-- lest it doesn't exist, in which case it's just ignored.
delPlayer w p = w {players = M.delete p (players w)}
available :: World -> Entity -> Bool
-- | For use with 'Entity's that are not yet placed in the 'World', in order
-- to check that the spot you are attempting to place them in is actually
-- available -- i.e. that it doesn't intersect with already placed out
-- 'Entity's
available w b = null . catMaybes $ intersect b
<$> (S.elems (neutrals w) ++ M.elems (players w))
clamp :: Ord a => a -> a -> a -> a
-- | 'clamp' stuff between a min and a max.
clamp l h = max l . min h
createWorld :: StdGen -> World
-- | The initial 'World'.
createWorld s = MkWorld
{width = 160
,height = 90
,players = M.empty
,neutrals = S.empty
,entropy = s
}
updateVel :: Double -> Entity -> Entity
-- | Update the 'velocity' of an 'Entity' based on its 'targetPos', and
-- limited by its 'mass'.
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
-- | Update the 'position of an 'Entity' based on its 'velocity'. Makes sure
-- to 'clamp' the 'Entity' to the 'World' edges.
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
-- | Natural decaying of 'Entity' 'mass', so as to not have too huge
-- 'Entity's.
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
-- | Check if any one 'Entity' collides with any one other. If they do, delete
-- them out of the recursion, and keep checking the others until every
-- 'Entity' is checked with every other.
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
-- | Check if any one 'Entity' collides with any one other. If they do, delete
-- them out of the recursion, and keep checking the others until every
-- 'Entity' is checked with every other.
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))
-- | Given an 'Entity' of a 'PlayerBlub' and its id (as a 'String'), and
-- a list of other such things, let the 'Entity' 'fite' all the ones in the
-- passed in the list.
--
-- It keeps checking until there's a collision. At that point, it figures out
-- which one 'blubber's which. The 'blubber'er grows, and the 'blubber'ee is
-- deleted. Ruthless.
--
-- If there is no collision it returns 'Nothing'. If there is one, it returns
-- a 'Just' with two tuples -- one for each 'Blub'. The survivor will be
-- a 'Just', the other one 'Nothing'.
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'))
-- This next one should not happen at all.
(Nothing, Nothing) -> Just ((s, Nothing), (t, Nothing))
| otherwise = playerBlubs (s, a) bs
neutralBlubs :: (String, Entity) -> [Entity]
-> Maybe ((String, Entity), Entity)
-- | Given an 'Entity' of a 'PlayerBlub' and its id (as a 'String'), and
-- a list of 'NeturalBlub's 'Entity's, let the 'PlayerBlub' 'Entity' 'fite'
-- all the 'NeutralbBlub's in the passed in list.
--
-- It keeps checking until there's a collision. At that point, it returns the
-- now rather quiute big 'PlayerBlub' and the poor 'NeutralBlub' it has
-- blubbered. If there is no collision it just returns 'Nothing'.
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
-- | Check if the client in the passed in 'String' is the owner of an
-- 'Entity'; if so, set its 'targetPos' to the passed in 'Double's.
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
-- | Update the 'World'. 'updateVel', 'updatePos', 'decay', and check for
-- 'blubbers'.
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
-- | Checks if a client has a player. If it does, then update the 'targetPos'
-- of the player's 'Entity'.
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