diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/shapes-demo.cabal b/shapes-demo.cabal
new file mode 100644
--- /dev/null
+++ b/shapes-demo.cabal
@@ -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
diff --git a/src/EasySDL/Draw.hs b/src/EasySDL/Draw.hs
new file mode 100644
--- /dev/null
+++ b/src/EasySDL/Draw.hs
@@ -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
diff --git a/src/GameInit.hs b/src/GameInit.hs
new file mode 100644
--- /dev/null
+++ b/src/GameInit.hs
@@ -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
diff --git a/src/GameLoop.hs b/src/GameLoop.hs
new file mode 100644
--- /dev/null
+++ b/src/GameLoop.hs
@@ -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
+
diff --git a/src/Geometry.hs b/src/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/src/Geometry.hs
@@ -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
+
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -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
diff --git a/src/Physics/Demo/IOWorld.hs b/src/Physics/Demo/IOWorld.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Demo/IOWorld.hs
@@ -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
diff --git a/src/Physics/Demo/OptWorld.hs b/src/Physics/Demo/OptWorld.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Demo/OptWorld.hs
@@ -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))
diff --git a/src/Physics/Demo/Scenes.hs b/src/Physics/Demo/Scenes.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Demo/Scenes.hs
@@ -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)
diff --git a/src/Physics/Draw.hs b/src/Physics/Draw.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Draw.hs
@@ -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
diff --git a/src/Physics/Draw/Canonical.hs b/src/Physics/Draw/Canonical.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Draw/Canonical.hs
@@ -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
diff --git a/src/Physics/Draw/Linear.hs b/src/Physics/Draw/Linear.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Draw/Linear.hs
@@ -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)
diff --git a/src/Physics/Draw/Opt.hs b/src/Physics/Draw/Opt.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Draw/Opt.hs
@@ -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))
diff --git a/src/Physics/Draw/Transform.hs b/src/Physics/Draw/Transform.hs
new file mode 100644
--- /dev/null
+++ b/src/Physics/Draw/Transform.hs
@@ -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