{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE TypeSynonymInstances  #-}

module Pong
  ( GameEvent (..),
    GameObject,
    newWorld,
    stepWorld,
    aabb,
  )
where

import           Spear.Math.AABB
import           Spear.Math.Algebra
import           Spear.Math.Spatial
import           Spear.Math.Spatial2
import           Spear.Math.Vector
import           Spear.Physics.Collision
import           Spear.Prelude
import           Spear.Step

import           Data.Monoid             (mconcat)


-- Configuration

padSize             = vec2 0.07 0.015
ballSize            = 0.012 :: Float
ballSpeed           = 0.7 :: Float
initialBallVelocity = vec2 1 1
maxBounceAngle      = (65::Float) * (pi::Float)/(180::Float)
playerSpeed         = 1.0 :: Float
enemySpeed          = 7.0 :: Float
enemyMomentum       = 1.0 :: Float
initialEnemyPos     = vec2 0.5 0.9
initialPlayerPos    = vec2 0.5 0.1
initialBallPos      = vec2 0.5 0.5

-- Game events

data GameEvent
  = MoveLeft
  | MoveRight
  | Collision GameObjectId GameObjectId
  deriving (Eq, Show)

-- Game objects

data GameObjectId
  = Ball
  | Enemy
  | Player
  deriving (Eq, Show)

data GameObject = GameObject
  { gameObjectId :: !GameObjectId
  , aabb         :: {-# UNPACK #-} !AABB2
  , basis        :: {-# UNPACK #-} !Transform2
  , gostep       :: Step [GameObject] [GameEvent] GameObject GameObject
  }


instance Has2dTransform GameObject where
  set2dTransform transform object = object { basis = transform }
  transform2 = basis


instance Positional GameObject Vector2 where
  setPosition p = with2dTransform (setPosition p)
  position = position . basis
  translate v = with2dTransform (translate v)


instance Rotational GameObject Vector2 Angle where
  setRotation r = with2dTransform (setRotation r)
  rotation = rotation . basis
  rotate angle = with2dTransform (rotate angle)
  right = right . basis
  up = up . basis
  forward = forward . basis
  setForward v = with2dTransform (setForward v)


instance Spatial GameObject Vector2 Angle Transform2 where
  setTransform t obj = obj { basis = t }
  transform = basis


instance Bounded2 GameObject where
  boundingVolume obj = aabb2Volume $ translate (position obj) (aabb obj)


ballBox, padBox :: AABB2
ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
padBox  = AABB2 (-padSize) padSize

newWorld =
  [ GameObject Ball   ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
    GameObject Enemy  padBox  (makeAt initialEnemyPos)  stepEnemy,
    GameObject Player padBox  (makeAt initialPlayerPos) stepPlayer
  ]
  where makeAt = newTransform2 unitx2 unity2


-- Step the game world:
--   1. Simulate physics.
--   2. Collide objects and clip -> produce collision events.
--   3. Update game objects      <- input collision events.
stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
stepWorld elapsed dt events gos@[ball, enemy, player] =
  let
    collisions = collide [ball] [enemy, player]
    collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions
    events' = events ++ collisionEvents
    gos' = map (update elapsed dt events' gos) gos
  in
    gos'

update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
update elapsed dt events gos go =
  let (go', s') = runStep (gostep go) elapsed dt gos events go
   in go' { gostep = s' }


-- Ball steppers

stepBall vel = bounceBall vel .> moveBall

bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
bounceBall vel = step $ \_ dt gos events ball ->
  let (AABB2 pmin pmax) = translate (position ball) (aabb ball)
      sideCollision = x pmin < 0 || x pmax > 1
      backCollision = y pmin < 0 || y pmax > 1
      flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v
      flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v
      collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos)
      vel' = normalise
           . collideWithPaddles
           . flipX
           . flipY
           $ vel
      collision = vel' /= vel
      -- Apply offset when collision occurs to avoid sticky collisions.
      delta = (1::Float) + if collision then (3::Float)*dt else (0::Float)
   in ((ballSpeed * delta * vel', ball), bounceBall vel')

paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2
paddleBounce ball events vel paddle =
  let collision = Collision Ball (gameObjectId paddle) `elem` events
  in if collision
  then
    let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle)
        center = (x pmin + x pmax) / (2::Float)
        -- Normalized offset of the ball from the paddle's center, [-1, +1].
        -- It's outside the [-1, +1] range if there is no collision.
        offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float))
        angle  = offset * maxBounceAngle
        -- When it bounces off of a paddle, y vel is flipped.
        ysign = -(signum (y vel))
    in vec2 (sin angle) (ysign * cos angle)
  else vel

moveBall :: Step s e (Vector2, GameObject) GameObject
moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)


-- Enemy stepper

stepEnemy = movePad 0 .> clamp

movePad :: Float -> Step [GameObject] e GameObject GameObject
movePad previousMomentumVector = step $ \_ dt gos _ pad ->
  let ball           = head gos
      heading        = (x . position $ ball) - (x . position $ pad)
      chaseVector    = enemySpeed * heading
      momentumVector = previousMomentumVector + enemyMomentum * heading * dt
      vx             = chaseVector * dt + momentumVector
   in (translate (vec2 vx 0) pad, movePad momentumVector)

sign :: Float -> Float
sign x = if x >= 0 then 1 else -1


-- Player stepper

stepPlayer = sfold movePlayer .> clamp

movePlayer = mconcat
  [ swhen MoveLeft  $ movePlayer' (vec2 (-playerSpeed) 0)
  , swhen MoveRight $ movePlayer' (vec2   playerSpeed  0)
  ]

movePlayer' :: Vector2 -> Step s e GameObject GameObject
movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir)

clamp :: Step s e GameObject GameObject
clamp = spure $ \go ->
  let p' = vec2 (clamp' x s (1 - s)) y
      (Vector2 x y) = position go
      clamp' x a b
        | x < a = a
        | x > b = b
        | otherwise = x
      (Vector2 s _) = padSize
   in setPosition p' go