HipmunkPlayground (empty) → 0.1
raw patch · 4 files changed
+306/−0 lines, 4 filesdep +GLFWdep +Hipmunkdep +OpenGLsetup-changed
Dependencies added: GLFW, Hipmunk, OpenGL, base, containers
Files
- HipmunkPlayground.cabal +28/−0
- LICENSE +16/−0
- Playground.hs +259/−0
- Setup.lhs +3/−0
+ HipmunkPlayground.cabal view
@@ -0,0 +1,28 @@+Cabal-Version: >= 1.2+Build-Type: Simple+Tested-With: GHC+Category: Physics, Game+Name: HipmunkPlayground+Version: 0.1+Stability: beta+License: OtherLicense+License-File: LICENSE+Copyright: (c) 2008 Felipe A. Lessa+Author: Felipe A. Lessa <felipe.lessa@gmail.com>+Maintainer: Felipe A. Lessa <felipe.lessa@gmail.com>+Synopsis: A playground for testing Hipmunk.+Description:+ This is a simple OpenGL program that allows you to see+ some of Hipmunk's functions in action.+ .+ Licensed under the MIT license (like Hipmunk itself).++Flag small_base+ Description: Choose the new smaller, split-up base package.++Executable HipmunkPlayground+ Build-Depends: base, Hipmunk, OpenGL, GLFW+ if flag(small_base)+ Build-Depends: containers+ GHC-Options: -Wall+ Main-is: Playground.hs
+ LICENSE view
@@ -0,0 +1,16 @@+Copyright (c) 2008 Felipe A. Lessa+ * Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:+ * The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Playground.hs view
@@ -0,0 +1,259 @@+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
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!runhaskell+> import Distribution.Simple+> main = defaultMain