Add quick example

CthulhuDen · Dec 6, 2020 · 8ce6697 · 8ce6697
1 parent e1ab9b6
commit 8ce6697
Show file tree

Hide file tree

Showing 6 changed files with 240 additions and 5 deletions.
diff --git a/README.md b/README.md
@@ -1,3 +1,6 @@
 # chiphunk
 
 Chiphunk is a Haskell bindings for Chipmunk2D physics library. See `Chiphunk.Low` module for documentation.
+
+See app/Main.hs for quick example of usage. Rendering is done by NanoVG, you will need pkg-config
+to have GLU and GLEW files (e.g. `aptitude install libglu-dev libglew-dev` on Ubuntu),
diff --git a/app/Main.hs b/app/Main.hs
@@ -0,0 +1,168 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Chiphunk.Low
+import Data.Functor
+import Text.Printf (printf)
+import Control.Monad
+import Control.Concurrent.MVar
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async
+
+import qualified Graphics.NanoVG.Simple as N
+import qualified Graphics.NanoVG.Picture as N
+import qualified NanoVG                 as NVG
+import           Data.IORef
+
+main :: IO ()
+main = do
+  dm <- newEmptyMVar
+  race_
+    (simulate dm)
+    (display dm)
+
+simulate :: MVar [VisObj] -> IO ()
+simulate dm = do
+  let gravity = Vect 0 (-100)
+  -- Create an empty space.
+  space <- spaceNew
+  spaceGravity space $= gravity
+
+  static <- get $ spaceStaticBody space
+
+  -- Add a static line segment shape for the ground.
+  -- We'll make it slightly tilted so the ball will roll off.
+  -- We attach it to a static body to tell Chipmunk it shouldn't be movable.
+  let (segA, segB) = (Vect (-20) (-5), Vect 20 (-25))
+  ground <- segmentShapeNew static segA segB 0
+  shapeElasticity ground $= 0.6
+  shapeFriction ground $= 1
+
+  spaceAddShape space ground
+
+  -- Now let's make a ball that falls onto the line and rolls off.
+  -- First we need to make a cpBody to hold the physical properties of the object.
+  -- These include the mass, position, velocity, angle, etc. of the object.
+  -- Then we attach collision shapes to the cpBody to give it a size and shape.
+
+  let radius = 5
+  let mass = 1
+  let mass100 = 100
+
+  -- The moment of inertia is like mass for rotation
+  -- Use the cpMomentFor*() functions to help you approximate it.
+  let moment = momentForCircle mass 0 radius (Vect 0 0)
+  let moment100 = momentForCircle mass100 0 radius (Vect 0 0)
+
+  -- The cpSpaceAdd*() functions return the thing that you are adding.
+  -- It's convenient to create and add an object in one line.
+  ballBody <- bodyNew mass moment
+  spaceAddBody space ballBody
+
+  -- Now we create the collision shape for the ball.
+  -- You can create multiple collision shapes that point to the same body.
+  -- They will all be attached to the body and move around to follow it.
+  ballShape <- circleShapeNew ballBody radius (Vect 0 0)
+  shapeFriction ballShape $= 0.9
+  shapeElasticity ballShape $= 1
+  spaceAddShape space ballShape
+
+  anotherBall <- bodyNew mass100 moment100
+  spaceAddBody space anotherBall
+
+  anotherBallShape <- circleShapeNew anotherBall radius (Vect 0 0)
+  shapeFriction anotherBallShape $= 0.9
+  shapeElasticity anotherBallShape $= 0.4
+  spaceAddShape space anotherBallShape
+
+  putMVar dm
+    [ mkStaticObj $ Segment segA segB
+    , mkBallBody ballBody radius
+    , mkBallBody anotherBall radius
+    ]
+
+  void $ forever $ do
+    bodyPosition ballBody $= Vect (-15) 30
+    bodyPosition anotherBall $= Vect (-5) 75
+    -- need to reset ball velocity after previous iteration
+    bodyVelocity ballBody $= Vect 0 0
+    bodyAngularVelocity ballBody $= 0
+    bodyVelocity anotherBall $= Vect 0 0
+    bodyAngularVelocity anotherBall $= 0
+
+    -- Now that it's all set up, we simulate all the objects in the space by
+    -- stepping forward through time in small increments called steps.
+    -- It is *highly* recommended to use a fixed size time step.
+    let timeStep = 1/120
+    runFor 3 timeStep $ \time -> do
+      pos <- get $ bodyPosition ballBody
+      vel <- get $ bodyVelocity ballBody
+      printf "Time is %4.2f. ballBody is at (%6.2f, %6.2f), it's velocity is (%6.2f, %6.2f).\n"
+             time (vX pos) (vY pos) (vX vel) (vY vel)
+
+      threadDelay $ round $ timeStep * 1000 * 1000
+      spaceStep space timeStep
+
+  shapeFree ballShape
+  bodyFree ballBody
+  shapeFree ground
+  spaceFree space
+  where
+    runFor time step inner = go time
+      where
+        go time'
+          | time' <= 0 = pure ()
+          | otherwise  = inner (time - time') *> go (time' - step)
+
+display :: MVar [VisObj] -> IO ()
+display dm = do
+  d <- takeMVar dm
+  N.run 800 600 "Chiphunk" $
+    N.showFPS "Liberation Sans" $
+    N.loadFont "/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf" "Liberation Sans" $
+    N.asWindow $
+      N.translateP 400 300 .
+      N.scaleP' (0, 0) 10 .
+      N.scalePy (0, 0) (-1) .
+      mconcat <$>
+        sequence (fmap render . runVisObj <$> d)
+  where
+    render = \case
+      Segment (Vect ax ay) (Vect bx by) -> N.stroke (NVG.Color 1 1 1 1) $
+        N.line (realToFrac ax, realToFrac ay) (realToFrac bx, realToFrac by)
+      Ball (Vect x y) r a ->
+        let c = (realToFrac x, realToFrac y)
+        in N.stroke (NVG.Color 1 1 1 1) $
+            N.rotateS c (realToFrac a) $
+            mconcat
+              [ N.circle c (realToFrac r)
+              , N.line c (realToFrac $ x - r / 2, realToFrac y)
+              ]
+
+data VisShape =
+    Segment
+    { segEndpointA :: Vect
+    , segEndpointB :: Vect
+    }
+  | Ball
+    { ballCenter :: Vect
+    , ballRadius :: Double
+    , ballAngle :: Double
+    }
+  deriving Show
+
+newtype VisObj = VisObj
+  { runVisObj :: IO VisShape
+  }
+
+mkRefObj :: IORef VisShape -> VisObj
+mkRefObj r = VisObj $ readIORef r
+
+mkStaticObj :: VisShape -> VisObj
+mkStaticObj = VisObj . pure
+
+mkBallBody :: Body -> Double -> VisObj
+mkBallBody b r = VisObj $ Ball <$> get (bodyPosition b)
+                               <*> pure r
+                               <*> get (bodyAngle b)
diff --git a/chiphunk.cabal b/chiphunk.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 3b21f15c38f8966ef0527241feb3899a7e824712920c28672784293c6a71c98b
+-- hash: affa04d0e05ec0c06f300e0e619be66311279ba5faa40e044602907b6e933043
 
 name:           chiphunk
-version:        0.1.2.2
+version:        0.1.3.0
 synopsis:       Haskell bindings for Chipmunk2D physics engine
 description:    Please see the README on GitHub at <https://github.com/CthulhuDen/chiphunk#readme>
 category:       Physics
@@ -53,6 +53,10 @@ extra-source-files:
     src/Chiphunk/wrapper.h
     Chipmunk2D-7.0.2/src/prime.h
 
+flag library-only
+  manual: False
+  default: True
+
 library
   exposed-modules:
       Chiphunk.Low
@@ -121,3 +125,20 @@ library
       Chipmunk2D-7.0.2/src/cpSweep1D.c
 
       src/Chiphunk/wrapper.c
+
+executable chiphunk
+  main-is: Main.hs
+  other-modules:
+      Paths_chiphunk
+  hs-source-dirs:
+      app
+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N2
+  build-depends:
+      async >=2.2.1 && <2.3
+    , base >=4.7 && <5
+    , chiphunk
+    , nanovg >=0.6.0.0 && <0.7
+    , nanovg-simple >=0.5.0.0 && <0.6
+  if flag(library-only)
+    buildable: False
+  default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
@@ -1,5 +1,5 @@
 name:                chiphunk
-version:             0.1.2.2
+version:             0.1.3.0
 synopsis:            Haskell bindings for Chipmunk2D physics engine
 description:         Please see the README on GitHub at <https://github.com/CthulhuDen/chiphunk#readme>
 homepage:            https://github.com/CthulhuDen/chiphunk#readme
@@ -124,3 +124,26 @@ library:
       Chipmunk2D-7.0.2/src/cpSweep1D.c
 
       src/Chiphunk/wrapper.c
+
+executables:
+  chiphunk:
+    when:
+      - condition: flag(library-only)
+        buildable: false
+    source-dirs:     app
+    main:            Main.hs
+    ghc-options:
+      - -O2
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N2
+    dependencies:
+      - chiphunk
+      - async >= 2.2.1 && < 2.3
+      - nanovg >= 0.6.0.0 && < 0.7
+      - nanovg-simple >= 0.5.0.0 && < 0.6
+
+flags:
+  library-only:
+    default: true
+    manual: false
diff --git a/stack.yaml b/stack.yaml
@@ -3,4 +3,10 @@ resolver: lts-16.14
 packages:
 - .
 
-extra-deps: []
+extra-deps:
+  - nanovg-0.6.0.0
+  - nanovg-simple-0.5.0.0
+
+flags:
+  chiphunk:
+    library-only: false
diff --git a/stack.yaml.lock b/stack.yaml.lock
@@ -3,7 +3,21 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: nanovg-0.6.0.0@sha256:326e73fe2c4ec56656fa42894c53a8e26b3e60449c69578f5f6da50c0ad60ed2,4146
+    pantry-tree:
+      size: 2477
+      sha256: a5e327e2216aea778723aeb77d8868376ff4999d1b3cd4d4fe17d38d0ff04265
+  original:
+    hackage: nanovg-0.6.0.0
+- completed:
+    hackage: nanovg-simple-0.5.0.0@sha256:57a194573b63f7c22ba48376e02341aebde2d577e2898e75d6c669c69f6507e4,1895
+    pantry-tree:
+      size: 725
+      sha256: 3be82ff9c16cfd9476701eeba5020a27cd1f9c6767379acf522a77138dd9f240
+  original:
+    hackage: nanovg-simple-0.5.0.0
 snapshots:
 - completed:
     size: 532382