HipmunkPlayground 5.2.0 → 5.2.0.1

raw patch · 3 files changed

+63/−19 lines, 3 filesdep +transformers

Dependencies added: transformers

Files

• HipmunkPlayground.cabal +10/−7
• NEWS +10/−0
• Playground.hs +43/−12

@@ -3,7 +3,7 @@ Tested-With:   GHC Category:      Physics, Game Name:          HipmunkPlayground-Version:       5.2.0+Version:       5.2.0.1 Stability:     provisional License:       OtherLicense License-File:  LICENSE@@ -15,6 +15,10 @@       This is a simple OpenGL program that allows you to see       some of Hipmunk's functions in action.       .+      New in version 5.2.0.1:+      .+      * Show collision points.+      .       New in version 5.2.0:       .       * Updated to Hipmunk 5.2.0 (which uses StateVar).@@ -32,12 +36,11 @@  Executable HipmunkPlayground   if flag(small_base)-    Build-Depends: base >= 3 && < 5, containers >= 0.1 && < 0.4,-                   Hipmunk >= 5.2 && < 5.3, GLFW >= 0.4 && < 0.5,-                   OpenGL >= 2.4 && < 2.5, StateVar >= 1.0 && < 1.1+    Build-Depends: base >= 3 && < 5, containers >= 0.1 && < 0.4   else-    Build-Depends: base >= 2 && < 3,-                   Hipmunk >= 5.2 && < 5.3, GLFW >= 0.4 && < 0.5,-                   OpenGL >= 2.4 && < 2.5, StateVar >= 1.0 && < 1.1+    Build-Depends: base >= 2 && < 3+  Build-Depends: Hipmunk >= 5.2 && < 5.3, transformers >= 0.2 && < 0.3,+                 OpenGL >= 2.4 && < 2.5, StateVar >= 1.0 && < 1.1,+                 GLFW >= 0.4 && < 0.5   GHC-Options:   -Wall   Main-is: Playground.hs

@@ -1,3 +1,13 @@+Version 5.2.0.1+===============+ - Show collision points.++Version 5.2.0+=============+ - Updated to Hipmunk 5.2.0 (which uses StateVar).+ - Updated to OpenGL 2.4.0.1.+ - Updated to GLFW 0.4.2.+ Version 5.1.0 =============  - Updated to Hipmunk 5.1.0.

@@ -2,6 +2,7 @@  import qualified Data.Map as M import Control.Monad+import Control.Monad.IO.Class import Data.IORef import Data.List (unzip4) import Data.StateVar@@ -68,7 +69,8 @@       stCarState :: CarState,       stControls :: CarControls,       stShapes   :: M.Map H.Shape (IO () {- Drawing -}-                                  ,IO () {- Removal -})+                                  ,IO () {- Removal -}),+      stCollisionsVar :: IORef [H.Position]     } data CarState = Stopped | GoingLeft | GoingRight deriving (Eq, Ord, Enum) type Object = (H.Shape, (IO (), IO ()))@@ -78,15 +80,31 @@ initialState :: IO State initialState = do   -- The (empty) space-  space  <- H.newSpace+  space <- H.newSpace   H.gravity space $= 0 +: -230    -- Default objects   seesaw  <- buildSeesaw space   ground  <- buildGround space   (car,c) <- buildCar space-  return $ State space Stopped c $ M.fromList [seesaw, ground, car] +  -- Add a callback to Hipmunk to draw collisions+  collisionsVar <- newIORef []+  let handler = do ps <- H.points+                   liftIO $ modifyIORef collisionsVar (ps ++)+  H.setDefaultCollisionHandler space $+    H.Handler {H.beginHandler     = Nothing+              ,H.preSolveHandler  = Nothing+              ,H.postSolveHandler = Just handler+              ,H.separateHandler  = Nothing}++  -- Our state+  return $ State {stSpace    = space+                 ,stCarState = Stopped+                 ,stControls = c+                 ,stShapes   = M.fromList [seesaw, ground, car]+                 ,stCollisionsVar = collisionsVar}+ -- | Builds the ground buildGround :: H.Space -> IO Object buildGround space = do@@ -247,7 +265,7 @@   ortho (-320) 320 (-240) 240 (-1) 1   translate (Vector3 0.5 0.5 zero) -  -- Add some callbacks+  -- Add some callbacks to GLFW   windowCloseCallback $= exitWith ExitSuccess   mouseButtonCallback $= processMouseInput stateVar @@ -323,12 +341,13 @@  -- | Renders the current state. updateDisplay :: IORef State -> KeyButtonState -> IO ()-updateDisplay stateVar slowKey  = do+updateDisplay stateVar slowKey = do   state <- get stateVar   clear [ColorBuffer]   drawInstructions   when (slowKey == Press) drawSlowMotion   forM_ (M.assocs $ stShapes state) (fst . snd) -- Draw each one+  readIORef (stCollisionsVar state) >>= mapM_ (drawPoint CollisionPoint)   swapBuffers  drawInstructions :: IO ()@@ -375,13 +394,13 @@           y = radius * sin (r + angle) + py       vertex' x y     vertex' px py-  drawPoint (px +: py)+  drawPoint PositionPoint (px +: py) drawMyShape shape (H.LineSegment p1 p2 _) = do   let v (H.Vector x y) = vertex' x y   pos <- get $ H.position $ H.body shape   color $ Color3 zero zero zero   renderPrimitive Lines $ v (p1 + pos) >> v (p2 + pos)-  drawPoint pos+  drawPoint PositionPoint pos drawMyShape shape (H.Polygon verts) = do   pos   <- get $ H.position $ H.body shape   angle <- get $ H.angle    $ H.body shape@@ -391,20 +410,25 @@   renderPrimitive LineStrip $ do     forM_ (verts' ++ [head verts']) $ \(H.Vector x y) -> do       vertex' x y-  drawPoint pos+  drawPoint PositionPoint pos  -- | Draws a red point.-drawPoint :: H.Vector -> IO ()-drawPoint (H.Vector px py) = do-  color $ Color3 1 zero zero+drawPoint :: PointType -> H.Vector -> IO ()+drawPoint pt (H.Vector px py) = do+  color $ case pt of+            PositionPoint  -> Color3 zero zero 1+            CollisionPoint -> Color3 1 zero zero   renderPrimitive Points $ do     vertex' px py +data PointType = PositionPoint | CollisionPoint+                 deriving (Eq, Ord, Show, Enum)     + ------------------------------------------------------------ -- Input processing ------------------------------------------------------------@@ -557,7 +581,14 @@ advanceSimulTime stateVar steps = do   removeOutOfSight stateVar   state <- get stateVar-  replicateM_ steps $ H.step (stSpace state) frameDelta++  -- Do (steps-1) steps that clear the collisions variable.+  let clearCollisions = writeIORef (stCollisionsVar state) []+      step = H.step (stSpace state) frameDelta+  replicateM_ (steps-1) $ step >> clearCollisions++  -- Do a final step that will leave the collisions variable filled.+  step  -- | Removes all shapes that may be out of sight forever. removeOutOfSight :: IORef State -> IO ()