packages feed

shapes-demo (empty) → 0.1.0.0

raw patch · 16 files changed

+1171/−0 lines, 16 filesdep +StateVardep +arraydep +basesetup-changed

Dependencies added: StateVar, array, base, containers, either, ghc-prim, lens, linear, monad-extras, mtl, sdl2, shapes, text, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2015 ublubu++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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ shapes-demo.cabal view
@@ -0,0 +1,60 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: f0a7b8ac0ba70e1fb6527635874554c13fe8008d0bcdf0d5ec97512adb3204cf++name:           shapes-demo+version:        0.1.0.0+synopsis:       demos for the 'shapes' package+description:    Please see the README on Github at <https://github.com/ublubu/shapes#readme>+category:       Physics+homepage:       https://github.com/ublubu/shapes#readme+bug-reports:    https://github.com/ublubu/shapes/issues+author:         Kynan Rilee+maintainer:     kynan.rilee@gmail.com+copyright:      2018 Kynan Rilee+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/ublubu/shapes++executable shapes-demo+  main-is: Main.hs+  hs-source-dirs:+      src+  build-depends:+      StateVar+    , array+    , base >=4.7 && <5+    , containers+    , either+    , ghc-prim+    , lens+    , linear+    , monad-extras+    , mtl+    , sdl2+    , shapes+    , text+    , transformers+    , vector+  other-modules:+      EasySDL.Draw+      GameInit+      GameLoop+      Geometry+      Physics.Demo.IOWorld+      Physics.Demo.OptWorld+      Physics.Demo.Scenes+      Physics.Draw+      Physics.Draw.Canonical+      Physics.Draw.Linear+      Physics.Draw.Opt+      Physics.Draw.Transform+      Paths_shapes_demo+  default-language: Haskell2010
+ src/EasySDL/Draw.hs view
@@ -0,0 +1,77 @@+module EasySDL.Draw where++import Data.StateVar+import qualified SDL.Video.Renderer as R+import GHC.Word+import Linear.V4++white :: V4 Word8+white = V4 0xFF 0xFF 0xFF 0xFF++red :: V4 Word8+red = V4 0xFF 0x00 0x00 0xFF++green :: V4 Word8+green = V4 0x00 0x80 0x00 0xFF++blue :: V4 Word8+blue = V4 0x00 0x00 0xFF 0xFF++yellow :: V4 Word8+yellow = V4 0xFF 0xFF 0x00 0xFF++black :: V4 Word8+black = V4 0x00 0x00 0x00 0xFF++pink :: V4 Word8+pink = V4 0xFF 0x3E 0x96 0xFF++cyan :: V4 Word8+cyan = V4 0x00 0xFF 0xFF 0xFF++darkBlue :: V4 Word8+darkBlue = V4 0x00 0x00 0xA0 0xFF++lightBlue :: V4 Word8+lightBlue = V4 0xAD 0xD8 0xE6 0xFF++purple :: V4 Word8+purple = V4 0x80 0x00 0x80 0xFF++magenta :: V4 Word8+magenta = V4 0xFF 0x00 0xFF 0xFF++silver :: V4 Word8+silver = V4 0xC0 0xC0 0xC0 0xFF++grey :: V4 Word8+grey = V4 0x80 0x80 0x80 0xFF++orange :: V4 Word8+orange = V4 0xFF 0xA5 0x00 0xFF++brown :: V4 Word8+brown = V4 0xA5 0x2A 0x2A 0xFF++maroon :: V4 Word8+maroon = V4 0x80 0x00 0x00 0xFF++lime :: V4 Word8+lime = V4 0x00 0xFF 0x00 0xFF++olive :: V4 Word8+olive = V4 0x80 0x80 0x00 0xFF++clearScreen :: R.Renderer -> IO ()+clearScreen renderer = do+  setColor renderer white+  R.clear renderer++setColor :: R.Renderer -> V4 Word8 -> IO ()+setColor r c = R.rendererDrawColor r $= c++withBlankScreen :: R.Renderer -> IO () -> IO ()+withBlankScreen r operation = do+  clearScreen r+  operation+  R.present r
+ src/GameInit.hs view
@@ -0,0 +1,24 @@+module GameInit where++import Data.Text+import qualified SDL.Init as I+import qualified SDL.Hint as H+import qualified SDL.Video as V+import qualified SDL.Video.Renderer as R+import Foreign.C.Types+import Linear.V2++runMain :: String -> V2 CInt -> (R.Renderer -> IO ()) -> IO ()+runMain windowTitle screenSize main = do+  I.initialize [I.InitVideo, I.InitTimer, I.InitEvents]++  _ <- H.setHintWithPriority H.DefaultPriority H.HintRenderScaleQuality H.ScaleLinear+  window <- V.createWindow (pack windowTitle)+            (V.defaultWindow { V.windowInitialSize = screenSize })+  renderer <- V.createRenderer window (-1) R.defaultRenderer++  main renderer++  V.destroyRenderer renderer+  V.destroyWindow window+  I.quit
+ src/GameLoop.hs view
@@ -0,0 +1,84 @@+module GameLoop where++import qualified SDL.Time+import Control.Concurrent+import Control.Monad.State++import GHC.Word++testStep :: Integer -> Word32 -> IO Integer+testStep i t = do+  putStrLn $ "step " ++ show i ++ " at " ++ show t+  return (i + 1)++testTest :: Integer -> Bool+testTest = (> 5)++testTimedRunWhile :: IO ()+testTimedRunWhile = do+  t0 <- SDL.Time.ticks+  timedRunUntil t0 1000 0 testTest testStep++updater :: MonadIO m => (a -> Word32 -> IO a) -> StateT a m ()+updater f = do+  result <- get+  time <- SDL.Time.ticks+  result' <- liftIO $ f result time+  put result'+  return ()++timedUpdater :: MonadIO m+             => Word32+             -> (a -> Word32 -> m a)+             -> StateT (Word32, a) m ()+timedUpdater dt f = do+  (target, s) <- get+  time <- SDL.Time.ticks+  let wait = target - time in when (target > time) (liftIO $ threadDelay (1000 * fromIntegral wait))+  time' <- SDL.Time.ticks+  s' <- lift $ f s time'+  put (target + dt, s')+  return ()++timedRunWhile :: MonadIO m+              => Word32+              -> Word32+              -> a+              -> (a -> Bool)+              -> (a -> Word32 -> m a)+              -> m ()+timedRunWhile t0 dt s0 test f = void $ runStateT u' (t0, s0)+  where u = timedUpdater dt f+        u' = do+          (_, s) <- get+          when (test s) $ u >> u'++runWhile :: MonadIO m => a -> (a -> Bool) -> StateT a m () -> m ()+runWhile s0 test f = void $ runStateT f' s0+  where f' = do+          s <- get+          when (test s) $ f >> f'++runUntil :: MonadIO m => a -> (a -> Bool) -> StateT a m () -> m ()+runUntil s0 test = runWhile s0 (not . test)++timedRunUntil :: MonadIO m+              => Word32+              -> Word32+              -> a+              -> (a -> Bool)+              -> (a -> Word32 -> m a)+              -> m ()+timedRunUntil t0 dt s0 test = timedRunWhile t0 dt s0 (not . test)++timeSteps :: (RealFrac a, Integral b) => a -> a -> (b, a)+timeSteps dt tstep = (steps, remaining)+  where steps = floor (dt / tstep)+        remaining = max 0 (dt - fromIntegral steps * tstep)++timeSteps_ :: (Ord a, Num a, Integral b) => a -> a -> (b, a)+timeSteps_ dt = f (0, dt)+  where f res@(steps, remaining) tstep = if remaining > tstep+                                         then f (steps + 1, remaining - tstep) tstep+                                         else res+
+ src/Geometry.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++module Geometry where++import Control.Applicative+import Data.Foldable+import Data.Monoid++data Pair a = Pair a a deriving (Show, Eq)++instance Functor Pair where+  fmap f (Pair x y) = Pair (f x) (f y)++instance Applicative Pair where+  pure f = Pair f f+  (Pair f g) <*> (Pair x y) = Pair (f x) (g y)++instance Num a => Num (Pair a) where+  (+) = liftA2 (+)+  (-) = liftA2 (-)+  (*) = liftA2 (*)+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++instance Fractional a => Fractional (Pair a) where+  fromRational = pure . fromRational+  a / b = (/) <$> a <*> b++instance Foldable Pair where+  foldMap f (Pair x y) = mappend (f x) (f y)++cross :: Num a => Pair a -> Pair a -> a+cross (Pair ax ay) (Pair bx by) = (ax * by) - (bx * ay)++dot :: Num a => Pair a -> Pair a -> a+dot (Pair ax ay) (Pair bx by) = (ax * bx) + (ay * by)++zero :: Num a => Pair a+zero = Pair 0 0++pairToTuple :: Pair a -> (a, a)+pairToTuple (Pair a b) = (a, b)++tupleToPair :: (a, a) -> Pair a+tupleToPair (a, b) = Pair a b++data Transform a = Transform { transformScale :: a+                             , transformOrigin :: a } deriving (Eq, Show)++joinTrans :: (Num a) => Transform a -> Transform a -> Transform a+joinTrans (Transform scale origin) (Transform scale' origin') =+  Transform (scale * scale') (origin * scale' + origin')++instance Functor Transform where+  fmap f (Transform scale origin) = Transform (f scale) (f origin)++class Convert a b where+  convert :: a -> b++instance Applicative t => Convert a (t a) where+  convert = pure+
+ src/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import GameInit+import Linear.V2++import qualified Physics.Engine.Main as Opt+import Physics.Demo.OptWorld()+import qualified Physics.Demo.IOWorld as IOWorld++main :: IO ()+main =+  let window = V2 800 600+      scale = V2 40 40+  in runMain "physics test" window $ IOWorld.demoMain Opt.engineP (fmap fromIntegral window) scale
+ src/Physics/Demo/IOWorld.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}++module Physics.Demo.IOWorld where++import Control.Monad+import Control.Monad.IO.Class+import Control.Lens ((^.), (.~), (%~), (&), makeLenses)+import Data.Proxy+++import Linear.V2+import Linear.Matrix (M33)++import EasySDL.Draw+import qualified SDL.Event as E+import qualified SDL.Time as T+import qualified SDL.Video.Renderer as R+import qualified SDL.Input.Keyboard as K+import qualified SDL.Input.Keyboard.Codes as KC+import GameLoop hiding (testStep)++import Physics.Draw+import Physics.Draw.Canonical+import Physics.Engine.Class+import Utils.Utils++import Physics.Scenes.Scene+import Physics.Demo.Scenes++class (PhysicsEngine e, PEExternalObj e ~ (), MonadIO (DemoM e)) => Demo e where+  type DemoM e :: * -> *+  runDemo :: Proxy e -> Scene e -> DemoM e a -> IO a+  resetEngine :: Proxy e -> Scene e -> DemoM e ()+  drawWorld :: Proxy e -> R.Renderer -> M33 Double -> DemoM e ()+  demoWorld :: Proxy e -> DemoM e (PEWorld' e)+  worldContacts :: Proxy e -> DemoM e [Contact]+  worldAabbs :: Proxy e -> DemoM e [Aabb]+  debugEngineState :: Proxy e -> DemoM e String+  updateWorld :: Proxy e -> DemoM e ()++data DemoState =+  DemoState { _demoFinished :: Bool+            , _demoSceneIndex :: Int+            , _demoDrawDebug :: Bool+            , _demoPrintDebug :: Bool+            , _demoViewTransform :: M33 Double+            }+makeLenses ''DemoState++getViewTransform :: V2 Double -> V2 Double -> M33 Double+getViewTransform window scale = fst $ viewTransform window scale (V2 0 0)++initialState :: Int -> M33 Double -> DemoState+initialState i = DemoState False i True False++nextInitialState :: (Demo e) => Proxy e -> DemoState -> Int -> DemoM e DemoState+nextInitialState p DemoState{..} i = do+  resetEngine p (scenes p !! i)+  return $ initialState i _demoViewTransform+    & demoDrawDebug .~ _demoDrawDebug+    & demoPrintDebug .~ _demoPrintDebug++timeStep :: Num a => a+timeStep = 10++renderWorld :: (Demo e) => Proxy e -> R.Renderer -> DemoState -> DemoM e ()+renderWorld p r DemoState{..} = do+  liftIO $ setColor r black+  drawWorld p r _demoViewTransform++renderContacts :: (Demo e) => Proxy e -> R.Renderer -> DemoState -> DemoM e ()+renderContacts p r DemoState{..} = do+  liftIO $ setColor r pink+  contacts <- worldContacts p+  liftIO $ mapM_ (drawContact r . transform _demoViewTransform) contacts++renderAabbs :: (Demo e) => Proxy e -> R.Renderer -> DemoState -> DemoM e ()+renderAabbs p r DemoState{..} = do+  liftIO $ setColor r silver+  aabbs <- worldAabbs p+  liftIO $ mapM_ (drawAabb r . transform _demoViewTransform) aabbs++demoStep :: (Demo e) => Proxy e -> R.Renderer -> DemoState -> DemoM e DemoState+demoStep p r s0@DemoState{..} = do+  events <- liftIO E.pollEvents+  liftIO $ clearScreen r+  renderWorld p r s0+  when (s0 ^. demoDrawDebug) $ do+    renderContacts p r s0+    renderAabbs p r s0+  when (s0 ^. demoPrintDebug) $ do+    debug <- debugEngineState p+    liftIO $ print debug+  s1 <- foldM (handleEvent p) s0 events+  updateWorld p+  liftIO $ R.present r+  return s1++handleEvent :: (Demo e) => Proxy e -> DemoState -> E.Event -> DemoM e DemoState+handleEvent _ s0 (E.Event _ E.QuitEvent) =+  return s0 { _demoFinished = True }+handleEvent p s0 (E.Event _ (E.KeyboardEvent (E.KeyboardEventData _ motion _ key)))+  | motion == E.Pressed =+    handleKeypress p s0 (K.keysymScancode key) (K.keysymModifier key)+  | otherwise = return s0+handleEvent _ s0 _ = return s0++handleKeypress :: (Demo e)+               => Proxy e+               -> DemoState+               -> K.Scancode+               -> K.KeyModifier+               -> DemoM e DemoState+handleKeypress p state KC.ScancodeR _ =+  nextInitialState p state (state ^. demoSceneIndex)+handleKeypress p state KC.ScancodeN km+  | K.keyModifierLeftShift km || K.keyModifierRightShift km =+    nextInitialState p state $+    (state ^. demoSceneIndex - 1)+    `posMod` sceneCount+  | otherwise =+    nextInitialState p state $+    (state ^. demoSceneIndex + 1)+    `mod` sceneCount+  where sceneCount = length $ scenes p+handleKeypress _ state KC.ScancodeD _ =+  return $ state & demoDrawDebug %~ not+handleKeypress _ state KC.ScancodeP _ =+  return $ state & demoPrintDebug %~ not+handleKeypress _ state _ _ = return state++demoMain :: (Demo e) => Proxy e -> V2 Double -> V2 Double -> R.Renderer -> IO ()+demoMain p window scale r = do+  t0 <- T.ticks+  let demo = timedRunUntil t0 timeStep (initialState 0 $ getViewTransform window scale) _demoFinished (\s _ -> demoStep p r s)+  runDemo p (head $ scenes p) demo
+ src/Physics/Demo/OptWorld.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}++module Physics.Demo.OptWorld where++import           Control.Lens+import           Control.Monad+import           Control.Monad.Reader+import           Control.Monad.ST+import           Control.Monad.State.Strict+import           Data.Maybe+import qualified Data.Vector.Unboxed        as V++import qualified Physics.Broadphase.Aabb    as B+import qualified Physics.Broadphase.Grid    as G+import           Physics.Contact+import           Physics.Contact.ConvexHull+import           Physics.Contact.Types+import           Physics.Engine+import qualified Physics.Engine.Main        as OM+import           Physics.Scenes.Scene+import           Physics.World.Class++import           Physics.Demo.IOWorld       (Demo (..))+import           Physics.Draw.Canonical+import qualified Physics.Draw.Opt           as D++import           Utils.Descending+import           Utils.Utils++instance Demo (Engine ()) where+  type DemoM (Engine ()) = ReaderT OM.EngineConfig (StateT (OM.EngineState () RealWorld) IO)+  runDemo _ scene@Scene{..} action = do+    eState <- liftIO . stToIO $ OM.initEngine scene+    evalStateT (runReaderT action eConfig) eState+    where eConfig = OM.EngineConfig 0.01 _scContactBeh+  resetEngine _ scene =+    convertEngineT $ OM.changeScene scene+  drawWorld p r vt = do+    world <- demoWorld p+    liftIO $ D.drawWorld r vt world+  demoWorld _ = view _1 <$> get+  worldContacts p = do+    world <- demoWorld p+    let cs :: Descending Contact'+        cs = fmap (flipExtractUnsafe . snd) . join $ generateContacts <$> culledPairs+        pairKeys = G.culledKeys (G.toGrid OM.gridAxes world)+        culledPairs = fmap f pairKeys+        f :: (Int, Int) -> (Shape, Shape)+        f ij = fromJust $ iixView (\k -> wObj k . woShape) ij world+    return . _descList $ toCanonical <$> cs+  worldAabbs p = do+    world <- demoWorld p+    return $ toCanonical . snd <$> V.toList (B.toAabbs world)+  debugEngineState _ = return "<insert debug trace here>"+  updateWorld _ = void . convertEngineT $ OM.updateWorld++convertEngineT :: OM.EngineST () RealWorld a -> DemoM (Engine ()) a+convertEngineT action =+  ReaderT (\config -> StateT (\state -> stToIO $ runStateT (runReaderT action config) state))
+ src/Physics/Demo/Scenes.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+module Physics.Demo.Scenes where++import Data.Proxy++import Physics.Scenes.Scene+import Physics.Engine.Class+import Utils.Utils (posMod)++import qualified Physics.Scenes.TwoFlyingBoxes as S0+import qualified Physics.Scenes.FourBoxesTwoStatic as S1+import qualified Physics.Scenes.Rolling as S2+import qualified Physics.Scenes.Stacks as S3+import qualified Physics.Scenes.Balls as S4++scenes :: (PhysicsEngine e, PEExternalObj e ~ ()) => Proxy e -> [Scene e]+scenes p = [ S4.makeScene (10, 10) 1 1 p ()+           , S4.makeScene' (30, 30) 0.2 1 p ()+           , S3.makeScene (30, 30) 1 p ()+           , S1.scene p () () () ()+           , S1.scene' p () () () ()+           , S2.scene p () ()+           , S3.scene p ()+           , S3.scene' p ()+           , S3.scene'' p ()+           , S3.scene''' p ()+           , S0.scene p () ()+           , S4.circleAndBox p () ()+           , S4.twoCircles p () ()+           ]++nextScene :: Int -> [a] -> (Int, a)+nextScene i ss = (i', ss !! i')+  where i' = posMod (i + 1) (length ss)
+ src/Physics/Draw.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++module Physics.Draw where++import Control.Lens ((^.), _1, _2)+import Linear.Affine+import Linear.V2+import qualified SDL.Video.Renderer as R+import Physics.Draw.Canonical+import Physics.Draw.Transform (WorldTransform, joinTransforms', translateTransform, scaleTransform, translateTransform)+import Physics.Draw.Linear++toRenderable :: (Functor f, RealFrac a, Integral b) => f a -> f b+toRenderable = fmap floor++centeredRectangle :: (Fractional a) => P2 a -> V2 a -> R.Rectangle a+centeredRectangle center size = R.Rectangle (center .-^ halfSize) size+  where halfSize = fmap (/2) size++viewTransform :: (Floating a) => V2 a -> V2 a -> V2 a -> WorldTransform a+viewTransform window (V2 x y) d = joinTransforms' [ translateTransform window'+                                                  , scaleTransform (V2 x (-y))+                                                  , translateTransform (-d) ]+  where window' = fmap (/2) window++drawLine :: (RealFrac a) => R.Renderer -> P2 a -> P2 a -> IO ()+drawLine r a b = R.drawLine r (toRenderable a) (toRenderable b)++drawLine_ :: (RealFrac a) => R.Renderer -> (P2 a, P2 a) -> IO ()+drawLine_ r = uncurry (drawLine r)++drawPoint :: (RealFrac a) => R.Renderer -> P2 a -> IO ()+drawPoint r p = R.drawPoint r (toRenderable p)++drawThickPoint :: (RealFrac a) => R.Renderer -> P2 a -> IO ()+drawThickPoint r p = R.fillRect r (Just . toRenderable $ centeredRectangle p (V2 4 4))++drawAabb :: R.Renderer -> Aabb -> IO ()+drawAabb r (Aabb aabb) = do+  drawLine r nw ne+  drawLine r ne se+  drawLine r se sw+  drawLine r sw nw+  where nw = extractCorner _1 _2+        ne = extractCorner _2 _2+        sw = extractCorner _1 _1+        se = extractCorner _2 _1+        extractCorner lx ly = P $ V2 (aabb ^._x.lx) (aabb ^._y.ly)++drawPolygon :: R.Renderer -> Polygon -> IO ()+drawPolygon r vertices = sequence_ (fmap f segments)+  where f (v1, v2) = drawLine r v1 v2+        segments = zip vertices (tail vertices ++ [head vertices])++drawOverlap :: R.Renderer -> Overlap -> IO ()+drawOverlap r Overlap{..} = do+  drawLine r a b+  drawLine r c c'+  drawThickPoint r _overlapPenetrator+  where (a, b) = _overlapEdge+        c = center2 a b+        c' = c .+^ _overlapVector++drawContact :: R.Renderer -> Contact -> IO ()+drawContact r Contact{..} = do+  (c, c') <- either f g _contactPoints+  drawLine r c c'+  where f a = do+          drawThickPoint r a+          return (a, a .+^ _contactNormal)+        g (a, b) = do+          drawThickPoint r a+          drawThickPoint r b+          return (c, c')+            where c = center2 a b+                  c' = c .+^ _contactNormal
+ src/Physics/Draw/Canonical.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Physics.Draw.Canonical where++import Data.Either.Combinators+import Linear.Affine (Point(..))+import Linear.V2+import Linear.Matrix+import Physics.Draw.Linear+import Utils.Utils++type V2' = V2 Double+type P2' = P2 Double+type ContactPoints = Either P2' (P2', P2')+data Contact =+  Contact { _contactPoints :: ContactPoints+          , _contactNormal :: V2'+          } deriving (Show)++data Overlap =+  Overlap { _overlapEdge :: (P2', P2')+          , _overlapVector :: V2'+          , _overlapPenetrator :: P2'+          } deriving (Show)++type Polygon = [P2']++newtype Aabb = Aabb (V2 (Double, Double))++class Transformable t where+  transform :: M33 Double -> t -> t++instance Transformable V2' where+  transform = afmul++instance Transformable P2' where+  transform = afmul++instance (Transformable a) => Transformable (a, a) where+  transform = pairMap . transform++instance (Transformable a, Transformable b) => Transformable (Either a b) where+  transform t = mapBoth (transform t) (transform t)++instance Transformable Contact where+  transform t (Contact x y) =+    Contact (transform t x) (transform t y)++instance Transformable Overlap where+  transform t (Overlap x y z) =+    Overlap (transform t x) (transform t y) (transform t z)++instance (Transformable a) => Transformable [a] where+  transform = fmap . transform++instance Transformable Aabb where+  transform t (Aabb box) = Aabb $ (,) <$> minBox <*> maxBox+    where (P minBox) = transform t . P $ fmap fst box+          (P maxBox) = transform t . P $ fmap snd box++class IsCanonical a where+  dummyIsCanonical :: a+  dummyIsCanonical = undefined++instance IsCanonical V2'+instance IsCanonical P2'+instance IsCanonical ContactPoints+instance IsCanonical Contact+instance IsCanonical Overlap+instance IsCanonical Polygon+instance IsCanonical Aabb++class (IsCanonical (Canonical a)) => ToCanonical a where+  type Canonical a+  toCanonical :: a -> Canonical a++transCanon :: (ToCanonical a, Transformable (Canonical a))+           => M33 Double+           -> a+           -> Canonical a+transCanon t = transform t . toCanonical
+ src/Physics/Draw/Linear.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++module Physics.Draw.Linear where++import GHC.TypeLits (Nat)+import GHC.TypeNats (KnownNat)+import Control.Lens+import qualified Data.Vector as Vec+import Data.Vector ((!))+import Data.Maybe+import Linear.Affine+import Linear.Epsilon+import Linear.V+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Matrix+import Linear.Metric++type V6 a = V 6 a+type M66 a = V6 (V6 a)+type P2 a = Point V2 a++join22 :: V2 a -> V2 a -> V4 a+join22 (V2 ax ay) (V2 bx by) = V4 ax ay bx by++join33 :: V3 a -> V3 a -> V 6 a+join33 (V3 a b c) (V3 d e f) = listToV [a, b, c, d, e, f]++split33 :: V6 a -> (V3 a, V3 a)+split33 v = Vec.splitAt 3 (toVector v) & both %~ (\v' -> V3 (v' ! 0) (v' ! 1) (v' ! 2))++flip33 :: V6 a -> V6 a+flip33 v = listToV [d, e, f, a, b, c]+  where (a, b, c, d, e, f) = extract6 v++extract6 :: V6 a -> (a, a, a, a, a, a)+extract6 v6 = (v ! 0, v ! 1, v ! 2, v ! 3, v ! 4, v ! 5)+  where v = toVector v6++join44 :: V4 a -> V4 a -> V 8 a+join44 (V4 a b c d) (V4 e f g h) = listToV [a, b, c, d, e, f, g, h]++cross22 :: Num a => V2 a -> V2 a -> a+cross22 (V2 ax ay) (V2 bx by) = (ax * by) - (ay * bx)++append2 :: V2 a -> a -> V3 a+append2 (V2 a b) = V3 a b++split3 :: V3 a -> (V2 a, a)+split3 (V3 a b c) = (V2 a b, c)++listToV :: KnownNat n => [a] -> V (n :: Nat) a+listToV = fromJust . fromVector . Vec.fromList++rotate22_ :: (Num a) => a -> a -> M22 a+rotate22_ cosv sinv = V2 (V2 cosv (-sinv)) (V2 sinv cosv)++rotate22 :: (Floating a) => a -> M22 a+rotate22 ori = rotate22_ c s+  where c = cos ori+        s = sin ori++afmat33 :: (Num a) => M22 a -> M33 a+afmat33 (V2 x y) = V3 (append2 x 0) (append2 y 0) (V3 0 0 1)++aftranslate33 :: (Num a) => V2 a -> M33 a+aftranslate33 (V2 x y) = V3 (V3 1 0 x) (V3 0 1 y) (V3 0 0 1)++afrotate33 :: (Floating a) => a -> M33 a+afrotate33 = afmat33 . rotate22++afscale33 :: (Num a) => V2 a -> M33 a+afscale33 (V2 x y) = V3 (V3 x 0 0) (V3 0 y 0) (V3 0 0 1)++dfa :: (Num a) => Diff V2 a -> V3 a+dfa (V2 x y) = V3 x y 0++afd :: V3 a -> Diff V2 a+afd = view _xy++pfa :: (Num a) => P2 a -> V3 a+pfa (P (V2 x y)) = V3 x y 1++afp :: V3 a -> P2 a+afp = P . view _xy++afdot :: (Num a) => P2 a -> Diff V2 a -> a+afdot a b = view _Point a `dot` b++afdot' :: (Num a) => Diff V2 a -> P2 a -> a+afdot' = flip afdot++data Diag6 a = Diag6 (V6 a)++toDiag6 :: [a] -> Diag6 a+toDiag6 = Diag6 . listToV++mulDiag6 :: (Num a) => V6 a -> Diag6 a -> V6 a+mulDiag6 v (Diag6 d) = (*) <$> v <*> d++mulDiag6' :: (Num a) => Diag6 a -> V6 a -> V6 a+mulDiag6' = flip mulDiag6++class AffineTrans t a where+  afmul :: M33 a -> t -> t++instance (Num a) => AffineTrans (Point V2 a) a where+  afmul m = afp . (m !*) . pfa++instance (Num a) => AffineTrans (V2 a) a where+  afmul m = afd . (m !*) . dfa++clockwise22 :: Num a => M22 a+clockwise22 = V2 (V2 0 1) (V2 (-1) 0)++clockwise2 :: Num a => V2 a -> V2 a+clockwise2 (V2 x y) = V2 y (-x)++anticlockwise22 :: Num a => M22 a+anticlockwise22 = V2 (V2 0 1) (V2 (-1) 0)++anticlockwise2 :: Num a => V2 a -> V2 a+anticlockwise2 (V2 x y) = V2 (-y) x++perpendicularTowards :: (Num a, Ord a) => V2 a -> V2 a -> V2 a+a `perpendicularTowards` b = rot b+  where rot = if a `cross22` b > 0 then clockwise2+              else anticlockwise2++similarDir :: (Metric t, Num a, Ord a) => t a -> t a -> Bool+similarDir a b = a `dot` b > 0++horizontalizer22 :: (Floating a) => V2 a -> M22 a+horizontalizer22 d@(V2 a o) = rotate22_ cosv (-sinv)+  where sinv = o / h+        cosv = a / h+        h = norm d++data Line2 a = Line2 { linePoint :: !(P2 a)+                     , lineNormal :: !(V2 a) }++toLine2 :: (Num a) => P2 a -> P2 a -> Line2 a+toLine2 a b = Line2 { linePoint = a+                    , lineNormal = clockwise2 (b .-. a) }++perpLine2 :: (Num a) => P2 a -> P2 a -> Line2 a+perpLine2 a b = Line2 { linePoint = a+                      , lineNormal = b .-. a }++-- solving some `mx = b` up in here+intersect2 :: (Floating a, Epsilon a) => Line2 a -> Line2 a -> P2 a+intersect2 (Line2 p n) (Line2 p' n') =+  P (inv22 m !* b)+  where b = V2 (p `afdot` n) (p' `afdot` n')+        m = V2 n n'++center2 :: (Fractional a) => P2 a -> P2 a -> P2 a+center2 a b = fmap (/2) (a + b)
+ src/Physics/Draw/Opt.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE MagicHash            #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Physics.Draw.Opt where++import           GHC.Types                  (Double (D#))++import           Physics.Draw.Canonical++import           Control.Lens               (sequenceOf_, (^.))+import           Data.Array                 (elems)+import           Data.Either.Combinators++import qualified Linear.Matrix              as L+import qualified Linear.V2                  as L+import           Physics.Draw+import qualified SDL.Video.Renderer         as R++import qualified Physics.Broadphase.Aabb    as B+import           Physics.Contact            (Shape (..))+import           Physics.Contact.Circle     (Circle (..))+import           Physics.Contact.ConvexHull+import qualified Physics.Contact.SAT        as O+import qualified Physics.Contact.Types      as O+import           Physics.Linear+import           Physics.Linear.Convert+import           Physics.World              (World (..), worldObjs)+import           Physics.World.Object       (WorldObj (..))+import           Utils.Utils++instance ToCanonical V2 where+  type Canonical V2 = V2'+  toCanonical = toLV2++instance ToCanonical P2 where+  type Canonical P2 = P2'+  toCanonical = toLP2++instance ToCanonical O.ContactPoints where+  type Canonical O.ContactPoints = ContactPoints+  toCanonical =+    mapBoth f (fromSP . spMap f)+    where f = toCanonical . _neighborhoodCenter++instance ToCanonical O.Contact where+  type Canonical O.Contact = Contact+  toCanonical O.Contact{..} =+    Contact+    (toCanonical _contactPenetrator)+    (toCanonical . _neighborhoodUnitNormal $ _contactEdge)++instance ToCanonical O.Contact' where+  type Canonical O.Contact' = Contact+  toCanonical O.Contact'{..} =+    Contact+    (Left . toCanonical $ _contactPenetrator')+    (toCanonical _contactEdgeNormal')++instance ToCanonical O.Overlap where+  type Canonical O.Overlap = Overlap+  toCanonical O.Overlap{..} =+    Overlap (e0, e1) depth pen+    where e0 = toCanonical $ _neighborhoodCenter _overlapEdge+          e1 = toCanonical . _neighborhoodCenter . _neighborhoodNext $ _overlapEdge+          n = toCanonical $ _neighborhoodUnitNormal _overlapEdge+          depth = fmap (*(-_overlapDepth)) n+          pen = toCanonical $ _neighborhoodCenter _overlapPenetrator++instance ToCanonical ConvexHull where+  type Canonical ConvexHull = Polygon+  toCanonical ConvexHull{..} = toCanonical <$> elems _hullVertices++unitCircle :: [P2]+unitCircle = fmap f [0,step..(2 - step)]+  where f = P2 . unitV2 . (*pi)+        step = 0.1++instance ToCanonical Circle where+  type Canonical Circle = Polygon+  toCanonical Circle{..} = toCanonical . t <$> unitCircle+    where t (P2 a) = _circleCenter `pplusV2` (_circleRadius `smulV2` a)++instance ToCanonical B.Aabb where+  type Canonical B.Aabb = Aabb+  toCanonical (B.Aabb (B.Bounds x0 x1) (B.Bounds y0 y1)) =+    Aabb $ L.V2 (D# x0, D# x1) (D# y0, D# y1)++drawObj :: R.Renderer -> L.M33 Double -> Shape -> IO ()+drawObj r viewtrans (HullShape hull) =+  drawPolygon r (transform viewtrans . toCanonical $ hull)+drawObj r viewtrans (CircleShape circle) =+  drawPolygon r (transform viewtrans . toCanonical $ circle)++drawWorld :: R.Renderer -> L.M33 Double -> World (WorldObj ()) -> IO ()+drawWorld r vt w = sequenceOf_ traverse (fmap (drawObj r vt . _worldShape) (w ^. worldObjs))
+ src/Physics/Draw/Transform.hs view
@@ -0,0 +1,164 @@+{-# Language MultiParamTypeClasses #-}+{-# Language FlexibleInstances #-}+{-# Language FlexibleContexts #-}++module Physics.Draw.Transform where++import Linear.Affine+import Linear.Matrix+import Linear.V2+import Utils.Utils+import Physics.Draw.Linear++type WorldTransform a = (M33 a, M33 a)++toTransform :: (Floating a) => Diff V2 a -> a -> WorldTransform a+toTransform pos ori = joinTransforms (translateTransform pos) (rotateTransform ori)++scaleTransform :: (Floating a) => V2 a -> WorldTransform a+scaleTransform s@(V2 x y) = (afscale33 s, afscale33 s')+  where s' = V2 (1/x) (1/y)++rotateTransform :: (Floating a) => a -> WorldTransform a+rotateTransform ori = (rot, rot')+  where rot = afrotate33 ori+        rot' = afrotate33 (-ori)++translateTransform :: (Floating a) => Diff V2 a -> WorldTransform a+translateTransform pos = (transl, transl')+  where transl = aftranslate33 pos+        transl' = aftranslate33 (-pos)++idTransform :: (Num a) => WorldTransform a+idTransform = (identity, identity)++joinTransforms :: (Num a) => WorldTransform a -> WorldTransform a -> WorldTransform a+joinTransforms (outer, outer') (inner, inner') = (outer !*! inner, inner' !*! outer')++joinTransforms' :: (Num a) => [WorldTransform a] -> WorldTransform a+joinTransforms' = foldl1 joinTransforms++invertTransform :: WorldTransform a -> WorldTransform a+invertTransform (f, g) = (g, f)++-- TODO: add another type variable to track values that originated in the same local space+-- see lap, Geometry.overlap+data LocalT a b = LocalT !(WorldTransform a) !b deriving (Show, Eq)+type LV2 a = LocalT a (V2 a)+type LP2 a = LocalT a (P2 a)++data WorldT a = WorldT !a deriving (Show, Eq)+type WV2 a = WorldT (V2 a)+type WP2 a = WorldT (Point V2 a)++iExtract :: WorldT a -> a+iExtract (WorldT x) = x++iInject :: a -> WorldT a+iInject = WorldT++iInject_ :: Num a => b -> LocalT a b+iInject_ = LocalT idTransform++instance Functor (LocalT a) where+  fmap f (LocalT t v) = LocalT t (f v)++instance Functor WorldT where+  fmap f (WorldT v) = WorldT (f v)++-- wExtract and wInject don't change the transform - they only move between types+class WorldTransformable t a where+  -- TODO: deduplicate - these are just opposite sides of a tuple+  transform :: WorldTransform a -> t -> t+  untransform :: WorldTransform a -> t -> t++  wExtract :: LocalT a t -> WorldT t+  wExtract (LocalT t v) = WorldT (transform t v)++  wExtract_ :: LocalT a t -> t+  wExtract_ = iExtract . wExtract++  wInject :: WorldTransform a -> WorldT t -> LocalT a t+  wInject t v = LocalT t (untransform t (iExtract v))++  wInject_ :: WorldTransform a -> t -> t -- same as wInject, but throws away type information+  wInject_ = untransform++instance (Floating a) => WorldTransformable (P2 a) a where+  transform (trans, _) = afmul trans+  untransform (_, untrans) = afmul untrans++instance (Floating a) => WorldTransformable (V2 a) a where+  transform (trans, _) = afmul trans+  untransform (_, untrans) = afmul untrans++instance (WorldTransformable t a) => WorldTransformable (WorldT t) a where+  transform t = WorldT . transform t . iExtract+  untransform t = WorldT . untransform t . iExtract++instance (Num a) => WorldTransformable (LocalT a b) a where+  transform t' (LocalT t v) = LocalT (joinTransforms t' t) v+  untransform t' (LocalT t v) = LocalT (joinTransforms (invertTransform t') t) v+  wInject _ = LocalT idTransform . iExtract++instance (WorldTransformable b a) => WorldTransformable (b, b) a where+  transform t = pairMap (transform t)+  untransform t = pairMap (untransform t)++instance (WorldTransformable b a) => WorldTransformable [b] a where+  transform t = map (transform t)+  untransform t = map (untransform t)++instance (WorldTransformable b a) => WorldTransformable (Maybe b) a where+  transform t = fmap (transform t)+  untransform t = fmap (untransform t)++data WaL w a l = WaL { _wlW :: !(WorldT w)+                   , _wlL :: !(LocalT a l)+                   } deriving (Show, Eq)+type WaL' a t = WaL t a t++instance (Num a, WorldTransformable w a, WorldTransformable l a) => WorldTransformable (WaL w a l) a where+  transform t (WaL w l) =+    WaL (transform t w) (transform t l)+  untransform t (WaL w l) =+    WaL (untransform t w) (untransform t l)++wfmap :: (Functor t) => (a -> t b) -> WorldT a -> t (WorldT b)+wfmap f (WorldT v) = fmap WorldT (f v)++wflip :: (Functor t) => WorldT (t a) -> t (WorldT a)+wflip (WorldT v) = fmap WorldT v++wmap :: (a -> b) -> WorldT a -> WorldT b+wmap = fmap++wlift2 :: (a -> b -> c) -> WorldT a -> WorldT b -> WorldT c+wlift2 f x = wap (wmap f x)++wlift2_ :: (a -> b -> c) -> WorldT a -> WorldT b -> c+wlift2_ f x y = iExtract (wlift2 f x y)++wap :: WorldT (a -> b) -> WorldT a -> WorldT b+wap (WorldT f) = wmap f++wlap :: (WorldTransformable a n) => WorldT (a -> b) -> LocalT n a -> WorldT b+wlap f = wap f . wExtract++lwap :: (WorldTransformable a n) => LocalT n (a -> b) -> WorldT a -> LocalT n b+lwap (LocalT t f) x = lmap f (wInject t x)++lap :: (WorldTransformable a n) => LocalT n (a -> b) -> LocalT n a -> LocalT n b+lap f x = lwap f (wExtract x)++lmap :: (a -> b) -> LocalT n a -> LocalT n b+lmap = fmap++lfmap :: (Functor t) => (a -> t b) -> LocalT n a -> t (LocalT n b)+lfmap f (LocalT t v) = fmap (LocalT t) (f v)++lunsafe_ :: (a -> b) -> LocalT n a -> b+lunsafe_ f (LocalT _ v) = f v++wlens :: (Functor f) => (a -> f a) -> WorldT a -> f (WorldT a)+wlens f = fmap WorldT . f . iExtract