Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

234 lines (186 sloc) 6.192 kB
{-# 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, newStdGen)
-- 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) <$> newStdGen
return . interleave $ filter ((> 0.2) . abs) rs
where
interleave :: [a] -> [(a,a)]
interleave (x:y:xs) = (x,y) : interleave xs
interleave _ = []
Jump to Line
Something went wrong with that request. Please try again.