justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/WallCreatureCollisions.hs
+56 -50
View File
@@ -1,66 +1,70 @@
{- | Deals with moving creature wall collisions. -}
module Dodge.WallCreatureCollisions
( colCrsWalls
, colCrWall
, pushCreatureOutFromWalls
, crOnWall
) where
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Base
import Geometry
-- | Deals with moving creature wall collisions.
module Dodge.WallCreatureCollisions (
colCrsWalls,
colCrWall,
pushCreatureOutFromWalls,
crOnWall,
) where
import Data.Monoid
import Data.Maybe
import Data.Function
import Control.Lens
import Data.Maybe
import Data.Monoid
import Dodge.Base
import Dodge.Data.Universe
import Dodge.Zoning.Wall
import Geometry
colCrsWalls :: Universe -> Universe
colCrsWalls uv = uv & uvWorld . cWorld . creatures %~ fmap (noclipCheck (_uvConfig uv) (_uvWorld uv))
noclipCheck :: Configuration -> World -> Creature -> Creature
noclipCheck cfig w c
noclipCheck cfig w c
| debugOn Noclip cfig && _crID c == 0 = c -- for noclip
| otherwise = colCrWall w c
-- no noclip check, so no need for a configuration file
colCrWall :: World -> Creature -> Creature
colCrWall w c
| p1 == p2 = pushOrCrush ls c
-- | _crPos c' == _crPos c'' = c'
-- | otherwise = c & crPos .~ _crOldPos c
colCrWall w c
| p1 == p2 = pushOrCrush ls c
-- | _crPos c' == _crPos c'' = c'
-- | otherwise = c & crPos .~ _crOldPos c
| otherwise = c'
where
-- c'' = c' & crPos %~ pushOutFromWalls rad ls
where
-- c'' = c' & crPos %~ pushOutFromWalls rad ls
--c' = c & crPos %~ pushOutFromWalls' rad (reverse ls)
c' = c & crPos %~ pushOutFromCorners rad ls'
. pushOutFromWalls rad ls'
. fst . flip (collidePoint p1) wls' -- check push throughs
-- . flip (collidePointWalls' p1) wls -- check push throughs
c' =
c & crPos
%~ pushOutFromCorners rad ls'
. pushOutFromWalls rad ls'
. fst
. flip (collidePoint p1) wls' -- check push throughs
-- . flip (collidePointWalls' p1) wls -- check push throughs
rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = _wlLine <$> wls
p1 = _crOldPos c
p2 = _crPos c
ls = _wlLine <$> wls
ls' = filter (uncurry $ isLHS p1) ls
wls' = filter (not . _wlWalkable) $ wlsNearPoint p2 w
wls = filter (not . _wlWalkable) $ wlsNearPoint p2 w
--wallPoints = map fst ls
--wallPoints = map fst ls
-- the amount to push creatures out from walls, extra to their radius
wallBuffer :: Float
wallBuffer = 0
pushCreatureOutFromWalls :: [(Point2,Point2)] -> Creature -> Creature
pushCreatureOutFromWalls ls cr = cr & crPos %~ pushOutFromWalls (_crRad cr) ls
pushCreatureOutFromWalls :: [(Point2, Point2)] -> Creature -> Creature
pushCreatureOutFromWalls ls cr = cr & crPos %~ pushOutFromWalls (_crRad cr) ls
-- the following tests whether or not a point is on a wall, and if so pushes it
-- out from the wall
-- this is then repeated if the point ends up on a new wall
pushOutFromWalls :: Float -> [(Point2,Point2)] -> Point2 -> Point2
pushOutFromWalls :: Float -> [(Point2, Point2)] -> Point2 -> Point2
pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of
Nothing -> p1
Just p2 -> pushOutFromWalls rad (tail wls) p2
-- possible improvement: choose between the closer of p2 and "p3" to p1
-- possible improvement: choose between the closer of p2 and "p3" to p1
--pushOutFromWalls' :: Float -> [(Point2,Point2)] -> Point2 -> Point2
--pushOutFromWalls' rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall' rad p1)) wls of
@@ -68,43 +72,45 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall
-- Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall' rad p2)) wls
-- -- possible improvement: choose between the closer of p2 and "p3" to p1
pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature
pushOrCrush :: [(Point2, Point2)] -> Creature -> Creature
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
[] -> cr
(p:_) -> cr & crPos .~ p
-- (_:p:_) -> cr
-- & crPos .~ p
-- & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
[] -> cr
(p : _) -> cr & crPos .~ p
where
-- (_:p:_) -> cr
-- & crPos .~ p
-- & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
cpos = _crPos cr
-- note the inclusion of endpoints in circOnSeg
crOnWall :: Creature -> World -> Bool
crOnWall cr = any (uncurry (circOnSeg p r) . _wlLine)
. filter (not . _wlWalkable)
. wlsNearPoint p
crOnWall cr =
any (uncurry (circOnSeg p r) . _wlLine)
. filter (not . _wlWalkable)
. wlsNearPoint p
where
p = _crPos cr
r = _crRad cr
-- assumes that the wall is orientated
-- assumes wall points are different
pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe Point2
pushOutFromWall rad cp2 (wp1,wp2)
| isOnWall = Just newP
pushOutFromWall :: Float -> Point2 -> (Point2, Point2) -> Maybe Point2
pushOutFromWall rad cp2 (wp1, wp2)
| isOnWall = Just newP
| otherwise = Nothing
where
where
norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
wp1' = wp1 +.+ rad *.* norm
wp2' = wp2 +.+ rad *.* norm
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2
pushOutFromCorners :: Float -> [(Point2, Point2)] -> Point2 -> Point2
--pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls
pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst)
squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
squashIntersectCirclePoint rad p cCen
squashIntersectCirclePoint rad p cCen
| dist cCen p > rad = cCen
| otherwise = p +.+ (rad *.* squashNormalizeV (cCen -.- p))
| otherwise = p +.+ (rad *.* squashNormalizeV (cCen -.- p))