HipmunkPlayground 0.1 → 0.2
raw patch · 4 files changed
+349/−114 lines, 4 filesdep ~Hipmunksetup-changed
Dependency ranges changed: Hipmunk
Files
- HipmunkPlayground.cabal +5/−3
- NEWS +15/−0
- Playground.hs +328/−110
- Setup.lhs +1/−1
HipmunkPlayground.cabal view
@@ -3,8 +3,8 @@ Tested-With: GHC Category: Physics, Game Name: HipmunkPlayground-Version: 0.1-Stability: beta+Version: 0.2+Stability: provisional License: OtherLicense License-File: LICENSE Copyright: (c) 2008 Felipe A. Lessa@@ -16,12 +16,14 @@ some of Hipmunk's functions in action. . Licensed under the MIT license (like Hipmunk itself).+Extra-Source-Files:+ NEWS Flag small_base Description: Choose the new smaller, split-up base package. Executable HipmunkPlayground- Build-Depends: base, Hipmunk, OpenGL, GLFW+ Build-Depends: base, Hipmunk >= 0.2, OpenGL, GLFW if flag(small_base) Build-Depends: containers GHC-Options: -Wall
+ NEWS view
@@ -0,0 +1,15 @@+Version 0.2+===========+ - Add a seesaw to the middle of the screen.+ - Show the line of the pendulum.+ - Show instructions on the screen.+ - Add slow motion key.+ - Add clear screen key.+ - Add rotation control keys.+ - Use higher frequency for the Chipmunk engine (360Hz instead of 120Hz).+ - Draw a small red dot on the body's center.+++Version 0.1+===========+ - Initial public release.
Playground.hs view
@@ -9,12 +9,11 @@ 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 -})- } +------------------------------------------------------------+-- Some constants+------------------------------------------------------------+ -- | Desired (and maximum) frames per second. desiredFPS :: Int desiredFPS = 60@@ -24,8 +23,8 @@ framePeriod = 1 / toEnum desiredFPS -- | How many steps should be done per frame.-frameSteps :: Int-frameSteps = 2+frameSteps :: Double+frameSteps = 6 -- | Maximum number of steps per frame (e.g. if lots of frames get -- dropped because the window was minimized)@@ -34,31 +33,120 @@ -- | How much time should pass in each step. frameDelta :: H.Time-frameDelta = 1e-2+frameDelta = 3.33e-3 +-- | How much slower should the slow mode be.+slowdown :: Double+slowdown = 10 +-- | 0 :: GLfloat+zero :: GLfloat+zero = 0++-- | 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)}+++++------------------------------------------------------------+-- State+------------------------------------------------------------++-- | Our current program state that will be passed around.+data State = State {+ stSpace :: H.Space,+ stShapes :: M.Map H.Shape (IO () {- Drawing -}+ ,IO () {- Removal -})+ }+ -- | Our initial state. initialState :: IO State initialState = do+ -- The (empty) space space <- H.newSpace H.setElasticIterations space 10+ H.setGravity space $ H.Vector 0 (-230) + -- The ground static <- H.newBody H.infinity H.infinity- let seg1type = H.LineSegment (H.Vector (-280) (-230))- (H.Vector ( 280) (-230)) 1+ H.setPosition static (H.Vector (-330) 0)+ let seg1type = H.LineSegment (H.Vector 50 (-230))+ (H.Vector 610 (-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))+ -- The seesaw+ ---- Support+ let supportV = map (uncurry H.Vector) [(-15,-20),(-5,20),(5,20),(15,-20)]+ supportT = H.Polygon supportV+ supportM = 500+ supportI = H.momentForPoly supportM supportV 0+ supportB <- H.newBody supportM supportI+ H.setPosition supportB (H.Vector 0 (20-230))+ supportS <- H.newShape supportB supportT 0+ H.setFriction supportS 2.0+ H.setElasticity supportS 0.1+ H.spaceAdd space supportB+ H.spaceAdd space supportS+ ----- Board+ let boardV = map (uncurry H.Vector) [(-100,1),(100,1),(100,-1),(-100,-1)]+ boardT = H.Polygon boardV+ boardM = 10+ boardI = H.momentForPoly boardM boardV 0+ boardB <- H.newBody boardM boardI+ H.setPosition boardB (H.Vector 0 (40-230))+ boardS <- H.newShape boardB boardT 0+ let setBoardProps shape = do+ H.setFriction shape 2.0+ H.setElasticity shape 0.1+ setBoardProps boardS+ H.spaceAdd space boardB+ H.spaceAdd space boardS+ boardS2 <- forM (zip boardV $ tail $ cycle boardV) $ \(v1,v2) -> do+ seg <- H.newShape boardB (H.LineSegment v1 v2 0.1) 0+ setBoardProps seg+ H.spaceAdd space seg+ return seg+ ----- Joint+ seesawJoint <- H.newJoint supportB boardB (H.Pin (H.Vector 0 20) 0)+ H.spaceAdd space seesawJoint+ ----- Avoiding self-collisions+ forM_ (supportS : boardS : boardS2) $ \s -> do+ H.setGroup s 1+ ----- Removing and drawing+ let drawSeeSaw = do+ drawMyShape supportS supportT+ drawMyShape boardS boardT+ let removeSeeSaw = do+ H.spaceRemove space supportB+ H.spaceRemove space supportS+ H.spaceRemove space boardB+ H.spaceRemove space boardS+ forM_ boardS2 (H.spaceRemove space)+ H.spaceRemove space seesawJoint --- | 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)} + return $ State space $ M.fromList+ [(seg1, (drawMyShape seg1 seg1type, return ()))+ ,(supportS, (drawSeeSaw, removeSeeSaw))]++-- | Destroy a state.+destroyState :: State -> IO ()+destroyState (State {stSpace = space}) = do+ H.freeSpace space+++++------------------------------------------------------------+-- Main function and main loop+------------------------------------------------------------+ -- | Entry point. main :: IO () main = do@@ -72,19 +160,21 @@ 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+ clearColor $= Color4 1 1 1 1+ pointSmooth $= Enabled+ pointSize $= 3+ 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+ mouseButtonCallback $= processMouseInput stateVar -- Let's go! now <- get time@@ -93,36 +183,98 @@ -- | The simulation loop. loop :: IORef State -> Double -> IO () loop stateVar oldTime = do- updateDisplay stateVar+ -- Some key states+ slowKey <- getKey (SpecialKey ENTER)+ quitKey <- getKey (SpecialKey ESC)+ clearKey <- getKey (SpecialKey DEL)++ -- Quit?+ when (quitKey == Press) (terminate >> exitWith ExitSuccess)++ -- Clear?+ when (clearKey == Press) $ do+ destroyState =<< readIORef stateVar+ initialState >>= writeIORef stateVar++ -- Update display and time+ updateDisplay stateVar slowKey+ newTime <- advanceTime stateVar oldTime slowKey+ loop stateVar newTime++-- | Advances the time.+advanceTime :: IORef State -> Double -> KeyButtonState -> IO Double+advanceTime stateVar oldTime slowKey = do newTime <- get time -- Advance simulation- let framesPassed = (newTime - oldTime) / framePeriod- stepsToAdvance = round framesPassed- simulNewTime = oldTime + framePeriod * toEnum stepsToAdvance- advanceTime stateVar $ min maxSteps stepsToAdvance+ let slower = if slowKey == Press then slowdown else 1+ mult = frameSteps / (framePeriod * slower)+ framesPassed = truncate $ mult * (newTime - oldTime)+ simulNewTime = oldTime + toEnum framesPassed / mult+ advanceSimulTime stateVar $ min maxSteps framesPassed -- Correlate with reality newTime' <- get time let diff = newTime' - simulNewTime- when (diff < framePeriod) $ sleep (framePeriod - diff)- loop stateVar simulNewTime+ sleepTime = ((framePeriod * slower) - diff) / slower+ when (sleepTime > 0) $ sleep sleepTime+ return simulNewTime +++++------------------------------------------------------------+-- Display related functions+------------------------------------------------------------++ -- | Renders the current state.-updateDisplay :: IORef State -> IO ()-updateDisplay stateVar = do+updateDisplay :: IORef State -> KeyButtonState -> IO ()+updateDisplay stateVar slowKey = do state <- get stateVar clear [ColorBuffer]- color $ Color3 0 0 (0 :: GLfloat)- forM_ (M.assocs $ stShapes state) $ \(s,(t,_)) -> drawMyShape s t+ drawInstructions+ when (slowKey == Press) drawSlowMotion+ forM_ (M.assocs $ stShapes state) (fst . snd) -- Draw each one swapBuffers +drawInstructions :: IO ()+drawInstructions = preservingMatrix $ do+ translate (Vector3 (-320) 240 zero)+ scale 0.75 0.75 (zero + 1)+ let render str = do+ translate (Vector3 zero (-16) zero)+ renderString Fixed8x16 str++ color $ Color3 zero zero 1+ render "Press the left mouse button to create a ball."+ render "Press the right mouse button to create a square."+ render "Press the middle mouse button to create a triangle on a pendulum."++ color $ Color3 1 zero zero+ render "Hold LEFT SHIFT to create counterclockwise rotating objects."+ render "Hold RIGHT SHIFT to create clockwise rotating objects."+ render "Hold ENTER to see in slow motion."++ color $ Color3 zero zero zero+ render "Press DEL to clear the screen."++drawSlowMotion :: IO ()+drawSlowMotion = preservingMatrix $ do+ scale 2 2 (zero + 1)+ translate (Vector3 (-40) zero zero)+ color $ Color3 zero 1 zero+ renderString Fixed8x16 "Slowwww..."+ -- | 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++ color $ Color3 zero zero zero renderPrimitive LineStrip $ do let segs = 20; coef = 2*pi/toEnum segs forM_ [0..segs] $ \i -> do@@ -131,93 +283,39 @@ y = radius * sin (r + angle) + py vertex (Vertex2 x y) vertex (Vertex2 px py)+ drawPoint (H.Vector 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+ color $ Color3 zero zero zero renderPrimitive Lines $ v (p1 + pos) >> v (p2 + pos)+ drawPoint 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+ color $ Color3 zero zero zero renderPrimitive LineStrip $ do forM_ (verts' ++ [head verts']) $ \(H.Vector x y) -> do vertex (Vertex2 x y)+ drawPoint pos +-- | Draws a red point.+drawPoint :: H.Vector -> IO ()+drawPoint (H.Vector px py) = do+ color $ Color3 1 zero zero+ renderPrimitive Points $ do+ vertex (Vertex2 px py) --- | 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 ()-+------------------------------------------------------------+-- Input processing+------------------------------------------------------------ -- | Returns the current mouse position in our space's coordinates. getMousePos :: IO H.Position@@ -231,19 +329,139 @@ Vertex3 mx my _ <- unProject src (model :: GLmatrix GLdouble) proj view return $ H.Vector (realToFrac mx) (realToFrac my) +-- | Process a user mouse button press.+processMouseInput :: IORef State -> MouseButton -> KeyButtonState -> IO ()+processMouseInput _ _ Press = return ()+processMouseInput stateVar btn Release = do+ rotateKeyCCW <- getKey (SpecialKey LSHIFT)+ rotateKeyCW <- getKey (SpecialKey RSHIFT)+ let angVel = case (rotateKeyCCW, rotateKeyCW) of+ (Press, Release) -> 50+ (Release, Press) -> (-50)+ _ -> 0+ (shape,add,draw,remove) <- (case btn of+ ButtonLeft -> createCircle+ ButtonRight -> createSquare+ _ -> createTriPendulum) angVel + state <- get stateVar+ let space = stSpace state+ add space >> stateVar $= state {+ stShapes = M.insert shape (draw, remove space) $ stShapes state} --- | Advances the time in a certain number of frames.-advanceTime :: IORef State -> Int -> IO ()-advanceTime _ 0 = return ()-advanceTime stateVar frames = do++------------------------------------------------------------+-- Object creation+------------------------------------------------------------+++-- | The return of functions that create objects.+type Creation = (H.Shape, -- ^ A representative shape+ H.Space -> IO (), -- ^ Function that add the entities+ IO (), -- ^ Function that draws the entity+ H.Space -> IO () -- ^ Function that removes the entities+ )++-- | The type of the functions that create objects.+type Creator = H.CpFloat -> IO Creation++createCircle :: Creator+createCircle angVel = 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 angVel+ H.setPosition b =<< getMousePos+ H.setFriction s 0.5+ H.setElasticity s 0.9+ let add space = do+ H.spaceAdd space b+ H.spaceAdd space s+ let draw = do+ drawMyShape s t+ let remove space = do+ H.spaceRemove space b+ H.spaceRemove space s+ return (s,add,draw,remove)++createSquare :: Creator+createSquare angVel = 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.setAngVel b angVel+ H.setPosition b =<< getMousePos+ H.setFriction s 0.5+ H.setElasticity s 0.6+ let add space = do+ H.spaceAdd space b+ H.spaceAdd space s+ let draw = do+ drawMyShape s t+ let remove space = do+ H.spaceRemove space b+ H.spaceRemove space s+ return (s,add,draw,remove)++createTriPendulum :: Creator+createTriPendulum angVel = 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.setAngVel b angVel+ H.setPosition b =<< getMousePos+ H.setFriction s 0.8+ H.setElasticity s 0.3++ let staticPos = H.Vector 0 240+ static <- H.newBody H.infinity H.infinity+ H.setPosition static staticPos+ j <- H.newJoint static b (H.Pin 0 0)++ let add space = do+ H.spaceAdd space b+ H.spaceAdd space s+ H.spaceAdd space j+ let remove space = do+ H.spaceRemove space b+ H.spaceRemove space s+ H.spaceRemove space j+ let draw = do+ H.Vector x1 y1 <- H.getPosition b+ let H.Vector x2 y2 = staticPos+ color $ Color3 (zero+0.7) 0.7 0.7+ renderPrimitive LineStrip $ do+ vertex (Vertex2 x1 y1)+ vertex (Vertex2 x2 y2)+ drawMyShape s t+ return (s,add,draw,remove)+++++++------------------------------------------------------------+-- Simulation bookkeeping+------------------------------------------------------------++-- | Advances the time in a certain number of steps.+advanceSimulTime :: IORef State -> Int -> IO ()+advanceSimulTime _ 0 = return ()+advanceSimulTime stateVar steps = do removeOutOfSight stateVar state <- get stateVar- replicateM_ (frames * frameSteps) $- H.step (stSpace state) frameDelta+ replicateM_ steps $ H.step (stSpace state) frameDelta -- | Removes all shapes that may be out of sight forever. removeOutOfSight :: IORef State -> IO ()@@ -253,7 +471,7 @@ stateVar $= state {stShapes = shapes'} where f shapes (shape, (_,remove)) = do- H.Vector _ y <- H.getPosition $ H.getBody shape- if y < (-300)+ H.Vector x y <- H.getPosition $ H.getBody shape+ if y < (-350) || abs x > 800 then remove >> return (M.delete shape shapes) else return shapes
Setup.lhs view
@@ -1,3 +1,3 @@-#!runhaskell+#!/usr/bin/runhaskell > import Distribution.Simple > main = defaultMain