pong.hs

{-# LANGUAGE TemplateHaskell #-}
module Main 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.wasd)
                 (lift (flip (^.) _2) Keyboard.arrows)

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 x1 y1 z
  | z < x1 = x1
  | x1 <= z && z < y1 = z
  | otherwise = y1

stepPads :: Time -> Input -> State -> State
stepPads t (Input _ l r) s = let
  lft x1 = padL .~ clamp 20 380 (s^.padL - fromIntegral l * 200 * t) $ x1
  rgt x1 = padR .~ clamp 20 380 (s^.padR - fromIntegral r * 200 * t) $ x1
  in rgt . lft $ s

step :: (Time, Input) -> State -> State
step (t, i) s = stepPads t i 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,
               move (half w, 380) 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 }
    txt' = toForm $ Text.text $ Text.defaultText {
      textUTF8 = "SPACE to start, WS and ↑↓ to move",
      textColor = cyan,
      textTypeface = "monospace",
      textHeight = 12 }

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