{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE Arrows #-}
-- | This module defines the game as a big Signal Function that transforms a
-- Signal carrying a Input 'Controller' information into a Signal carrying
-- 'GameState'.
--
-- There is no randomness in the game, the only input is the user's.
-- 'Controller' is an abstract representation of a basic input device with
-- position information and a /fire/ button.
--
-- The output is defined in 'GameState', and consists of basic information
-- (points, current level, etc.) and a universe of objects.
--
-- Objects are represented as Signal Functions as well ('ObjectSF'). This
-- allows them to react to user input and change with time. Each object is
-- responsible for itself, but it cannot affect others: objects can watch
-- others, depend on others and react to them, but they cannot /send a
-- message/ or eliminate other objects. However, if you would like to
-- dynamically introduce new elements in the game (for instance, falling
-- powerups that the player must collect before they hit the ground) then it
-- might be a good idea to allow objects not only to /kill themselves/ but
-- also to spawn new object.
--
-- This module contains two sections:
--
-- - A collection of gameplay SFs, which control the core game loop, carry
-- out collision detection, , etc.
--
-- - One SF per game object. These define the elements in the game universe,
-- which can observe other elements, depend on user input, on previous
-- collisions, etc.
--
-- You may want to read the basic definition of 'GameState', 'Controller' and
-- 'ObjectSF' before you attempt to go through this module.
--
module Game (wholeGame) where
-- External imports
import Prelude hiding (id, (.))
import Control.Category (id, (.))
import Data.List
import Data.Maybe
import Debug.Trace
import FRP.Yampa -- as Yampa
-- import FRP.Yampa.InternalCore
import FRP.Yampa.Extra
import FRP.Yampa.Switches
-- General-purpose internal imports
import Data.Extra.Ord
import Data.Extra.VectorSpace
import Physics.Oscillator
import Physics.TwoDimensions.Collisions as Collisions
import Physics.TwoDimensions.Dimensions
import Physics.TwoDimensions.GameCollisions
import Physics.TwoDimensions.Shapes
import Physics.TwoDimensions.PhysicalObjects
-- Internal iports
import Constants
import GameState
import Input
import Objects
import ObjectSF
import Objects.Walls
-- * General state transitions
-- | Run the game that the player can lose at until ('switch') the player is
-- completely dead, and then restart the game.
wholeGame :: SF Controller GameState
wholeGame = forgetPast $
switch (level 0 >>> (identity &&& playerDead))
(\_ -> wholeGame)
-- * Game over
-- | Detect the death of a player by searching for it in the scene (SF).
playerDead :: SF GameState (Event ())
playerDead = playerDead' ^>> edge
-- | Detect the death of a player by searching for it in the scene.
playerDead' :: GameState -> Bool
playerDead' gs = gamePlaying && dead
where
-- Dead in the game if not present, or if found dead
dead = null (filter isPlayer (gameObjects gs))
|| not (null (filter playerIsDead (gameObjects gs)))
-- Player dead if it has no more lives left
playerIsDead o = case objectKind o of
(Player _ lives _ _) -> lives < 0
otherwise -> False
-- This is only defined when the game is in progress.
gamePlaying = GamePlaying == gameStatus (gameInfo gs)
-- | Show loading screen for 2 seconds, then move on to play
-- the game.
level :: Int -> SF Controller GameState
level n = switch
(levelLoading n &&& after 2 ()) -- show loading screen for 2 seconds
(\_ -> levelLoaded n)
-- | Play a level till completed, then move on to the next level.
levelLoaded :: Int -> SF Controller GameState
levelLoaded n = switch
(playLevel n >>> (identity &&& outOfEnemies))
(\_ -> level (n + 1))
timeProgression :: SF Controller (DTime -> DTime)
timeProgression = slowDown
-- proc (c) -> do
-- let rev = if controllerReverse c then ((-1)*) else id
-- returnA -< rev
slowDown :: SF Controller (DTime -> DTime)
slowDown = proc (c) -> do
rec let slow = controllerReverse c
unit = if | power' >= 0 && slow -> (-1)
| power' >= maxPower -> 0
| otherwise -> 1
power <- (maxPower +) ^<< integral -< unit
let power' = min maxPower (max 0 power)
dtF = if slow && (power' > 0) then (0.1*) else id
returnA -< dtF
where
maxPower :: Double
maxPower = 5
timeProgression' :: SF ObjectInput (DTime -> DTime)
timeProgression' = arr userInput >>> stopClock
stopClock :: SF Controller (DTime -> DTime)
stopClock = switch (arr controllerHalt >>> arr (\c' -> if c' then (const 0, Event ()) else (id, noEvent)))
(\_ -> switch (constant (const 0) &&& after 25 ())
(\_ -> stopClock))
-- | Produce a constant game state of loading a particular level.
levelLoading :: Int -> SF a GameState
levelLoading n = constant (GameState [] (GameInfo 0 n GameLoading))
-- | Play one level indefinitely (it never ends or restarts).
playLevel :: Int -> SF Controller GameState
playLevel n = playLevel' n
-- checkpoint $ proc (c) -> do
-- take <- edge <<^ controllerCheckPointSave -< c
-- restore <- edge <<^ controllerCheckPointRestore -< c
-- g <- playLevel' n -< c
-- returnA -< (g, take, restore)
playLevel' :: Int -> SF Controller GameState
playLevel' n = timeTransformSF timeProgression $ limitHistory 5 $ playLevel'' n
playLevel'' :: Int -> SF Controller GameState
playLevel'' n = gamePlay (initialObjects n) >>^ composeGameState
where
-- Compose GameState output from 'gamePlay's output
composeGameState :: (Objects, Time) -> GameState
composeGameState (objs, t) = GameState objs (GameInfo t n GamePlaying)
-- | Detect when there are no more enemies in the scene.
outOfEnemies :: SF GameState (Event GameState)
outOfEnemies = arr outOfEnemies'
where
outOfEnemies' :: GameState -> (Event GameState)
outOfEnemies' gs | null balls = Event gs
| otherwise = NoEvent
where
balls = filter isBall (gameObjects gs)
-- ** Game with partial state information
-- | Given an initial list of objects, it runs the game, presenting the output
-- from those objects at all times, notifying any time the ball hits the floor,
-- and and of any additional points made.
--
-- This works as a game loop with a post-processing step. It uses
-- a well-defined initial accumulator and a traditional feedback
-- loop.
--
-- The internal accumulator holds the last known collisions (discarded at every
-- iteration).
playerEnergy'' :: Objects -> Int
playerEnergy'' objs =
let p = findPlayer objs
in case p of
Just p' -> playerEnergy p'
Nothing -> 0
gameTimeSF = proc (_, (_, e)) -> do
dt <- deltas -< ()
let dt' = if e < 0 && dt < 0 then (-dt) else dt
returnA -< dt'
gamePlay :: [ListSF ObjectInput Object] -> SF Controller (Objects, Time)
gamePlay objs = loopPre ([], 0) $ clocked gameTimeSF (gamePlay' objs)
-- Process physical movement and detect new collisions
-- -- Adapt Input
-- let oi = ObjectInput input cs
-- -- Step
-- -- Each obj processes its movement forward
-- ol <- dlSwitch objs -< oi
-- let cs' = detectCollisions ol
-- let energyLeft = playerEnergy'' ol
-- -- Output
-- tLeft <- time -< ()
-- returnA -< ((ol, tLeft), (cs', energyLeft))
-- gamePlay' :: SF (Controller, (Collisions, Int)) ((Objects, Time), (Collisions, Int))
gamePlay' :: [ListSF ObjectInput Object]
-> SF (Controller, (Objects.Collisions, Int))
(([Object], Time), (Collisions.Collisions String, Int))
gamePlay' objs =
proc (input, (cs, el)) -> do
-- Adapt Input
let oi = ObjectInput input cs
-- Step
-- Each obj processes its movement forward
ol <- dlSwitch objs -< oi
let cs' = detectCollisions ol
let eleft = playerEnergy'' ol
-- Output
tLeft <- time -< ()
returnA -< ((ol, tLeft), (cs', eleft))
-- * Game objects
--
-- | Objects initially present: the walls, the ball, the player and the blocks.
initialObjects :: Int -> [ListSF ObjectInput Object]
initialObjects level =
objEnemies level ++ blocks level ++ objPlayers ++ walls
where
walls = [ inertSF objSideRight
, inertSF objSideTop
, inertSF objSideLeft
, inertSF objSideBottom
]
-- ** Enemies
-- | Defines the enemies depending on the level.
--
-- This function is paired with 'blocks', because there could be inconsistent
-- initial positions in which blocks and enemies already overlap.
--
-- WARNING: All objects need different names, both at the beginning and during
-- gameplay.
objEnemies :: Int -> [ListSF ObjectInput Object]
objEnemies 0 =
[ splittingBall ballWidth "ballEnemy1" (600, 300) (360, -350) ]
objEnemies 1 =
[ splittingBall ballMedium "ballEnemy1" (width/4, 300) (360, -350)
, splittingBall ballMedium "ballEnemy2" (3*width/4, 300) (360, -350) ]
objEnemies 2 =
map ballLeft [1..4] ++ map ballRight [1..4]
where baseL = 20
sep = width / 20
baseR = width - (baseL + 4 * sep)
ballLeft n = splittingBall ballSmall ("ballEnemyL" ++ show n)
(baseL + n * sep, 100) (-200, -200)
ballRight n = splittingBall ballSmall ("ballEnemyR" ++ show n)
(baseR + n * sep, 100) (200, -200)
objEnemies n =
[ splittingBall ballBig "ballEnemy1" (600, 300) (360, -350) ]
-- ** Blocks
--
-- Blocks are horizontal rectangles that /every/ other element collides
-- with. They need not be static.
-- | List of blocks depending on the level.
blocks :: Int -> [ListSF ObjectInput Object]
blocks 0 = [ objBlock "block1" (200, 55) (100, 50) ]
blocks 1 = [ movingBlock "block1" (400, 200) (100, 50) 200 10 0 0 ]
blocks 2 = [ movingBlock "block1" (400, 200) (100, 50) 0 0 100 10 ]
blocks 3 = [ movingBlock "block1" (324, 200) (100, 40) 200 6 0 0
, movingBlock "block2" (700, 200) (100, 40) 200 6 100 10
]
blocks n = [ objBlock "block1" (200, 200) (100, 50) ]
-- *** Moving blocks
-- | A moving block with an initial position and size, and horizontal and
-- vertical amplitude and periods. If an amplitude is /not/ zero, the
-- block moves along that dimension using a periodic oscillator
-- (see the SF 'osci').
movingBlock :: String
-> Pos2D -> Size2D -- Geometry
-> Double -> Double -- Horizontal oscillation amplitude and period
-> Double -> Double -- Vertical oscillation amplitude and period
-> ListSF ObjectInput Object
movingBlock name (px, py) size hAmp hPeriod vAmp vPeriod = ListSF $ proc _ -> do
px' <- vx -< px
py' <- vy -< py
returnA -< (Object { objectName = name
, objectKind = Block size
, objectPos = (px', py')
, objectVel = (0,0)
, canCauseCollisions = False
, collisionEnergy = 0
}, False, [])
where
-- To avoid errors, we check that the amplitude is non-zero, otherwise
-- just pass the given position along.
vx :: SF Double Double
vx = if hAmp /= 0 then (px +) ^<< osci hAmp hPeriod else identity
-- To avoid errors, we check that the amplitude is non-zero, otherwise
-- just pass the given position along.
vy :: SF Double Double
vy = if vAmp /= 0 then (py +) ^<< osci vAmp vPeriod else identity
-- | Generic block builder, given a name, a size and its base
-- position.
objBlock :: ObjectName -> Pos2D -> Size2D -> ListSF ObjectInput Object
objBlock name pos size = ListSF $ timeTransformSF timeProgression' $ constant
(Object { objectName = name
, objectKind = Block size
, objectPos = pos
, objectVel = (0,0)
, canCauseCollisions = False
, collisionEnergy = 0
}, False, [])
-- ** Enemy sizes
ballGiant = ballWidth
ballBig = ballGiant / 2
ballMedium = ballBig / 2
ballSmall = ballMedium / 2
-- ** Player
objPlayers :: [ListSF ObjectInput Object]
objPlayers =
[ player initialLives playerName (320, 20) True ]
-- ** Guns
gun :: String -> SF (ObjectInput, Pos2D) [ListSF ObjectInput Object]
gun name = normalGun name
-- To switch between different kinds of guns
-- gun name = switch
-- (normalGun name &&& after 5 ())
-- (\_ -> multipleGun name)
-- *** Normal gun, fires one shot at a time
normalGun :: String -> SF (ObjectInput, Pos2D) [ListSF ObjectInput Object]
normalGun name = revSwitch (constant [] &&& gunFired name)
(\fireLSF -> blockedGun name fireLSF)
blockedGun name fsf = revSwitch (([fsf] --> constant []) &&& fireDead fsf)
(\_ -> normalGun name)
fireDead fsf = proc (oi, _) -> do
(_, b, _) <- listSF fsf -< oi
justDied <- edge -< b
returnA -< justDied
gunFired :: String -> SF (ObjectInput, Pos2D) (Event (ListSF ObjectInput Object))
gunFired name = proc (i, ppos) -> do
-- Fire!!
newF1 <- edge -< controllerClick (userInput i)
uniqId <- (\t -> "fire" ++ name ++ show t) ^<< time -< ()
let newFire = fire uniqId (fst ppos + playerWidth / 2, 0) False
returnA -< newF1 `tag` newFire
eventToList :: Event a -> [ a ]
eventToList NoEvent = []
eventToList (Event a) = [a]
-- *** Normal gun, fires one shot at a time
multipleGun :: String -> SF (ObjectInput, Pos2D) [ListSF ObjectInput Object]
multipleGun name = eventToList ^<< gunFired name
player :: Int -> String -> Pos2D -> Bool -> ListSF ObjectInput Object
player lives name p0 vul = ListSF $ proc i -> do
(ppos, pvel) <- playerProgress name p0 -< i
let state = playerState (userInput i)
-- newF1 <- isEvent ^<< edge -< controllerClick (userInput i)
-- uniqId <- (\t -> "fire" ++ name ++ show t) ^<< time -< ()
-- let newF1Arrows = [ fire uniqId (fst ppos, 0) False
-- | newF1 ]
newF1Arrows <- gun name -< (i, ppos)
-- Dead?
let hitByBall = not $ null
$ collisionMask name ("ball" `isPrefixOf`)
$ collisions i
vulnerable <- alwaysForward $
switch (constant vul &&& after 2 ())
(\_ -> constant True) -< ()
dead <- isEvent ^<< edge -< hitByBall && vulnerable
let newPlayer = [ player (lives-1) name p0 False
| dead && lives > 0 ]
dt <- deltas -< ()
energy <- loopPre 5 (arr (dup . max 0 . min 5 . sumTime)) -< dt
-- max 0 (min 5 (round (fromIntegral (playerEnergy'' ol) + dt)))
-- Final player
returnA -< (Object { objectName = name
, objectKind = Player state lives vulnerable (round energy)
, objectPos = ppos
, objectVel = pvel
, canCauseCollisions = True
, collisionEnergy = 1
}
, dead
, newF1Arrows ++ newPlayer)
sumTime :: (DTime, DTime) -> DTime
sumTime (dt, e) = e + dt
playerState :: Controller -> PlayerState
playerState controller =
case (controllerLeft controller, controllerRight controller) of
(True, _) -> PlayerLeft
(_, True) -> PlayerRight
_ -> PlayerStand
playerName :: String
playerName = "player"
playerProgress :: String -> Pos2D -> SF ObjectInput (Pos2D, Vel2D)
playerProgress pid p0 = proc i -> do
-- Obtain velocity based on state and input, and obtain
-- velocity delta to be applied to the position.
v <- repeatSF getVelocity PlayerStand -< userInput i
let collisionsWithBlocks = filter onlyBlocks (collisions i)
onlyBlocks (Collision cdata) = any (playerCollisionElem . fst) cdata
playerCollisionElem s = isBlockId s || isWallId s
isBlockId = ("block" `isPrefixOf`)
isWallId = ("Wall" `isSuffixOf`)
let ev = changedVelocity pid collisionsWithBlocks
vc = fromMaybe v ev
(px,py) <- (p0 ^+^) ^<< alwaysForward integral -< vc
-- Calculate actual velocity based on corrected/capped position
v' <- derivative -< (px, py)
returnA -< ((px, py), v')
where
capPlayerPos (px, py) = (px', py')
where px' = inRange (0, width - playerWidth) px
py' = inRange (0, height - playerHeight) py
getVelocity :: PlayerState -> SF Controller (Vel2D, Event PlayerState)
getVelocity pstate = stateVel pstate &&& stateChanged pstate
stateVel :: PlayerState -> SF a Vel2D
stateVel PlayerLeft = constant (-playerSpeed, 0)
stateVel PlayerRight = constant (playerSpeed, 0)
stateVel PlayerStand = constant (0, 0)
stateChanged :: PlayerState -> SF Controller (Event PlayerState)
stateChanged oldState = arr playerState >>> ifDiff oldState
-- *** Fire/arrows/bullets/projectiles
-- | This produces bullets that die when they hit the top of the screen.
-- There's sticky bullets and normal bullets. Sticky bullets get stuck for a
-- while before they die.
fire :: String -> Pos2D -> Bool -> ListSF ObjectInput Object
fire name (x0, y0) sticky = ListSF $ proc i -> do
-- Calculate arrow tip
yT <- (y0+) ^<< integral -< fireSpeed
let y = min height yT
-- Delay death if the fire is "sticky"
hit <- revSwitch (never &&& fireHitCeiling) (\_ -> stickyDeath sticky) -< y
hitBall <- arr (fireCollidedWithBall name) -< collisions i
hitBlock <- arr (fireCollidedWithBlock name) -< collisions i
let dead = isEvent hit || hitBall || hitBlock
let object = Object { objectName = name
, objectKind = Projectile
, objectPos = (x0, y)
, objectVel = (0, 0)
, canCauseCollisions = True
, collisionEnergy = 0
}
returnA -< (object, dead, [])
where
fireHitCeiling = arr (>= height) >>> edge
fireCollidedWithBall bid = not . null . collisionMask bid ("ball" `isPrefixOf`)
fireCollidedWithBlock bid = not . null . collisionMask bid ("block" `isPrefixOf`)
stickyDeath :: Bool -> SF a (Event ())
stickyDeath True = after 30 ()
stickyDeath False = constant (Event ())
-- *** Ball
splittingBall :: Double -> String -> Pos2D -> Vel2D -> ListSF ObjectInput Object
splittingBall size bid p0 v0 = ListSF $ timeTransformSF timeProgression' $ proc i -> do
-- Default, just bouncing behaviour
bo <- bouncingBall size bid p0 v0 -< i
-- Hit fire? If so, it should split
click <- edge <<^ ballCollidedWithFire bid -< collisions i
let shouldSplit = isEvent click
-- We need two unique IDs so that collisions work
t <- localTime -< ()
let offspringIDL = bid ++ show t ++ "L"
offspringIDR = bid ++ show t ++ "R"
let enforceYPositive (x,y) = (x, abs y)
-- Position and velocity of new offspring
let bpos = physObjectPos bo
bvel = enforceYPositive $ physObjectVel bo
ovel = enforceYPositive $ (\(vx,vy) -> (-vx, vy)) bvel
-- Offspring size, unless this ball is too small to split
let tooSmall = size <= (ballWidth / 8)
let offspringSize = size / 2
-- Calculate offspring, if any
let offspringL = splittingBall offspringSize offspringIDL bpos bvel
offspringR = splittingBall offspringSize offspringIDR bpos ovel
offspring = if shouldSplit && not tooSmall
then [ offspringL, offspringR ]
else []
-- If it splits, we just remove this one
let dead = shouldSplit
returnA -< (bo, dead, offspring)
ballCollidedWithFire :: ObjectName -> Objects.Collisions -> Bool
ballCollidedWithFire bid = not . null . collisionMask bid ("fire" `isPrefixOf`)
-- A bouncing ball moves freely until there is a collision, then bounces and
-- goes on and on.
--
-- This SF needs an initial position and velocity. Every time
-- there is a bounce, it takes a snapshot of the point of
-- collision and corrected velocity, and starts again.
--
bouncingBall :: Double -> String -> Pos2D -> Vel2D -> ObjectSF
bouncingBall size bid p0 v0 = repeatRevSF (progressAndBounce size bid) (p0, v0)
-- | Calculate the future tentative position, and bounce if necessary. Pass on
-- snapshot of ball position and velocity if bouncing.
progressAndBounce :: Double -> String -> (Pos2D, Vel2D)
-> SF ObjectInput (Object, Event (Pos2D, Vel2D))
progressAndBounce size bid (p0, v0) = proc i -> do
-- Position of the ball, starting from p0 with velicity v0, since the
-- time of last switching (or being fired, whatever happened last)
-- provided that no obstacles are encountered.
o <- freeBall size bid p0 v0 -< i
-- The ballBounce needs the ball SF' input (which has knowledge of
-- collisions), so we carry it parallely to the tentative new
-- positions, and then use it to detect when it's time to bounce
b <- ballBounce bid -< (i, o)
returnA -< (o, b)
-- | Detect if the ball must bounce and, if so, take a snapshot of the object's
-- current position and velocity.
--
-- NOTE: To avoid infinite loops when switching, the initial input is discarded
-- and never causes a bounce. Careful: this prevents the ball from bouncing
-- immediately after creation, which may or may not be what we want.
ballBounce :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))
ballBounce bid = noEvent --> ballBounce' bid
-- | Detect if the ball must bounce and, if so, take a snapshot of the object's
-- current position and velocity.
--
-- This does the core of the work, and does not ignore the initial input.
--
-- It proceeds by detecting whether any collision affects the ball's velocity,
-- and outputs a snapshot of the object position and the corrected velocity if
-- necessary.
ballBounce' :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))
ballBounce' bid = proc (ObjectInput ci cs, o) -> do
-- HN 2014-09-07: With the present strategy, need to be able to
-- detect an event directly after
-- ev <- edgeJust -< changedVelocity "ball" cs
let collisionsWithoutBalls = filter (not . allBalls) cs
allBalls (Collision cdata) = all (isPrefixOf "ball" . fst) cdata
let collisionsWithoutPlayer = filter (not . anyPlayer)
collisionsWithoutBalls
anyPlayer (Collision cdata) = any (isPrefixOf "player" . fst) cdata
let ev = maybeToEvent (changedVelocity bid collisionsWithoutPlayer)
returnA -< fmap (\v -> (objectPos o, v)) ev
-- | Position of the ball, starting from p0 with velicity v0, since the time of
-- last switching (that is, collision, or the beginning of time --being fired
-- from the paddle-- if never switched before), provided that no obstacles are
-- encountered.
freeBall :: Double -> String -> Pos2D -> Vel2D -> ObjectSF
freeBall size name p0 v0 = proc (ObjectInput ci cs) -> do
-- Integrate acceleration, add initial velocity and cap speed. Resets both
-- the initial velocity and the current velocity to (0,0) when the user
-- presses the Halt key (hence the dependency on the controller input ci).
vInit <- startAs v0 -< ci
vel <- vdiffSF -< (vInit, (0, -1000.8), ci)
-- Any free moving object behaves like this (but with
-- acceleration. This should be in some FRP.NewtonianPhysics
-- module)
pos <- (p0 ^+^) ^<< integral -< vel
let obj = Object { objectName = name
, objectKind = Ball size
, objectPos = pos
, objectVel = vel
, canCauseCollisions = True
, collisionEnergy = 1
}
returnA -< obj
where -- Spike every time the user presses the Halt key
restartCond = spikeOn (arr controllerStop)
-- Calculate the velocity, restarting when the user
-- requests it.
vdiffSF = proc (iv, acc, ci) -> do
-- Calculate velocity difference by integrating acceleration
-- Reset calculation when user requests to stop balls
vd <- restartOn (arr fst >>> integral)
(arr snd >>> restartCond) -< (acc, ci)
-- Add initial velocity, and cap the result
v <- arr (uncurry (^+^)) -< (iv, vd)
let vFinal = limitNorm v (maxVNorm size)
returnA -< vFinal
-- Initial velocity, reset when the user requests it.
startAs v0 = revSwitch (constant v0 &&& restartCond)
(\_ -> startAs (0,0))