HipmunkPlayground 0.2 → 5.0.0
raw patch · 2 files changed
+142/−39 lines, 2 filesdep ~GLFWdep ~Hipmunkdep ~OpenGL
Dependency ranges changed: GLFW, Hipmunk, OpenGL, base, containers
Files
- HipmunkPlayground.cabal +15/−3
- Playground.hs +127/−36
HipmunkPlayground.cabal view
@@ -3,7 +3,7 @@ Tested-With: GHC Category: Physics, Game Name: HipmunkPlayground-Version: 0.2+Version: 5.0.0 Stability: provisional License: OtherLicense License-File: LICENSE@@ -15,6 +15,13 @@ This is a simple OpenGL program that allows you to see some of Hipmunk's functions in action. .+ New in version 5.0.0:+ .+ * Updated for Hipmunk 5.0.0. Yay!+ .+ * Add a small car using @SimpleMotor@ (not the best way+ of creating a car, but it works a demo).+ . Licensed under the MIT license (like Hipmunk itself). Extra-Source-Files: NEWS@@ -23,8 +30,13 @@ Description: Choose the new smaller, split-up base package. Executable HipmunkPlayground- Build-Depends: base, Hipmunk >= 0.2, OpenGL, GLFW if flag(small_base)- Build-Depends: containers+ Build-Depends: base >= 3 && < 5, containers >= 0.1 && < 0.3,+ Hipmunk >= 5.0 && < 5.1, OpenGL >= 2.1 && < 2.3,+ GLFW >= 0.3 && < 0.4+ else+ Build-Depends: base >= 2 && < 3,+ Hipmunk >= 5.0 && < 5.1, OpenGL >= 2.1 && < 2.3,+ GLFW >= 0.3 && < 0.4 GHC-Options: -Wall Main-is: Playground.hs
Playground.hs view
@@ -2,6 +2,7 @@ import Control.Monad import Data.IORef+import Data.List (unzip4) import qualified Data.Map as M import System.Exit @@ -9,9 +10,10 @@ import Graphics.Rendering.OpenGL import qualified Physics.Hipmunk as H +type Time = Double --------------------------------------------------------------- Some constants+-- Some constants and utils ------------------------------------------------------------ -- | Desired (and maximum) frames per second.@@ -19,7 +21,7 @@ desiredFPS = 60 -- | How much seconds a frame lasts.-framePeriod :: Double+framePeriod :: Time framePeriod = 1 / toEnum desiredFPS -- | How many steps should be done per frame.@@ -48,6 +50,10 @@ assertTrue :: IO Bool -> String -> IO () assertTrue act msg = do {b <- act; when (not b) (fail msg)} +-- | Constructs a Vector.+(+:) :: H.CpFloat -> H.CpFloat -> H.Vector+(+:) = H.Vector+infix 4 +: @@ -57,10 +63,15 @@ -- | Our current program state that will be passed around. data State = State {- stSpace :: H.Space,- stShapes :: M.Map H.Shape (IO () {- Drawing -}- ,IO () {- Removal -})+ stSpace :: H.Space,+ stCarState :: CarState,+ stControls :: CarControls,+ stShapes :: M.Map H.Shape (IO () {- Drawing -}+ ,IO () {- Removal -}) }+data CarState = Stopped | GoingLeft | GoingRight deriving (Eq, Ord, Enum)+type Object = (H.Shape, (IO (), IO ()))+type CarControls = (CarState -> IO ()) -- | Our initial state. initialState :: IO State@@ -68,38 +79,48 @@ -- The (empty) space space <- H.newSpace H.setElasticIterations space 10- H.setGravity space $ H.Vector 0 (-230)+ H.setGravity space (0 +: -230) - -- The ground+ -- Default objects+ seesaw <- buildSeesaw space+ ground <- buildGround space+ (car,c) <- buildCar space+ return $ State space Stopped c $ M.fromList [seesaw, ground, car]++-- | Builds the ground+buildGround :: H.Space -> IO Object+buildGround space = do static <- H.newBody H.infinity H.infinity- H.setPosition static (H.Vector (-330) 0)- let seg1type = H.LineSegment (H.Vector 50 (-230))- (H.Vector 610 (-230)) 1+ H.setPosition 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.spaceAdd space (H.Static seg1)+ return (seg1, (drawMyShape seg1 seg1type, return ())) - -- The seesaw+-- | Builds the seesaw.+buildSeesaw :: H.Space -> IO Object+buildSeesaw space = do ---- Support- let supportV = map (uncurry H.Vector) [(-15,-20),(-5,20),(5,20),(15,-20)]+ let supportV = [-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))+ H.setPosition supportB (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)]+ let boardV = [-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))+ H.setPosition boardB (0 +: 40-230) boardS <- H.newShape boardB boardT 0 let setBoardProps shape = do H.setFriction shape 2.0@@ -112,8 +133,8 @@ setBoardProps seg H.spaceAdd space seg return seg- ----- Joint- seesawJoint <- H.newJoint supportB boardB (H.Pin (H.Vector 0 20) 0)+ ----- Constraint+ seesawJoint <- H.newConstraint supportB boardB (H.Pin (0 +: 20) 0) H.spaceAdd space seesawJoint ----- Avoiding self-collisions forM_ (supportS : boardS : boardS2) $ \s -> do@@ -129,11 +150,65 @@ H.spaceRemove space boardS forM_ boardS2 (H.spaceRemove space) H.spaceRemove space seesawJoint-+ return (supportS, (drawSeeSaw, removeSeeSaw)) - return $ State space $ M.fromList- [(seg1, (drawMyShape seg1 seg1type, return ()))- ,(supportS, (drawSeeSaw, removeSeeSaw))]+-- | Build a small car.+buildCar :: H.Space -> IO (Object, CarControls)+buildCar space = do+ ---- Bodywork+ let bodyworkV = [-25 +: -9, -17 +: 10, 17 +: 10, 25 +: -9]+ bodyworkT = H.Polygon bodyworkV+ bodyworkP = (-150 +: -90)+ bodyworkM = 40+ bodyworkI = H.momentForPoly bodyworkM bodyworkV 0+ bodyworkB <- H.newBody bodyworkM bodyworkI+ H.setPosition bodyworkB bodyworkP+ bodyworkS <- H.newShape bodyworkB bodyworkT 0+ H.setFriction bodyworkS 1.5+ H.setElasticity bodyworkS 0.1+ H.spaceAdd space bodyworkB+ H.spaceAdd space bodyworkS+ ---- Wheels+ let wheelR = 12 -- radius+ wheelM = 200 -- mass+ wheelT = H.Circle wheelR+ wheelI = H.momentForCircle wheelM (0, wheelR) 0+ wheelJ1 x = H.DampedSpring (x +: 0) (0 +: 0) 23 0 10 -- spring+ wheelJ2 x = H.Groove (x +: -23.5, x +: -27) (0 +: 0) -- groove+ (wheelBs, wheelSs, wheelCs, wheelMs) <-+ fmap unzip4 $ forM [-25, 25] $ \x -> do+ -- Basic+ wheelB <- H.newBody wheelM wheelI+ H.setPosition wheelB $ (x +: -24) + bodyworkP+ wheelS <- H.newShape wheelB wheelT 0+ H.setFriction wheelS 2.0+ H.setElasticity wheelS 0.25+ -- Constraints+ wheelC1 <- H.newConstraint bodyworkB wheelB (wheelJ1 x)+ wheelC2 <- H.newConstraint bodyworkB wheelB (wheelJ2 x)+ H.spaceAdd space wheelB+ H.spaceAdd space wheelS+ H.spaceAdd space wheelC1+ H.spaceAdd space wheelC2+ -- Motor+ motor <- H.newConstraint bodyworkB wheelB (H.SimpleMotor 0)+ H.spaceAdd space motor+ let motorControls = map turn [0, -1, 1]+ turn = H.redefineC motor . H.SimpleMotor . (*4)+ -- Return+ let constrs = [H.forgetC wheelC1, H.forgetC wheelC2, H.forgetC motor]+ return (wheelB, wheelS, constrs, motorControls)+ ---- Removing and drawing+ let drawCar = do+ drawMyShape bodyworkS bodyworkT+ mapM_ (flip drawMyShape wheelT) wheelSs+ let removeCar = do+ mapM_ (H.spaceRemove space) (bodyworkB : wheelBs)+ mapM_ (H.spaceRemove space) (bodyworkS : wheelSs)+ mapM_ (H.spaceRemove space) (concat wheelCs)+ ---- Motor controls+ let control w = mapM_ (!!n) wheelMs where n = fromEnum w+ return ((bodyworkS, (drawCar, removeCar)), control) -- | Destroy a state. destroyState :: State -> IO ()@@ -170,23 +245,25 @@ matrixMode $= Projection loadIdentity ortho (-320) 320 (-240) 240 (-1) 1- translate (Vector3 0.5 0.5 0 :: Vector3 GLfloat)+ translate (Vector3 0.5 0.5 zero) -- Add some callbacks- windowCloseCallback $= exitWith ExitSuccess- mouseButtonCallback $= processMouseInput stateVar+ windowCloseCallback $= exitWith ExitSuccess+ mouseButtonCallback $= processMouseInput stateVar -- Let's go! now <- get time loop stateVar now -- | The simulation loop.-loop :: IORef State -> Double -> IO ()+loop :: IORef State -> Time -> IO () loop stateVar oldTime = do -- Some key states slowKey <- getKey (SpecialKey ENTER) quitKey <- getKey (SpecialKey ESC) clearKey <- getKey (SpecialKey DEL)+ leftKey <- getKey (SpecialKey LEFT)+ rightKey <- getKey (SpecialKey RIGHT) -- Quit? when (quitKey == Press) (terminate >> exitWith ExitSuccess)@@ -194,15 +271,29 @@ -- Clear? when (clearKey == Press) $ do destroyState =<< readIORef stateVar+ H.resetShapeCounter initialState >>= writeIORef stateVar -- Update display and time+ updateCar stateVar leftKey rightKey updateDisplay stateVar slowKey newTime <- advanceTime stateVar oldTime slowKey loop stateVar newTime +-- | Updates the car state+updateCar :: IORef State -> KeyButtonState -> KeyButtonState -> IO ()+updateCar stateVar leftKey rightKey = do+ let wantsToBe = case (leftKey, rightKey) of+ (Press, _) -> GoingLeft+ (_, Press) -> GoingRight+ _ -> Stopped+ state <- readIORef stateVar+ when (stCarState state /= wantsToBe) $ do+ stControls state wantsToBe+ writeIORef stateVar (state {stCarState = wantsToBe})+ -- | Advances the time.-advanceTime :: IORef State -> Double -> KeyButtonState -> IO Double+advanceTime :: IORef State -> Time -> KeyButtonState -> IO Time advanceTime stateVar oldTime slowKey = do newTime <- get time @@ -243,7 +334,7 @@ drawInstructions :: IO () drawInstructions = preservingMatrix $ do translate (Vector3 (-320) 240 zero)- scale 0.75 0.75 (zero + 1)+ scale 0.75 0.75 (1 `asTypeOf` zero) let render str = do translate (Vector3 zero (-16) zero) renderString Fixed8x16 str@@ -256,6 +347,7 @@ 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 LEFT or RIGHT to move the car." render "Hold ENTER to see in slow motion." color $ Color3 zero zero zero@@ -263,7 +355,7 @@ drawSlowMotion :: IO () drawSlowMotion = preservingMatrix $ do- scale 2 2 (zero + 1)+ scale 2 2 (1 `asTypeOf` zero) translate (Vector3 (-40) zero zero) color $ Color3 zero 1 zero renderString Fixed8x16 "Slowwww..."@@ -283,7 +375,7 @@ y = radius * sin (r + angle) + py vertex (Vertex2 x y) vertex (Vertex2 px py)- drawPoint (H.Vector 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@@ -327,7 +419,7 @@ 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)+ return (realToFrac mx +: realToFrac my) -- | Process a user mouse button press. processMouseInput :: IORef State -> MouseButton -> KeyButtonState -> IO ()@@ -392,8 +484,7 @@ createSquare :: Creator createSquare angVel = do let mass = 18- verts = map (uncurry H.Vector)- [(-15,-15), (-15,15), (15,15), (15,-15)]+ verts = [-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@@ -414,7 +505,7 @@ createTriPendulum :: Creator createTriPendulum angVel = do let mass = 100- verts = map (uncurry H.Vector) [(-30,-30), (0, 37), (30, -30)]+ verts = [-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@@ -423,10 +514,10 @@ H.setFriction s 0.8 H.setElasticity s 0.3 - let staticPos = H.Vector 0 240+ let staticPos = 0 +: 240 static <- H.newBody H.infinity H.infinity H.setPosition static staticPos- j <- H.newJoint static b (H.Pin 0 0)+ j <- H.newConstraint static b (H.Pin 0 0) let add space = do H.spaceAdd space b@@ -439,7 +530,7 @@ 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+ color $ Color3 (0.7 `asTypeOf` zero) 0.7 0.7 renderPrimitive LineStrip $ do vertex (Vertex2 x1 y1) vertex (Vertex2 x2 y2)