Add source files, commit before reverting pictures to lists

src/Dodge/WallCreatureCollisions.hs

@@ -0,0 +1,95 @@
+module Dodge.WallCreatureCollisions where
+-- imports {{{
+import Dodge.Data
+import Dodge.Base
+import Geometry
+
+import Data.List
+import Data.Maybe
+import Data.Function
+import Control.Lens
+import qualified Data.IntMap.Strict as IM
+
+colCrsWalls :: World -> World
+colCrsWalls w = over creatures (fmap (colCrWall w)) w
+
+colCrWall :: World -> Creature -> Creature
+colCrWall w c = pushOutFromWall w c
+
+pushOutFromWall :: World -> Creature -> Creature
+pushOutFromWall w c 
+    | p1 == p2 = c
+    | otherwise = over crPos ( 
+                              collideCorners rad p1 wallPoints
+                             . 
+                               collideWalls rad p1 ls 
+                             . checkPushThroughs rad p1 ls 
+                             ) 
+                       c 
+    where rad = _crRad c + wallBuffer
+          p1  = _crOldPos c
+          p2  = _crPos c
+          ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
+          wallPoints = nub $ concat ls
+
+-- colCrPushThrough :: World -> Creature -> Creature
+-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
+--     where rad = _crRad cr + wallBuffer
+--           p1  = _crOldPos cr
+--           p2  = _crPos cr
+--           ls  = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
+-- -- probably best to push check pushing through walls before creature springs
+
+-- the amount to push creatures out from walls, extra to their radius
+wallBuffer = 3
+
+-- the following tests whether a moving circle crosses a list of walls, and
+-- places the circle accordingly.
+-- It supposes that the circle will only interact with at most two walls.
+-- the reverse prevents the collision from happening again with the first wall,
+-- when two walls are collided with
+collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
+collideWalls rad cp1 walls cp2
+    = case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of
+            Nothing -> cp2
+            Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of
+                                         Nothing -> cp3
+                                         Just cp4 -> cp4
+
+-- assumes that the wall is orientated
+-- assumes wall points are different
+collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
+collideWall rad cp1 cp2 (wp1:wp2:_) 
+            | isOnWall  = Just newP -- +.+ (1 *.* norm))
+            | otherwise = Nothing
+    where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
+          wp1' = (rad *.* norm) +.+ wp1
+          wp2' = (rad *.* norm) +.+ wp2
+          newP = errorClosestPointOnLine 5 wp1' wp2' cp2
+          isOnWall = circOnLine' wp1 wp2 cp2 rad
+          isJust Nothing = False
+          isJust _       = True
+
+collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
+collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps
+
+-- collide circles with points (outer corners)
+intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
+intersectCirclePoint rad p cCen | dist cCen p > rad = cCen
+                                | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
+
+checkPushThroughs :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
+checkPushThroughs rad cp1 walls cp2
+    = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls
+
+checkPushThrough :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
+checkPushThrough  rad cp1 cp2 (wp1:wp2:_) 
+            | isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
+            | otherwise = Nothing
+    where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
+          wp1' = (rad *.* norm) +.+ wp1
+          wp2' = (rad *.* norm) +.+ wp2
+          newP = errorClosestPointOnLine 5 wp1' wp2' cp2
+          isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
+          isJust Nothing = False
+          isJust _       = True