module Main (main) where
import Control.Monad
import Data.IORef
import qualified Data.Map as M
import System.Exit
import Graphics.UI.GLFW
import Graphics.Rendering.OpenGL
import qualified Physics.Hipmunk as H
-- | Our current program state that will be passed around.
data State = State {
stSpace :: H.Space,
stShapes :: M.Map H.Shape (H.ShapeType, IO () {- Removal -})
}
-- | Desired (and maximum) frames per second.
desiredFPS :: Int
desiredFPS = 60
-- | How much seconds a frame lasts.
framePeriod :: Double
framePeriod = 1 / toEnum desiredFPS
-- | How many steps should be done per frame.
frameSteps :: Int
frameSteps = 2
-- | Maximum number of steps per frame (e.g. if lots of frames get
-- dropped because the window was minimized)
maxSteps :: Int
maxSteps = 20
-- | How much time should pass in each step.
frameDelta :: H.Time
frameDelta = 1e-2
-- | Our initial state.
initialState :: IO State
initialState = do
space <- H.newSpace
H.setElasticIterations space 10
static <- H.newBody H.infinity H.infinity
let seg1type = H.LineSegment (H.Vector (-280) (-230))
(H.Vector ( 280) (-230)) 1
seg1 <- H.newShape static seg1type 0
H.setFriction seg1 1.0
H.setElasticity seg1 0.6
H.spaceAdd space (H.Static seg1)
H.setGravity space $ H.Vector 0 (-230)
return $ State space (M.singleton seg1 (seg1type, undefined))
-- | Asserts that an @IO@ action returns @True@, otherwise
-- fails with the given message.
assertTrue :: IO Bool -> String -> IO ()
assertTrue act msg = do {b <- act; when (not b) (fail msg)}
-- | Entry point.
main :: IO ()
main = do
-- Initialize Chipmunk, GLFW and our state
H.initChipmunk
assertTrue initialize "Failed to init GLFW"
stateVar <- initialState >>= newIORef
-- Create a window
assertTrue (openWindow (Size 800 600) [] Window) "Failed to open a window"
windowTitle $= "Hipmunk Playground"
-- Define some GL parameters for the whole program
clearColor $= Color4 1 1 1 1
lineSmooth $= Enabled
lineWidth $= 2.5
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
matrixMode $= Projection
loadIdentity
ortho (-320) 320 (-240) 240 (-1) 1
translate (Vector3 0.5 0.5 0 :: Vector3 GLfloat)
-- Add some callbacks
windowCloseCallback $= exitWith ExitSuccess
mouseButtonCallback $= processInput stateVar
-- Let's go!
now <- get time
loop stateVar now
-- | The simulation loop.
loop :: IORef State -> Double -> IO ()
loop stateVar oldTime = do
updateDisplay stateVar
newTime <- get time
-- Advance simulation
let framesPassed = (newTime - oldTime) / framePeriod
stepsToAdvance = round framesPassed
simulNewTime = oldTime + framePeriod * toEnum stepsToAdvance
advanceTime stateVar $ min maxSteps stepsToAdvance
-- Correlate with reality
newTime' <- get time
let diff = newTime' - simulNewTime
when (diff < framePeriod) $ sleep (framePeriod - diff)
loop stateVar simulNewTime
-- | Renders the current state.
updateDisplay :: IORef State -> IO ()
updateDisplay stateVar = do
state <- get stateVar
clear [ColorBuffer]
color $ Color3 0 0 (0 :: GLfloat)
forM_ (M.assocs $ stShapes state) $ \(s,(t,_)) -> drawMyShape s t
swapBuffers
-- | Draws a shape (assuming zero offset)
drawMyShape :: H.Shape -> H.ShapeType -> IO ()
drawMyShape shape (H.Circle radius) = do
H.Vector px py <- H.getPosition $ H.getBody shape
angle <- H.getAngle $ H.getBody shape
renderPrimitive LineStrip $ do
let segs = 20; coef = 2*pi/toEnum segs
forM_ [0..segs] $ \i -> do
let r = toEnum i * coef
x = radius * cos (r + angle) + px
y = radius * sin (r + angle) + py
vertex (Vertex2 x y)
vertex (Vertex2 px py)
drawMyShape shape (H.LineSegment p1 p2 _) = do
let v (H.Vector x y) = vertex (Vertex2 x y)
pos <- H.getPosition $ H.getBody shape
renderPrimitive Lines $ v (p1 + pos) >> v (p2 + pos)
drawMyShape shape (H.Polygon verts) = do
pos <- H.getPosition $ H.getBody shape
angle <- H.getAngle $ H.getBody shape
let rot = H.rotate $ H.fromAngle angle
verts' = map ((+pos) . rot) verts
renderPrimitive LineStrip $ do
forM_ (verts' ++ [head verts']) $ \(H.Vector x y) -> do
vertex (Vertex2 x y)
-- | Process a user mouse button press.
processInput :: IORef State -> MouseButton -> KeyButtonState -> IO ()
processInput _ _ Press = return ()
processInput stateVar btn Release = do
state <- get stateVar
pos <- getMousePos
case btn of
ButtonLeft -> do
let mass = 20
radius = 20
t = H.Circle radius
b <- H.newBody mass $ H.momentForCircle mass (0, radius) 0
s <- H.newShape b t 0
H.setAngVel b 50
H.setPosition b pos
H.setFriction s 0.5
H.setElasticity s 0.9
H.spaceAdd (stSpace state) b
H.spaceAdd (stSpace state) s
let removal = do H.spaceRemove (stSpace state) b
H.spaceRemove (stSpace state) s
stateVar $= state {
stShapes = M.insert s (t, removal) $ stShapes state}
ButtonRight -> do
let mass = 18
verts = map (uncurry H.Vector)
[(-15,-15), (-15,15), (15,15), (15,-15)]
t = H.Polygon verts
b <- H.newBody mass $ H.momentForPoly mass verts 0
s <- H.newShape b t 0
H.setPosition b pos
H.setFriction s 0.5
H.setElasticity s 0.6
H.spaceAdd (stSpace state) b
H.spaceAdd (stSpace state) s
let removal = do H.spaceRemove (stSpace state) b
H.spaceRemove (stSpace state) s
stateVar $= state {
stShapes = M.insert s (t, removal) $ stShapes state}
ButtonMiddle -> do
let mass = 100
verts = map (uncurry H.Vector) [(-30,-30), (0, 37), (30, -30)]
t = H.Polygon verts
b <- H.newBody mass $ H.momentForPoly mass verts 0
s <- H.newShape b t 0
H.setPosition b pos
H.setFriction s 0.8
H.setElasticity s 0.3
static <- H.newBody H.infinity H.infinity
H.setPosition static $ H.Vector 0 240
j <- H.newJoint static b (H.Pin 0 0)
H.spaceAdd (stSpace state) b
H.spaceAdd (stSpace state) s
H.spaceAdd (stSpace state) j
let removal = do H.spaceRemove (stSpace state) b
H.spaceRemove (stSpace state) s
H.spaceRemove (stSpace state) j
stateVar $= state {
stShapes = M.insert s (t, removal) $ stShapes state}
_ -> return ()
-- | Returns the current mouse position in our space's coordinates.
getMousePos :: IO H.Position
getMousePos = do
Position cx cy <- get mousePos
Size _ h <- get $ windowSize
model <- get $ matrix (Just $ Modelview 0)
proj <- get $ matrix (Just Projection)
view <- get $ viewport
let src = Vertex3 (fromIntegral cx) (fromIntegral $ h - cy) 0
Vertex3 mx my _ <- unProject src (model :: GLmatrix GLdouble) proj view
return $ H.Vector (realToFrac mx) (realToFrac my)
-- | Advances the time in a certain number of frames.
advanceTime :: IORef State -> Int -> IO ()
advanceTime _ 0 = return ()
advanceTime stateVar frames = do
removeOutOfSight stateVar
state <- get stateVar
replicateM_ (frames * frameSteps) $
H.step (stSpace state) frameDelta
-- | Removes all shapes that may be out of sight forever.
removeOutOfSight :: IORef State -> IO ()
removeOutOfSight stateVar = do
state <- get stateVar
shapes' <- foldM f (stShapes state) $ M.assocs (stShapes state)
stateVar $= state {stShapes = shapes'}
where
f shapes (shape, (_,remove)) = do
H.Vector _ y <- H.getPosition $ H.getBody shape
if y < (-300)
then remove >> return (M.delete shape shapes)
else return shapes