Pong.hs

{-# LANGUAGE TemplateHaskell #-}
module Pong where

import Control.Lens
import FRP.Elerea.Simple hiding (delay)
import FRP.Helm
import FRP.Helm.Time
import qualified FRP.Helm.Keyboard as Keyboard
import qualified FRP.Helm.Window as Window
import qualified FRP.Helm.Text as Text

-- Model

data Input = Input Bool Int Int deriving Show

input :: SignalGen (Signal (Time, Input))
input = lift2 (,) delta' keys
  where
    delta' = delay $ fps 60
    keys = lift3 Input Keyboard.space
                 (lift (flip (^.) _2) Keyboard.arrows)
                 (lift (flip (^.) _2) Keyboard.wasd)

data Vector =
  Vector {
    _x :: Double,
    _y :: Double } deriving Show

data Ball =
  Ball {
    _pos :: Vector,
    _vel :: Vector } deriving Show

data Score =
  Score {
    _left :: Int,
    _right :: Int } deriving Show

data MatchState = Play | Pause deriving (Show, Eq)

data State =
  State {
    _padL :: Double,
    _padR :: Double,
    _ball :: Ball,
    _score :: Score,
    _state :: MatchState } deriving Show

makeLenses ''Vector
makeLenses ''Ball
makeLenses ''Score
makeLenses ''State

-- Update

clamp :: Ord a => a -> a -> a -> a
clamp x y z
  | z < x = x
  | x <= z && z < y = z
  | otherwise = y

stepPad :: Time -> Int -> Double -> Double
stepPad t i p = clamp 20 380 $ p - fromIntegral i * 200 * t

collision :: State -> Bool
collision s = bX >= 20 && bX <= 30 && bY >= (pL - 40) || bY <= pL || bY >= (pR - 40) || bY <= pR
  where
    bX = s^.ball.pos.x
    bY = s^.ball.pos.y
    pL = s^.padL
    pR = s^.padR

stepVelocity :: State -> Vector
stepVelocity s
  | collision s = Vector {
      _x = opposite $ s^.ball.vel.x,
      _y = opposite $ s^.ball.vel.y }
  | otherwise = s^.ball.vel
  where
    opposite n = if n < 0 then abs n else negate n

stepBall :: Time -> State -> State
stepBall t s = let s' = ball.vel .~ stepVel $ s in ball.pos .~ stepPos $ s'
  where
    stepVel = stepVelocity s
    stepPos = Vector {
      _x = (s^.ball.pos.x) + (s^.ball.vel.x) * t,
      _y = (s^.ball.pos.y) + (s^.ball.vel.y) * t }

stepGame :: Time -> (Int, Int) -> State -> State
stepGame t (l, r) s = let s1 = stepBall t s; s2 = padL .~ pL $ s1; s3 = padR .~ pR $ s2 in
  case s3^.ball.pos.x >= 600 of
    True -> let s4 = score.right +~ 1 $ s3; s5 = ball .~ ballReset $ s4 in
      state .~ Pause $ s5
    False -> case s3^.ball.pos.x <= 0 of
      True -> let s4 = score.left +~ 1 $ s3; s5 = ball .~ ballReset $ s4 in 
        state .~ Pause $ s5
      False -> s3
  where
    pL = stepPad t l $ s^.padL
    pR = stepPad t r $ s^.padR
    ballReset = Ball {
      _pos = Vector {
        _x = 300,
        _y = 200 },
      _vel = Vector {
        _x = 2,
        _y = 2 } }

step :: (Time, Input) -> State -> State
step (t, (Input sp l r)) s
  | s^.state == Play = stepGame t (l, r) s
  | s^.state == Pause && sp = stepGame t (l, r) s
  | otherwise = s

-- View

render :: (Int, Int) -> State -> Element
render (w, h) s =
  collage w h [move (half w, half h) bg,
               move (20, s^.padL) pad,
               move (fromIntegral w - 20, s^.padR) pad,
               move (s^.ball.pos.x, s^.ball.pos.y) ball',
               move (half w, 40) txt]
  where
    half = (/ 2) . fromIntegral
    bg = filled teal $ rect (fromIntegral w) (fromIntegral h)
    pad = filled white $ rect 10 40 
    ball' = filled white $ oval 15 15
    txt = toForm $ Text.text $ Text.defaultText {
      textUTF8 = (show $ s^.score.left) ++ " " ++ (show $ s^.score.right),
      textColor = cyan,
      textTypeface = "monospace",
      textHeight = 32 }

-- Main

main = run config $ lift2 render Window.dimensions $ foldp step gameInit input

config :: EngineConfig
config = defaultConfig {
  windowDimensions = (600,400),
  windowIsResizable = False,
  windowTitle = "Pong" }

gameInit :: State
gameInit = State {
  _padL = 200,
  _padR = 200,
  _ball = Ball {
    _pos = Vector {
      _x = 300,
      _y = 200 },
    _vel = Vector {
      _x = 0,
      _y = 0 } },
  _score = Score {
    _left = 0,
    _right = 0 },
  _state = Pause }