{-# LANGUAGE Arrows #-}
-- |
-- Copyright  : (c) Ivan Perez & Henrik Nilsson, 2014.
-- License    : See LICENSE file.
-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>
--
-- 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 three sections:
--
--   - A collection of general game SFs. These determine how the game
--   transitions from one state to another based on different internal events
--   (running out of lives, finishing a level, etc.)
--
--   - A collection of gameplay SFs, which control the core game loop, carry
--   out collision detection, add points, 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 Control.Applicative ((<$>))
import Data.List
import Data.Tuple.Utils
import FRP.Yampa

-- General-purpose internal imports
import Data.Extra.Ord
import Data.Extra.VectorSpace
import Data.IdentityList
import FRP.Extra.Yampa
import Physics.TwoDimensions.Collisions
import Physics.TwoDimensions.Dimensions

-- Internal imports
import Constants
import GameCollisions
import GameState
import Input
import Levels
import Objects
import ObjectSF

-- * General state transitions

-- | Run the game that the player can lose at ('canLose'), until ('switch')
-- there are no more levels ('outOfLevels'), in which case the player has won
-- ('wonGame').
wholeGame :: SF Controller GameState
wholeGame = switch
  -- restart normal behaviour every time I'm out of lives
  (canLose >>> (arr id &&& outOfLevels))
  (\_ -> wonGame)

-- | Detect when the last level is finished.
outOfLevels :: SF GameState (Event ())
outOfLevels = arr ((>= numLevels) . gameLevel . gameInfo) >>> edge

-- | Run the game in which the player is alive, until she runs out of lives
-- ('outOfLives'), in which case the game must be restarted ('restartGame').
canLose :: SF Controller GameState
canLose = switch
  -- retart normal behaviour every time I'm out of lives
  (gameAlive >>> (arr id &&& outOfLives))
  (\_ -> restartGame)

-- | Detect when the last life is lost.
outOfLives :: SF GameState (Event ())
outOfLives = arr ((< 0) . gameLives . gameInfo) >>> edge

-- | The game state is over for 3 seconds, then the game is run again
-- ('wholeGame').
restartGame :: SF Controller GameState
restartGame = switch
  (gameOver &&& after 3 ()) (\_ -> wholeGame)

-- | Produces a neutral 'GameOver' 'GameState'.
gameOver :: SF a GameState
gameOver = arr $ const $
  neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameOver } }

-- | The game state is finished for 4 seconds, then the game is run again
-- ('wholeGame').
wonGame :: SF Controller GameState
wonGame = switch
  (gameFinished &&& after 4 ()) (\_ -> wholeGame)

-- | Produces a neutral 'GameFinished' 'GameState'.
gameFinished :: SF a GameState
gameFinished = arr $ const $
  neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameFinished } }

-- | Run the game from the beginning (no points, max lives, etc.).
--
-- Load the first level.
--
gameAlive :: SF Controller GameState
gameAlive = runLevel stdLives initialLevel 0
  -- loadLevel stdLives initialLevel loadingDelay
  -- (gameWithLives stdLives initialLevel)

-- ** Level loading

-- | Set the game state as loading for a few seconds, then start the actual
-- game. Uses 'loadLevel', passing the game SF ('gameWithLives') as
-- continuation.
runLevel :: Int -> Int -> Int -> SF Controller GameState
runLevel lives level pts = loadLevel lives level pts loadingDelay
  (gameWithLives lives level pts)

-- | Unconditionally output the game in loading state ('levelLoading') for some
-- time, and then ('after') switch over to the given continuation.
--
-- The given arguments are the lives, the level, the points, the time to stay
-- loading the game and the continuation.
loadLevel :: Int -> Int -> Int -> DTime -> SF a GameState -> SF a GameState
loadLevel lives level pts time next = switch
  --
  (levelLoading lives level pts &&& after time ())
  (\_ -> next)

-- | Unconditionally output a neutral game state with the 'GameLoading' status,
-- forever.
levelLoading :: Int -> Int -> Int -> SF a GameState
levelLoading lvs lvl pts = arr $ const $
  neutralGameState { gameInfo = GameInfo { gameStatus = GameLoading lvl
                                         , gameLevel  = lvl
                                         , gameLives  = lvs
                                         , gamePoints = pts
                                         }
                   }

-- | Start the game at a given level, with a given number of lives.
--
-- It executes the normal gameplay until the level is completed.  It then
-- switches to the next level (remembering the current lives and points).
--
-- Conditions like finishing the game or running out of lives are detected in
-- 'wholeGame' and 'canLose', respectively.
--
gameWithLives :: Int -> Int -> Int -> SF Controller GameState
gameWithLives numLives level pts = dSwitch
  -- Run normal game until level is completed
  (gamePlayOrPause numLives level pts >>> (arr id &&& isLevelCompleted))

  -- Take last game state, extract basic info, and load the next level
  (\g -> let level' = level + 1
             lives' = gameLives  $ gameInfo g
             pts    = gamePoints $ gameInfo g
         in runLevel lives' level' pts)

-- | Detect if the level is completed (ie. if there are no more blocks).
isLevelCompleted :: SF GameState (Event GameState)
isLevelCompleted = proc s -> do
  over <- edge -< not $ any isBlock (map objectKind (gameObjects s))
  let snapshot = over `tag` s
  returnA -< snapshot

-- ** Pausing

-- | Run the normal game.
--
-- NOTE: The code includes a commented piece that detects a request to pause
-- the game. Check out the code to learn how to implement pausing.
gamePlayOrPause :: Int -> Int -> Int -> SF Controller GameState
gamePlayOrPause lives level pts = gamePlay lives level pts
--  ((arr id) &&& (pause undefined (False --> isPaused) (mainLoop lives level)))
--  >>> pauseGeneral
--
-- isPaused :: SF Controller Bool
-- isPaused = arr controllerPause
--
-- pauseGeneral :: SF (Controller, GameState) GameState
-- pauseGeneral = proc (c, g) -> do
--   let isPause = controllerPause c
--   let o       = gameInfo g
--   returnA -< if isPause
--                 then g { gameInfo = o { gameStatus = GamePaused } }
--                 else g

-- * Gameplay

-- | Run the game, obtain the internal game's running state, and compose it
-- with the more general 'GameState' using the known number of lives and
-- points.
gamePlay :: Int -> Int -> Int -> SF Controller GameState
gamePlay lives level pts =
  gamePlay' (initialObjects level) >>> composeGameState lives level pts

-- | Based on the internal gameplay info, compose the main game state and
-- detect when a live is lost. When that happens, restart this SF with one less
-- life available.
--
-- NOTE: it will be some other SF's responsibility to determine if the player's
-- run out of lives.

-- NOTE (about the code): We need to delay the initial event (if it happened to
-- occur) because, at the moment of switching, it will definitely occur and we
-- will fall in an infinite loop.  Therefore, this dswitch only switches for
-- non-start events.
composeGameState :: Int -> Int -> Int
                 -> SF (ObjectOutputs, Event (), Int) GameState
composeGameState lives level pts = futureDSwitch
  (composeGameState' lives level pts)
  (\_ -> composeGameState (lives - 1) level pts)

-- | Based on the internal gameplay info, compose the main game state and
-- detect when a live is lost. When that happens, keep the last known game
-- state.
composeGameState' :: Int -> Int -> Int
                  -> SF (ObjectOutputs, Event (), Int)
                        (GameState, Event GameState)
composeGameState' lives level pts = proc (oos, dead, points) -> do
  -- Compose game state
  objects <- extractObjects -< oos
  let general = GameState objects
                          (GameInfo GamePlaying lives level (pts + points))

  -- Detect death
  let lastGeneral = dead `tag` general

  returnA -< (general, lastGeneral)

-- ** 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 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 object outputs (discarded at every iteration).
--
--    - The last known collisions (discarded at every iteration).
--
--    - The last known points (added to the new ones in every loop iteration).
--
gamePlay' :: ObjectSFs -> SF Controller (ObjectOutputs, Event (), Int)
gamePlay' objs = loopPre ([], [], 0) $
    -- Process physical movement and detect new collisions
    ( ( adaptInput
          >>> processMovement
          >>> (arr elemsIL &&& detectObjectCollisions)
      )
      &&& arr (thd3.snd) -- This last bit just carries the old points forward
    )

    -- Adds the old point count to the newly-made points
    >>> (arr fst &&& arr (\((_, cs), o) -> o + countPoints cs))

    -- Re-arrange output, selecting
    -- (objects + dead + points, objects + collisions + points)
    >>> (composeOutput &&& arr (\((x, y), z) -> (x, y, z)))

  where

    -- Detect collisions between the ball and the bottom
    -- which are the only ones that matter outside gamePlay'
    composeOutput = proc ((x, y), z) -> do
      y' <- collisionWithBottom -< y
      returnA -< (x, y', z)

    -- Just reorder the input
    adaptInput :: SF (Controller, (ObjectOutputs, Collisions, Int)) ObjectInput
    adaptInput =
      arr (\(gi, (os, cs, pts)) -> ObjectInput gi cs (map outputObject os))

    -- Parallely apply all object functions
    processMovement :: SF ObjectInput (IL ObjectOutput)
    processMovement = processMovement' objs

    processMovement' :: ObjectSFs -> SF ObjectInput (IL ObjectOutput)
    processMovement' objs = dpSwitchB
      objs                                   -- Signal functions.
      (noEvent --> arr suicidalSect)         -- When necessary, remove all
                                             -- elements that must be removed.
      (\sfs' f -> processMovement' (f sfs')) -- Move along! Move along!
                                             -- (with new state, aka. sfs).

    suicidalSect :: (a, IL ObjectOutput) -> Event (IL ObjectSF -> IL ObjectSF)
    suicidalSect (_, oos) =
        -- Turn every event carrying a function that transforms the object
        -- signal function list into one function that performs all the effects
        -- in sequence
        foldl (mergeBy (.)) noEvent es

      -- Turn every object that wants to kill itself into a function that
      -- removes it from the list
      where
        es :: [Event (IL ObjectSF -> IL ObjectSF)]
        es = [ harakiri oo `tag` deleteIL k
             | (k, oo) <- assocsIL oos ]

    -- From the actual objects, detect which ones collide
    detectObjectCollisions :: SF (IL ObjectOutput) Collisions
    detectObjectCollisions = extractObjects >>> arr detectCollisions

    -- Count-points
    countPoints :: Collisions -> Int
    countPoints = sum . map numPoints
      where
        numPoints (Collision cd)
          | hasBall cd = countBlocks cd
          | otherwise  = 0
        hasBall     = any ((=="ball").fst)
        countBlocks = length . filter (isPrefixOf "block" . fst)

-- * Game objects
--
-- | Objects initially present: the walls, the ball, the paddle and the blocks.
initialObjects :: Int -> ObjectSFs
initialObjects level = listToIL $
  [ objSideRight
  , objSideTop
  , objSideLeft
  , objSideBottom
  , objPaddle
  , objBall
  ]
  ++ map (\p -> objBlock p (blockWidth, blockHeight))
         (blockCfgs $ levels !! level)

-- *** Ball

-- | Ball
--
-- A ball that follows the paddle until the user fires it
-- ('followPaddleDetectLaunch'), then switches ('switch') over to start
-- bounding around, until it hits the floor ('bounceAroundDetectMiss').
--
objBall :: ObjectSF
objBall = switch followPaddleDetectLaunch   $ \p ->
          switch (bounceAroundDetectMiss p) $ \_ ->
          objBall
  where
    -- Yampa's edge is used to turn the continuous signal produced by
    -- controllerClick into an event-carrying signal, only true the instant the
    -- mouse button is clicked.
    followPaddleDetectLaunch = proc oi -> do
      o     <- followPaddle -< oi
      click <- edge         -< controllerClick (userInput oi)
      returnA -< (o, click `tag` objectPos (outputObject o))

    bounceAroundDetectMiss p = proc oi -> do
      o    <- bouncingBall p initialBallVel -< oi
      miss <- collisionWithBottom           -< collisions oi
      returnA -< (o, miss)

-- | Fires an event when the ball *enters in* a collision with the bottom wall.
--
-- NOTE: even if the overlap is not corrected, 'edge' makes the event only take
-- place once per collision.
collisionWithBottom :: SF Collisions (Event ())
collisionWithBottom = inCollisionWith "ball" "bottomWall" ^>> edge

-- | Ball follows the paddle if there is one, and it's out of the screen
-- otherwise). To avoid reacting to collisions, this ball is non-interactive.
followPaddle :: ObjectSF
followPaddle = arr $ \oi ->
    -- Calculate ball position, midway on top of the paddle
    --
    -- This code allows for the paddle not to exist (Maybe), although that
    -- should never happen in practice.
    let mbPaddlePos = objectPos <$> find isPaddle (knownObjects oi)
        ballPos     = maybe (outOfScreen, outOfScreen)
                            ((paddleWidth / 2, - ballHeight) ^+^)
                            mbPaddlePos
    in ObjectOutput (inertBallAt ballPos) noEvent
  where
    outOfScreen = -10
    inertBallAt p = Object { objectName           = "ball"
                           , objectKind           = Ball ballWidth
                           , objectPos            = p
                           , objectVel            = (0, 0)
                           , objectAcc            = (0, 0)
                           , objectDead           = False
                           , objectHit            = False
                           , canCauseCollisions   = False
                           , collisionEnergy      = 0
                           , displacedOnCollision = False
                           }

-- 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 :: Pos2D -> Vel2D -> ObjectSF
bouncingBall p0 v0 =
    switch progressAndBounce
           (uncurry bouncingBall) -- Somehow it would be clearer like this:
                                  -- \(p', v') -> bouncingBall p' v')
  where

    -- Calculate the future tentative position, and bounce if necessary.
    --
    -- The ballBounce needs the ball SF' input (which has knowledge of
    -- collisions), so we carry it parallelly to the tentative new positions,
    -- and then use it to detect when it's time to bounce

    --      ==========================    ============================
    --     -==--------------------->==--->==-   ------------------->==
    --    / ==                      ==    == \ /                    ==
    --  --  ==                      ==    ==  X                     ==
    --    \ ==                      ==    == / \                    ==
    --     -==----> freeBall' ----->==--->==--------> ballBounce -->==
    --      ==========================    ============================
    progressAndBounce = (arr id &&& freeBall') >>> (arr snd &&& ballBounce)

    -- Position of the ball, starting from p0 with velocity v0, since the
    -- time of last switching (or being fired, whatever happened last)
    -- provided that no obstacles are encountered.
    freeBall' = freeBall p0 v0

-- | 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. This works in this game and in this particular
-- case because the ball never-ever bounces immediately as fired from the
-- paddle. This might not be true if a block is extremely close, if you add
-- flying enemies to the game, etc.
ballBounce :: SF (ObjectInput, ObjectOutput) (Event (Pos2D, Vel2D))
ballBounce = noEvent --> ballBounce'

-- | 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' :: SF (ObjectInput, ObjectOutput) (Event (Pos2D, Vel2D))
ballBounce' = proc (ObjectInput ci cs os, 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 ev = maybe noEvent Event (changedVelocity "ball" cs)
  returnA -< fmap (\v -> (objectPos (outputObject o), v)) ev

-- | Position of the ball, starting from p0 with velocity 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 :: Pos2D -> Vel2D -> ObjectSF
freeBall p0 v0 = proc (ObjectInput ci cs os) -> do

  -- Detect collisions
  let name = "ball"
  let isHit = inCollision name cs

  -- Cap speed
  let v = limitNorm v0 maxVNorm

  -- Any free moving object behaves like this (but with acceleration. This
  -- should be in some FRP.NewtonianPhysics module)
  p <- (p0 ^+^) ^<< integral -< v

  let obj = Object { objectName           = name
                   , objectKind           = Ball ballWidth
                   , objectPos            = p
                   , objectVel            = v0
                   , objectAcc            = (0, 0)
                   , objectDead           = False
                   , objectHit            = isHit
                   , canCauseCollisions   = True
                   , collisionEnergy      = 1
                   , displacedOnCollision = True
                   }

  returnA -< livingObject obj

-- *** Player paddle

-- | The paddle tries to be in line with the mouse/pointer/controller.
--
-- It has drag, to make the game a bit harder. Take a look at the code if you
-- want to make it move faster or even instantaneously.
--
objPaddle :: ObjectSF
objPaddle = proc (ObjectInput ci cs os) -> do

  -- Detect collisions
  let name = "paddle"
  let isHit = inCollision name cs

  -- Try to get to the mouse position, but with a capped velocity.

  -- rec
  --     -- let v = limitNorm (20.0 *^ (refPosPaddle ci ^-^ p)) maxVNorm
  --     -- let p = refPosPaddle ci -- (initPosPaddle ^+^) ^<< integral -< v
  --     let v = 100.00 *^ (refPosPaddle ci ^-^ p)
  --
  --         -- The initial position of the paddle, horizontally centered.
  --         initPosPaddle = ((gameWidth - paddleWidth)/2, yPosPaddle)
  --
  --     p <- (initPosPaddle ^+^) ^<< integral -< v
  let p = refPosPaddle ci
  v <- derivative -< p

  --  Use this code if you want instantaneous movement, particularly cool with
  --  the Wiimote, but remember to cap the balls velocity or you will get
  --  incredibly high velocities when the paddle hits the ball.
  --
  --  let p = refPosPaddle ci
  --  v <- derivative -< p

  returnA -< livingObject $
               Object{ objectName           = name
                     , objectKind           = Paddle (paddleWidth, paddleHeight)
                     , objectPos            = p
                     , objectVel            = (0, 0)
                     , objectAcc            = (0, 0)
                     , objectDead           = False
                     , objectHit            = isHit
                     , canCauseCollisions   = True
                     , collisionEnergy      = 0
                     , displacedOnCollision = False
                     }

-- | Follow the controller's horizontal position, keeping a constant vertical
-- position.
refPosPaddle :: Controller -> Pos2D
refPosPaddle c = (x', yPosPaddle)
  where
    (x, _) = controllerPos c
    x'     = inRange (0, gameWidth - paddleWidth) (x - (paddleWidth / 2))

-- | The paddle's vertical position, at a reasonable distance from the bottom.
yPosPaddle :: Double
yPosPaddle = gameHeight - paddleMargin

-- *** Blocks

-- | Block SF generator. It uses the blocks' size, position and a number of
-- lives that the block has. The block's position is used for it's unique ID,
-- which means that two simultaneously existing blocks should never have the
-- same position. This is ok in this case because they are static, but would not
-- work if they could move and be created dynamically.
objBlock :: (Pos2D, Int) -> Size2D -> ObjectSF
objBlock ((x, y), initlives) (w, h) = proc (ObjectInput ci cs os) -> do

  -- Detect collisions
  let name  = "blockat" ++ show (x, y)
      isHit = inCollision name cs
  hit   <- edge -< isHit

  -- Must be hit initlives times to disappear
  --
  -- If you want them to "recover" or self-heal with time, use the following
  -- code in place of lives.
  --
  -- recover <- delayEvent 5.0 -< hit
  -- lives <- accumHoldBy (+) 3 -< (hit `tag` (-1) `lMerge` recover `tag` 1)
  lives <- accumHoldBy (+) initlives -< (hit `tag` (-1))
  --
  -- let lives = 3 -- Always perfect

  -- Dead if out of lives.
  let isDead = lives <= 0
  dead <- edge -< isDead
  -- let isDead = False -- immortal blocks

  returnA -< ObjectOutput
               Object{ objectName           = name
                     , objectKind           = Block lives (w, h)
                     , objectPos            = (x, y)
                     , objectVel            = (0, 0)
                     , objectAcc            = (0, 0)
                     , objectDead           = isDead
                     , objectHit            = isHit
                     , canCauseCollisions   = False
                     , collisionEnergy      = 0
                     , displacedOnCollision = False
                     }
               dead

-- *** Walls

-- | Walls. Each wall has a side and a position.
--
-- NOTE: They are considered game objects instead of having special treatment.
-- The function that turns walls into 'Shape's for collision detection
-- determines how big they really are. In particular, this has implications in
-- ball-through-paper effects (ball going through objects, potentially never
-- coming back), which can be seen if the FPS suddenly drops due to CPU load
-- (for instance, if a really major Garbage Collection kicks in.  One potential
-- optimisation is to trigger these with every SF iteration or every rendering,
-- to decrease the workload and thus the likelihood of BTP effects.
objSideRight :: ObjectSF
objSideRight = objWall "rightWall" RightSide (gameWidth, 0)

-- | See 'objSideRight'.
objSideLeft :: ObjectSF
objSideLeft = objWall "leftWall" LeftSide (0, 0)

-- | See 'objSideRight'.
objSideTop :: ObjectSF
objSideTop = objWall "topWall" TopSide (0, 0)

-- | See 'objSideRight'.
objSideBottom :: ObjectSF
objSideBottom = objWall "bottomWall" BottomSide (0, gameHeight)

-- | Generic wall builder, given a name, a side and its base
-- position.
objWall :: ObjectName -> Side -> Pos2D -> ObjectSF
objWall name side pos = proc (ObjectInput ci cs os) -> do
  let isHit = inCollision name cs
  returnA -< ObjectOutput
               Object { objectName           = name
                      , objectKind           = Side side
                      , objectPos            = pos
                      , objectVel            = (0, 0)
                      , objectAcc            = (0, 0)
                      , objectDead           = False
                      , objectHit            = isHit
                      , canCauseCollisions   = False
                      , collisionEnergy      = 0
                      , displacedOnCollision = False
                      }
               noEvent
