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))