lens-2.5: examples/Pong.hs

{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Main
-- Copyright   :  (C) 2012 Edward Kmett, nand`
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  TH, Rank2, NoMonomorphismRestriction
--
-- A simple game of pong using gloss.
-----------------------------------------------------------------------------
module Main where

import Control.Applicative ((<$>), (<*>))
import Control.Lens
import Control.Monad.State (State, execState, get)
import Control.Monad (when)

import Data.Set (Set, member, empty, insert, delete)

import Graphics.Gloss
import Graphics.Gloss.Interface.Pure.Game

import System.Random (randomRs, getStdGen)

-- Some global constants

gameSize        = 300
windowWidth     = 800
windowHeight    = 600
ballRadius      = 0.02
speedIncrease   = 1.2
losingAccuracy  = 0.9
winningAccuracy = 0.1
initialSpeed    = 0.6
paddleWidth     = 0.02
paddleHeight    = 0.3
paddleSpeed     = 1
textSize        = 0.001

-- Pure data type for representing the game state

data Pong = Pong
  { _ballPos   :: Point
  , _ballSpeed :: Vector
  , _paddle1   :: Float
  , _paddle2   :: Float
  , _score     :: (Int, Int)
  , _vectors   :: [Vector]

  -- Since gloss doesn't cover this, we store the set of pressed keys
  , _keys      :: Set Key
  }

-- Some nice lenses to go with it
makeLenses ''Pong

-- Renamed tuple lenses for enhanced clarity with points/vectors
_x = _1
_y = _2

initial :: Pong
initial = Pong (0, 0) (0, 0) 0 0 (0, 0) [] empty

-- Calculate the y position at which the ball will next hit (on player2's side)
hitPos :: Point -> Vector -> Float
hitPos (x,y) (u,v) = ypos
  where
    xdist = if u >= 0 then 1 - x else 3 + x
    time  = xdist / abs u
    ydist = v * time
    ypos  = bounce (y + ydist)
    o     = 1 - ballRadius

    -- Calculate bounces iteratively
    bounce n
      | n >  o    = bounce (  2 *o - n)
      | n < -o    = bounce ((-2)*o - n)
      | otherwise = n

-- Difficulty function
accuracy :: Pong -> Float
accuracy p = g . f . fromIntegral $ p^.score._1 - p^.score._2
  where
    -- Scaling function
    f x = 0.04 * x + 0.5
    -- Clamping function
    g = min losingAccuracy . max winningAccuracy

-- Game update logic

update :: Float -> Pong -> Pong
update time = execState $ do
  updatePaddles time
  updateBall time
  checkBounds

-- Move the ball by adding its current speed
updateBall :: Float -> State Pong ()
updateBall time = do
  (u, v) <- use ballSpeed
  ballPos += (time * u, time * v)

  -- Make sure it doesn't leave the playing area
  ballPos.both %= clamp ballRadius

-- Update the paddles
updatePaddles :: Float -> State Pong ()
updatePaddles time = do
  p <- get

  let paddleMovement = time * paddleSpeed
      keyPressed key = p^.keys.contains (SpecialKey key)

  -- Update the player's paddle based on keys
  when (keyPressed KeyUp)   $ paddle1 += paddleMovement
  when (keyPressed KeyDown) $ paddle1 -= paddleMovement

  -- Calculate the optimal position
  let optimal = hitPos (p^.ballPos) (p^.ballSpeed)
      acc     = accuracy p
      target  = optimal * acc + (p^.ballPos._y) * (1 - acc)
      dist    = target - p^.paddle2

  -- Move the CPU's paddle towards this optimal position as needed
  when (abs dist > paddleHeight/3) $
    case compare dist 0 of
      GT -> paddle2 += paddleMovement
      LT -> paddle2 -= paddleMovement
      _  -> return ()

  -- Make sure both paddles don't leave the playing area
  paddle1 %= clamp (paddleHeight/2)
  paddle2 %= clamp (paddleHeight/2)

-- Clamp to the region (-1, 1) but with padding
clamp :: Float -> Float -> Float
clamp pad = max (pad - 1) . min (1 - pad)

-- Check for collisions and/or scores
checkBounds :: State Pong ()
checkBounds = do
  p <- get
  let (x,y) = p^.ballPos

  -- Check for collisions with the top or bottom
  when (abs y >= edge) $
    ballSpeed._y %= negate

  -- Check for collisions with paddles
  let check paddle other
        | y >= p^.paddle - paddleHeight/2 && y <= p^.paddle + paddleHeight/2 = do
            ballSpeed._x   %= negate
            ballSpeed._y   += 3*(y - p^.paddle) -- add english
            ballSpeed.both *= speedIncrease
        | otherwise = do
          score.other += 1
          reset

  when (x >=  edge) $ check paddle2 _1
  when (x <= -edge) $ check paddle1 _2

  where
    edge = 1 - ballRadius

-- Reset the game
reset :: State Pong ()
reset = do
  ballPos .= (0, 0)
  ballSpeed <~ nextSpeed

-- Retrieve a speed from the list, dropping it in the process
nextSpeed :: State Pong Vector
nextSpeed = do
  v:vs <- use vectors
  vectors .= vs
  return v

-- Drawing a pong state to the screen

draw :: Pong -> Picture
draw p = scale gameSize gameSize $ Pictures
  [ drawBall   `at` p^.ballPos
  , drawPaddle `at` (-paddleX, p^.paddle1)
  , drawPaddle `at` ( paddleX, p^.paddle2)

  -- Score and playing field
  , drawScore (p^.score) `at` (-0.1, 0.85)
  , rectangleWire 2 2
  ]
  where
    paddleX = 1 + paddleWidth/2
    p `at` (x,y) = translate x y p; infixr 1 `at`

drawPaddle :: Picture
drawPaddle = rectangleSolid paddleWidth paddleHeight

drawBall :: Picture
drawBall = circleSolid ballRadius

drawScore :: (Int, Int) -> Picture
drawScore (x, y) = scale textSize textSize . text $ show x ++ " " ++ show y

-- Handle input by simply updating the keys set

handle :: Event -> Pong -> Pong
handle (EventKey k s _ _) = keys.contains k .~ (s == Down)
handle _ = id

-- The main program action

main = do
  v:vs <- startingSpeeds
  let world = ballSpeed .~ v $ vectors .~ vs $ initial
  play display backColor fps world draw handle update

  where
    display   = InWindow "Pong!" (windowWidth, windowHeight) (200, 200)
    backColor = white
    fps       = 120

-- Generate the random list of starting speeds

startingSpeeds :: IO [Vector]
startingSpeeds = do
  rs <- randomRs (-initialSpeed, initialSpeed) <$> getStdGen
  return . interleave $ filter ((> 0.2) . abs) rs

  where
    interleave :: [a] -> [(a,a)]
    interleave (x:y:xs) = (x,y) : interleave xs
    interleave _        = []