astrds-0.1: src/States.hs
module States where
import Control.Monad
import qualified Control.Monad.State as S
import qualified Control.Monad.Random as R
import System.Random
import System.Posix
import Data.List
import UInputInterface
import UInputUtils
import Config
data State = State { player :: Player
, status :: Status
, score :: Int
, rocks :: [Rock]
, collectibles :: [Collectible]
, time :: Int -- ^ abstract game time
, input :: UInput
}
data Status = Alive | Dead
deriving (Eq, Show)
data FlyingObject = FlyingObject { pos :: Pos
, speed :: Vel
, size :: Double
, scale :: Double
}
type Player = FlyingObject
type Rock = FlyingObject
type Collectible = FlyingObject
type Pos = (Double, Double)
type Vel = (Double, Double) -- ^ all speeds are measured in pixels per second
initState :: State
initState = State { player = FlyingObject { pos = (fromIntegral maxXview/2, fromIntegral maxYview/2)
, speed = (0,0)
, size = 30
, scale = 1
}
, status = Alive
, score = 0
, rocks = []
, collectibles = []
, time = 0
, input = noInput
}
-- | State monad version of the (abstract) game state;
--
-- > S.State s a ~= s -> (a,s)
--
type StateS = S.State State
-- | State monad including a random generator.
type StateR a = R.RandT StdGen StateS a
--------------------------------------------------------------------
-- * Updating the game state
--------------------------------------------------------------------
updateState :: State -> UInput -> Int -> IO State
updateState s ui dt = do
-- generate a random random generator
tsys <- liftM fromEnum epochTime
let tgame = time s
let seed = tsys * tgame
let gen = mkStdGen seed
return $ snd (S.runState (R.runRandT (updateStateR ui dt) gen) s)
updateStateR :: UInput -> Int -> StateR()
updateStateR ui dt = do
-- force a first random number generation
R.getRandom :: StateR Int
-- adjust the abstract clock of the game
S.modify stepTime
-- interpolate the new positions
interpolateStateR dt
-- collision of the player with a rock?
updateHealthR
-- update score and remove collected collectibles
updateScoreR
-- remove rocks/collectibles that are out of reach
cleanUpR
-- generate new rocks/collectibles?
genRocksCollsR
-- remember new input
setUInput ui
-- | Increment the time counter.
stepTime :: State -> State
stepTime s = s { time = time s + 1 }
-------------------------------------------------------------------
-- * Interpolation
-------------------------------------------------------------------
interpolateStateR :: Int -> StateR ()
interpolateStateR dt = S.modify (\s -> interpolateState s dt)
-- | Interpolate the positions according to the time passed.
interpolateState :: State -> Int -> State
interpolateState s dt = let pl = (player s) { speed = uiToDir (input s) }
in s { player = confineToVis $ moveFlyingObject pl dt
, rocks = map (\r -> moveFlyingObject r dt) (rocks s)
, collectibles = map (\c -> moveFlyingObject c dt) (collectibles s)
}
moveFlyingObject :: FlyingObject -> Int -> FlyingObject
moveFlyingObject f dt = f { pos = movePos (pos f) (speed f) dt }
movePos :: Pos -> Vel -> Int -> Pos
movePos p (velx,vely) dt = inDir p ( (fromIntegral dt * velx)/10^3
, (fromIntegral dt * vely)/10^3 )
-- | Confine a FO to the visible part of the galaxy.
confineToVis :: FlyingObject -> FlyingObject
confineToVis f = f { pos = ( max 0 (min x (fromIntegral maxXview))
, max 0 (min y (fromIntegral maxYview)) )
}
where (x,y) = pos f
-- | Direction as a delta.
type Dir = (Double,Double)
-- | Compute a new position from an origin and a delta.
inDir :: Pos -> Dir -> Pos
inDir (x,y) (dx,dy) = ( x + dx, y + dy )
-- | Convert user input into a direction.
uiToDir :: UInput -> Dir
uiToDir ui = let (kx, ky) = dirkeys ui
(x,y) = axes ui
in ( (x+kx) * unitSpeed, (y+ky) * unitSpeed )
-- | Speed constant.
unitSpeed = 600
-------------------------------------------------------------------
-- * Update user input
-------------------------------------------------------------------
setUInput :: UInput -> StateR ()
setUInput ui = S.modify (\ s -> s { input = ui } )
-------------------------------------------------------------------
-- * Collision of the ship with other objects
-------------------------------------------------------------------
-- | Check whether two flying objects collide
-- (the flying objects are assumed to be circles).
collides :: FlyingObject -> FlyingObject -> Bool
collides f f' = distance (pos f) (pos f')
<= scale f * size f + scale f' * size f'
distance :: (Double,Double) -> (Double,Double) -> Double
distance (px,py) (px',py') = sqrt ( (px - px')^2 + (py-py')^2 )
-- check whether the player's ship hits a rock
hitsRock :: State -> Bool
hitsRock s = any (collides (player s)) (rocks s)
updateHealth :: State -> State
updateHealth s = s { status = newstatus }
where
newstatus = if hitsRock s then Dead else Alive
updateHealthR :: StateR ()
updateHealthR = S.modify updateHealth
-- computes the new score and removes the collected collectibles
updateScore :: State -> State
updateScore s = s { collectibles = noncollected
, score = score s + length collected
}
where
collected = filter (\c -> collides (player s) c) (collectibles s)
noncollected = filter (\c -> not (collides (player s) c)) (collectibles s)
updateScoreR :: StateR ()
updateScoreR = S.modify updateScore
-------------------------------------------------------------------
--- clean up rocks/collectibles that are out of reach
-------------------------------------------------------------------
cleanUp :: State -> State
cleanUp s = s { rocks = filter inReach (rocks s)
, collectibles = filter inReach (collectibles s)
}
cleanUpR :: StateR ()
cleanUpR = S.modify cleanUp
inReach :: FlyingObject -> Bool
inReach f = x >= (- realsize) && x <= fromIntegral maxXview + realsize
&& y >= (- realsize) && y <= fromIntegral maxYview + realsize
where (x,y) = pos f
realsize = size f * scale f
--------------------------------------------------------------------
--- generate new rocks/collectibles
--------------------------------------------------------------------
genRocksCollsR :: StateR ()
genRocksCollsR = do
s <- S.get
rrock <- genFlyingObject
rcoll <- genFlyingObject
p <- R.getRandomR (0,100)
let newrocks = if p < pRock then [rrock] else []
q <- R.getRandomR (0,100)
let newcolls = if q < pColl then [rcoll] else []
let s' = s { rocks = newrocks ++ rocks s
, collectibles = newcolls ++ collectibles s
}
S.put s'
-- | Probability for generating a rock (in percent per abstract tick).
pRock = 4 :: Int
-- | Probability for generating a collectible (in percent per abstract tick).
pColl = 2 :: Int
genFlyingObject :: StateR FlyingObject
genFlyingObject =
do
b <- R.getRandomR (0,2*maxXview + 2 * maxYview -1)
aimx <- R.getRandomR (-200,200)
aimy <- R.getRandomR (-150,150)
sc <- R.getRandomR (minScale,maxScale)
let (x,y) = convertBoundaryToXY b (sc * 30)
(vx,vy) = ( 1/5*(fromIntegral (maxXview + aimx) / 2 - x)
, 1/5*(fromIntegral (maxYview + aimy) / 2 - y) )
return $ FlyingObject { pos = (x,y)
, speed = (vx,vy)
, size = 30
, scale = sc
}
minScale = 0.5
maxScale = 1.5
convertBoundaryToXY :: Int -> Double -> Pos
convertBoundaryToXY b sz | b < maxXview = ( fromIntegral b
, - sz)
| b < maxXview + maxYview = ( fromIntegral maxXview + sz
, fromIntegral (b - maxXview))
| b < 2*maxXview + maxYview = ( fromIntegral (b - maxXview - maxYview)
, fromIntegral maxYview + sz)
| otherwise = ( -sz
, fromIntegral (b - 2 * maxXview - maxYview))