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

Move hands to touch walls

Browse Source
This commit is contained in:
justin
2026-03-30 15:50:25 +01:00
parent 4598deb70f
commit c7866cf668
5 changed files with 141 additions and 94 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/HandPos.hs
+41 -4
View File
@@ -14,6 +14,9 @@ module Dodge.Creature.HandPos (
rightHandPQ,
) where
import Control.Monad
import qualified Data.IntMap.Strict as IM
import Linear
import Control.Lens
import Dodge.Creature.Test
import Dodge.Data.Creature
@@ -61,11 +64,44 @@ rightHandPQ cr
| oneH cr = (V3 11 (-3) 20, Q.qID)
| twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0, Q.qID)
| twoFlat cr = (V3 4 (-8) 12, Q.qID)
-- | wl <- crRightHandWall cr = (0, Q.qID)
| Just p <- crRightHandWall cr = (20 & _xy .~ p, Q.qID)
| otherwise = (handWalkingPos LeftForward (-8) cr, Q.qID)
--crRightHandWall :: IM.IntMap Wall -> Creature -> Wall
--crRightHandWall wls cr
crRightHandWall :: Creature -> Maybe Point2
crRightHandWall cr = do
(_,p) <- IM.lookupMin (cr ^. crWallTouch)
let wp = p - cr ^. crPos . _xy
dp = argV wp
ang = nearZeroAngle (cd - dp)
cdp = unitVectorAtAngle cd
x | ang < 0 = 0.8 - (0.5 * ang / (pi / 4))
| otherwise = 0.8* dotV cdp (signorm wp)
y | ang < 0 = 2 - (5 * ang / (pi / 4))
| otherwise = 2
ep = wp - y *^ signorm wp + x *^ vNormal wp
guard $ ang > negate (pi / 8)
return $ ep & _xy %~ rot
where
cd = cr ^. crDir
rot = rotateV (negate cd)
crLeftHandWall :: Creature -> Maybe Point2
crLeftHandWall cr = do
(_,p) <- IM.lookupMin (cr ^. crWallTouch)
let wp = p - cr ^. crPos . _xy
dp = argV wp
ang = nearZeroAngle (cd - dp)
cdp = unitVectorAtAngle cd
x | ang > 0 = 0.8 + (0.5 * ang / (pi / 4))
| otherwise = 0.8* dotV cdp (signorm wp)
y | ang > 0 = 2 + (5 * ang / (pi / 4))
| otherwise = 2
ep = wp - y *^ signorm wp - x *^ vNormal wp
guard $ ang < (pi / 8)
return $ ep & _xy %~ rot
where
cd = cr ^. crDir
rot = rotateV (negate cd)
translateToRightHand :: Creature -> SPic -> SPic
translateToRightHand = overPosSP . translatePointToRightHand
@@ -75,9 +111,10 @@ rightWristPQ cr = rightHandPQ cr `Q.comp` (V3 0 (-4) (-4), Q.qID)
leftHandPQ :: Creature -> Point3Q
leftHandPQ cr
| oneH cr = (V3 0 8 10, Q.qz 0.4)
| twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
| twoFlat cr = (V3 4 8 12, Q.qID)
| Just p <- crLeftHandWall cr = (20 & _xy .~ p, Q.qID)
| oneH cr = (V3 0 8 10, Q.qz 0.4)
| otherwise = (handWalkingPos RightForward 8 cr, Q.qID)
translatePointToLeftHand :: Creature -> Point3 -> Point3
src/Dodge/Data/Creature.hs
+2 -3
View File
@@ -22,6 +22,7 @@ import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IM
import Dodge.Data.ActionPlan
import Dodge.Data.Creature.Misc
import Dodge.Data.Creature.Perception
@@ -30,8 +31,6 @@ import Dodge.Data.Creature.State
import Dodge.Data.Item
import Dodge.Data.Material
import Geometry.Data
import qualified Data.IntSet as IS
--import qualified IntMapHelp as IM
data Creature = Creature
{ _crPos :: Point3
@@ -58,7 +57,7 @@ data Creature = Creature
, _crIntention :: Intention
, _crName :: String
, _crDeathTimer :: Int
, _crWallTouch :: IS.IntSet
, _crWallTouch :: IM.IntMap Point2
}
data CrHP
src/Dodge/TestString.hs
+1 -1
View File
@@ -34,7 +34,7 @@ import Data.Monoid
import RandomHelp
testStringInit :: Universe -> [String]
testStringInit u = [fromMaybe "" $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crName]
testStringInit u = fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . ix 0 . crWallTouch . each
-- (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage . strideAmount)
-- a <> fromMaybe [] (do
-- a w1 <- u ^? uvWorld . cWorld . lWorld . walls . ix 18
src/Dodge/WallCreatureCollisions.hs
+19 -9
View File
@@ -9,7 +9,6 @@ import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Data.Foldable
import qualified Data.IntSet as IS
import Dodge.Base
import Dodge.Creature.Radius
import Dodge.Data.Universe
@@ -56,14 +55,14 @@ pushCr w wls cr
| otherwise = ecr
where
-- stwls = IM.filter (\wl -> uncurry circOnSegNoEndpoints (wl ^. wlLine) sp r) wls
twls = IM.elems $ IM.restrictKeys wls (ecr ^. crWallTouch) -- `IM.union` stwls
twls = IM.elems $ IM.intersection wls (ecr ^. crWallTouch) -- `IM.union` stwls
-- ep = ecr ^. crPos . _xy
ap = cr ^. crOldPos . _xy
-- sp = cr ^. crPos . _xy
ecr = foldl' f (cr & crWallTouch .~ mempty) wls
r = crRad (cr ^. crType)
f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
Just p -> acr & crPos . _xy .~ p & crWallTouch %~ IS.insert (wl ^. wlID)
f acr wl = case pushOutFromWall' r (acr ^. crPos . _xy) (wl ^. wlLine) of
Just (p,hitp) -> acr & crPos . _xy .~ p & crWallTouch . at (wl ^. wlID) ?~ hitp
Nothing -> acr
wallMovement :: LWorld -> Point2 -> Wall -> Point2
@@ -100,11 +99,22 @@ wlWlCrush' w p w1 w2 = (t w1 w2 || t w2 w1) -- test either wall is moving toward
wallBuffer :: Float
wallBuffer = 0
-- 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
---- 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
-- | otherwise = Nothing
-- where
-- n = errorNormalizeV 61 $ vNormal (wp1 - wp2)
-- wp1' = wp1 + rad *^ n
-- wp2' = wp2 + rad *^ n
-- newP = errorClosestPointOnLine 5 wp1' wp2' cp2
-- isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
pushOutFromWall' :: Float -> Point2 -> (Point2, Point2) -> Maybe (Point2,Point2)
pushOutFromWall' rad cp2 (wp1, wp2)
| isOnWall = Just (newP,newP - rad *^ n)
| otherwise = Nothing
where
n = errorNormalizeV 61 $ vNormal (wp1 - wp2)