HipmunkPlayground 5.1.0 → 5.2.0
raw patch · 2 files changed
+63/−53 lines, 2 filesdep +StateVardep ~GLFWdep ~Hipmunkdep ~OpenGL
Dependencies added: StateVar
Dependency ranges changed: GLFW, Hipmunk, OpenGL
Files
- HipmunkPlayground.cabal +11/−7
- Playground.hs +52/−46
HipmunkPlayground.cabal view
@@ -3,7 +3,7 @@ Tested-With: GHC Category: Physics, Game Name: HipmunkPlayground-Version: 5.1.0+Version: 5.2.0 Stability: provisional License: OtherLicense License-File: LICENSE@@ -15,10 +15,14 @@ This is a simple OpenGL program that allows you to see some of Hipmunk's functions in action. .- New in version 5.1.0:+ New in version 5.2.0: .- * Updated to Hipmunk 5.1.0.+ * Updated to Hipmunk 5.2.0 (which uses StateVar). .+ * Updated to OpenGL 2.4.0.1.+ .+ * Updated to GLFW 0.4.2.+ . Licensed under the MIT license (like Hipmunk itself). Extra-Source-Files: NEWS@@ -29,11 +33,11 @@ Executable HipmunkPlayground if flag(small_base) Build-Depends: base >= 3 && < 5, containers >= 0.1 && < 0.4,- Hipmunk >= 5.1 && < 5.2, OpenGL >= 2.1 && < 2.3,- GLFW >= 0.3 && < 0.4+ Hipmunk >= 5.2 && < 5.3, GLFW >= 0.4 && < 0.5,+ OpenGL >= 2.4 && < 2.5, StateVar >= 1.0 && < 1.1 else Build-Depends: base >= 2 && < 3,- Hipmunk >= 5.1 && < 5.2, OpenGL >= 2.1 && < 2.3,- GLFW >= 0.3 && < 0.4+ Hipmunk >= 5.2 && < 5.3, GLFW >= 0.4 && < 0.5,+ OpenGL >= 2.4 && < 2.5, StateVar >= 1.0 && < 1.1 GHC-Options: -Wall Main-is: Playground.hs
Playground.hs view
@@ -1,9 +1,10 @@ module Main (main) where +import qualified Data.Map as M import Control.Monad import Data.IORef import Data.List (unzip4)-import qualified Data.Map as M+import Data.StateVar import System.Exit import Graphics.UI.GLFW@@ -78,7 +79,7 @@ initialState = do -- The (empty) space space <- H.newSpace- H.setGravity space (0 +: -230)+ H.gravity space $= 0 +: -230 -- Default objects seesaw <- buildSeesaw space@@ -90,11 +91,11 @@ buildGround :: H.Space -> IO Object buildGround space = do static <- H.newBody H.infinity H.infinity- H.setPosition static (-330 +: 0)+ H.position static $= -330 +: 0 let seg1type = H.LineSegment (50 +: -230) (610 +: -230) 1 seg1 <- H.newShape static seg1type 0- H.setFriction seg1 1.0- H.setElasticity seg1 0.6+ H.friction seg1 $= 1.0+ H.elasticity seg1 $= 0.6 H.spaceAdd space (H.Static seg1) return (seg1, (drawMyShape seg1 seg1type, return ())) @@ -107,10 +108,10 @@ supportM = 500 supportI = H.momentForPoly supportM supportV 0 supportB <- H.newBody supportM supportI- H.setPosition supportB (0 +: 20-230)+ H.position supportB $= 0 +: 20-230 supportS <- H.newShape supportB supportT 0- H.setFriction supportS 2.0- H.setElasticity supportS 0.1+ H.friction supportS $= 2.0+ H.elasticity supportS $= 0.1 H.spaceAdd space supportB H.spaceAdd space supportS ----- Board@@ -119,11 +120,11 @@ boardM = 10 boardI = H.momentForPoly boardM boardV 0 boardB <- H.newBody boardM boardI- H.setPosition boardB (0 +: 40-230)+ H.position boardB $= 0 +: 40-230 boardS <- H.newShape boardB boardT 0 let setBoardProps shape = do- H.setFriction shape 2.0- H.setElasticity shape 0.1+ H.friction shape $= 2.0+ H.elasticity shape $= 0.1 setBoardProps boardS H.spaceAdd space boardB H.spaceAdd space boardS@@ -137,7 +138,7 @@ H.spaceAdd space seesawJoint ----- Avoiding self-collisions forM_ (supportS : boardS : boardS2) $ \s -> do- H.setGroup s 1+ H.group s $= 1 ----- Removing and drawing let drawSeeSaw = do drawMyShape supportS supportT@@ -161,10 +162,10 @@ bodyworkM = 40 bodyworkI = H.momentForPoly bodyworkM bodyworkV 0 bodyworkB <- H.newBody bodyworkM bodyworkI- H.setPosition bodyworkB bodyworkP+ H.position bodyworkB $= bodyworkP bodyworkS <- H.newShape bodyworkB bodyworkT 0- H.setFriction bodyworkS 1.5- H.setElasticity bodyworkS 0.1+ H.friction bodyworkS $= 1.5+ H.elasticity bodyworkS $= 0.1 H.spaceAdd space bodyworkB H.spaceAdd space bodyworkS ---- Wheels@@ -178,10 +179,10 @@ fmap unzip4 $ forM [-25, 25] $ \x -> do -- Basic wheelB <- H.newBody wheelM wheelI- H.setPosition wheelB $ (x +: -24) + bodyworkP+ H.position wheelB $= (x +: -24) + bodyworkP wheelS <- H.newShape wheelB wheelT 0- H.setFriction wheelS 2.0- H.setElasticity wheelS 0.25+ H.friction wheelS $= 2.0+ H.elasticity wheelS $= 0.25 -- Constraints wheelC1 <- H.newConstraint bodyworkB wheelB (wheelJ1 x) wheelC2 <- H.newConstraint bodyworkB wheelB (wheelJ2 x)@@ -362,8 +363,8 @@ -- | 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+ H.Vector px py <- get $ H.position $ H.body shape+ angle <- get $ H.angle $ H.body shape color $ Color3 zero zero zero renderPrimitive LineStrip $ do@@ -372,24 +373,24 @@ 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)+ vertex' x y+ vertex' px py drawPoint (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+ 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 drawMyShape shape (H.Polygon verts) = do- pos <- H.getPosition $ H.getBody shape- angle <- H.getAngle $ H.getBody shape+ pos <- get $ H.position $ H.body shape+ angle <- get $ H.angle $ H.body 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)+ vertex' x y drawPoint pos -- | Draws a red point.@@ -397,7 +398,7 @@ drawPoint (H.Vector px py) = do color $ Color3 1 zero zero renderPrimitive Points $ do- vertex (Vertex2 px py)+ vertex' px py @@ -416,7 +417,7 @@ model <- get $ matrix (Just $ Modelview 0) proj <- get $ matrix (Just Projection) view <- get $ viewport- let src = Vertex3 (fromIntegral cx) (fromIntegral $ h - cy) 0+ let src = Vertex3 (fromIntegral cx) (fromIntegral h - fromIntegral cy) 0 Vertex3 mx my _ <- unProject src (model :: GLmatrix GLdouble) proj view return (realToFrac mx +: realToFrac my) @@ -466,10 +467,10 @@ 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+ (H.position b $=) =<< getMousePos+ H.angVel b $= angVel+ H.friction s $= 0.5+ H.elasticity s $= 0.9 let add space = do H.spaceAdd space b H.spaceAdd space s@@ -487,10 +488,10 @@ 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+ (H.position b $=) =<< getMousePos+ H.angVel b $= angVel+ H.friction s $= 0.5+ H.elasticity s $= 0.6 let add space = do H.spaceAdd space b H.spaceAdd space s@@ -508,14 +509,14 @@ 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+ (H.position b $=) =<< getMousePos+ H.angVel b $= angVel+ H.friction s $= 0.8+ H.elasticity s $= 0.3 let staticPos = 0 +: 240 static <- H.newBody H.infinity H.infinity- H.setPosition static staticPos+ H.position static $= staticPos j <- H.newConstraint static b (H.Pin 0 0) let add space = do@@ -527,20 +528,25 @@ H.spaceRemove space s H.spaceRemove space j let draw = do- H.Vector x1 y1 <- H.getPosition b+ H.Vector x1 y1 <- get $ H.position b let H.Vector x2 y2 = staticPos color $ Color3 (0.7 `asTypeOf` zero) 0.7 0.7 renderPrimitive LineStrip $ do- vertex (Vertex2 x1 y1)- vertex (Vertex2 x2 y2)+ let+ vertex' x1 y1+ vertex' x2 y2 drawMyShape s t return (s,add,draw,remove) +vertex' :: Double -> Double -> IO ()+vertex' x y = let f p = realToFrac p :: GLdouble+ in vertex (Vertex2 (f x) (f y)) + ------------------------------------------------------------ -- Simulation bookkeeping ------------------------------------------------------------@@ -561,7 +567,7 @@ stateVar $= state {stShapes = shapes'} where f shapes (shape, (_,remove)) = do- H.Vector x y <- H.getPosition $ H.getBody shape+ H.Vector x y <- get $ H.position $ H.body shape if y < (-350) || abs x > 800 then remove >> return (M.delete shape shapes) else return shapes