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

Refactoring

Browse Source
This commit is contained in:
justin
2021-05-03 23:59:20 +02:00
parent b826299cbd
commit e21178b688
20 changed files with 830 additions and 731 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/AIs.hs
+10 -13
View File
@@ -6,7 +6,7 @@ import Dodge.SoundLogic
import Dodge.Creature.Action
import Dodge.RandomHelp
import Dodge.WorldEvent
import Dodge.Creature.Picture
import Geometry
import Picture
@@ -18,18 +18,16 @@ import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query.SP
import qualified Data.ByteString as B
import Control.Lens
import Control.Applicative
import Control.Monad.State
import Control.Monad
import System.Random
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import Foreign.ForeignPtr
import Control.Lens
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Concurrent
import System.Random
import Foreign.ForeignPtr
factionIs :: Faction -> Creature -> Bool
factionIs f c = (_faction $ _crState $ c) == f
@@ -845,7 +843,7 @@ launcherAI inRange outRange w (f,g) cr =
(SetPosture pture:_) -> ((f,g), replaceAction [] $ set (crState . stance . posture) pture cr)
(MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr)
(MoveByFor p i:_) -> ((f,g'), replaceAction [MoveByFor p (i-1)] . crMvBy p $ cr)
(Fire:_) | collidePointWallsSimple cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr))
(Fire:_) | pointHitsWalls cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr))
(wallsAlongLine cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) w)
-> ((f,g),replaceAction [] cr)
| otherwise -> ((tryUseItem cid . f,g'), replaceAction [] cr)
@@ -1220,10 +1218,10 @@ twitchMissAI inRange outRange w (f,g) cr =
(t,g') = randomR (fireRate+10,fireRate+15) g
retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400
where f p = fromMaybe (ypos +.+ p) $ fmap fst
$ collidePointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w)
$ reflectPointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w)
retreatP' = cpos +.+ 300 *.* (cpos -.- ypos)
retreatP'' = fromMaybe retreatP' $ fmap fst
$ collidePointWalls ypos retreatP'
$ reflectPointWalls ypos retreatP'
$ wallsAlongLine ypos retreatP' w
retreatP = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs
fireActions = [TurnToward yposoff, Fire, TurnTo ypos, WaitFor t
@@ -1864,6 +1862,5 @@ spCrRadFac = 8^2
----------------
circLine x = line [(0,0),(x,0)]
sigmoid x = x/sqrt(1+x^2)
src/Dodge/Base.hs
+226 -532
View File
@@ -1,7 +1,19 @@
--{-# LANGUAGE Strict #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
module Dodge.Base where
{- |
Basic helpers.
Consider splitting. -}
module Dodge.Base
( module Dodge.Base
, module Dodge.Base.Zone
, module Dodge.Base.Window
, module Dodge.Base.Collide
)
where
import Dodge.Data
import Dodge.Base.Zone
import Dodge.Base.Window
import Dodge.Base.Collide
import Dodge.Config.Data
import Geometry
import Picture
@@ -24,11 +36,13 @@ rightPad i x xs = take i $ xs ++ repeat x
midPad :: Int -> a -> [a] -> [a] -> [a]
midPad i x xs ys = xs ++ replicate j x ++ ys
where j = i - (length xs + length ys)
where
j = i - (length xs + length ys)
midPadL :: Int -> a -> [a] -> [a] -> [a]
midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
where j = i - length ys
where
j = i - length ys
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil f ps = case span (not . f) ps of
@@ -46,172 +60,30 @@ yourItem w = _crInv (you w) IM.! _crInvSel (you w)
yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
halfWidth,halfHeight :: World -> Float
halfWidth w = getWindowX w / 2
halfHeight w = getWindowY w / 2
getWindowX = _windowX . _config
getWindowY = _windowY . _config
hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-}
hasLOS p1 p2 w = (not $ collidePointWallsSimple p1 p2 nearbyWalls)
where nearbyWalls = wallsAlongLine p1 p2 w
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w
of Just _ -> False
Nothing -> True
isWalkable :: Point2 -> Point2 -> World -> Bool
isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls
where nearbyWalls = wallsAlongLine p1 p2 w
canSee :: Int -> Int -> World -> Bool
canSee i j w = hasLOS p1 p2 w
--canSee i j w = not $ collidePointWallsSimple p1 p2
-- nearbyWalls
where p1 = _crPos (_creatures w IM.! i)
p2 = _crPos (_creatures w IM.! j)
nearbyWalls = wallsAlongLine p1 p2 w
canSeePoint :: Int -> Point2 -> World -> Bool
canSeePoint i p w = hasLOS p1 p w
--canSeePoint i p w = case collidePointWalls p1 p nearbyWalls
-- of Just _ -> False
-- Nothing -> True
where nearbyWalls = wallsAlongLine p1 p w
p1 = _crPos (_creatures w IM.! i)
pathToPointFireable :: Int -> Point2 -> World -> Bool
pathToPointFireable i p w = not $ collidePointWallsSimple (_crPos (_creatures w IM.! i))
p
walls
where walls = IM.filter (not . isJust . \wl -> wl ^? blHP)
$ wallsAlongLine p1 p w
p1 = _crPos (_creatures w IM.! i)
canSeePointAll :: Int -> Point2 -> World -> Bool
canSeePointAll i targPos w = and $ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p)))
[(1,0),(0,1),(-1,0),(0,-1)]
where cr = _creatures w IM.! i
cpos = _crPos cr
radius = _crRad cr
canSeeAny :: Int -> Int -> World -> Bool
canSeeAny fromID toID w = or $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p)))
[(1,0),(0,1),(-1,0),(0,-1)]
where cr = _creatures w IM.! toID
cpos = _crPos cr
radius = _crRad cr
canSeeAll :: Int -> Int -> World -> Bool
canSeeAll fromID toID w = and $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p)))
[(1,0),(0,1),(-1,0),(0,-1)]
where cr = _creatures w IM.! toID
cpos = _crPos cr
radius = _crRad cr
canWalk :: Int -> Int -> World -> Bool
canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
where ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeIndirect :: Int -> Int -> World -> Bool
canSeeIndirect i j w = case collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
of Just _ -> False
Nothing -> True
where ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeFire :: Point2 -> Point2 -> World -> Bool
canSeeFire p p' w = (not $ collidePointFireVision p p' $ wallsAlongLine p p' w)
canSeeFireVision :: Int -> Int -> World -> Bool
canSeeFireVision i j w = (not $ collidePointFireVision ipos jpos $ wallsAlongLine ipos jpos w)
where ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeFireVisionAny :: Int -> Int -> World -> Bool
canSeeFireVisionAny i j w = not $ and $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
$ zipWith collidePointFireVision ips jps
where icr = _creatures w IM.! i
jcr = _creatures w IM.! j
ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
canSeeFireVisionAll :: Int -> Int -> World -> Bool
canSeeFireVisionAll i j w = not $ or $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
$ zipWith collidePointFireVision ips jps
where icr = _creatures w IM.! i
jcr = _creatures w IM.! j
ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
-- looks for first collision of a point with walls
-- if found, returns wall
-- I'm sure there is a better way of doing this, one that propagates Nothing in a nice way
--wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
--wallsOnLine p1 p2 ws = hitWalls
-- where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
-- hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
wallNormal :: Wall -> Point2
wallNormal wl = normalizeV . vNormal $ a -.- b
where (a:b:_) = _wlLine wl
where
(a:b:_) = _wlLine wl
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
wallsOnLine p1 p2 ws = hitWalls
where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
where
hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
hitWalls = filter (isJust . hitPoint) (IM.elems ws)
wallOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Wall
wallOnLine p1 p2 ws
= listToMaybe $ sortBy f hitWalls
where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
--where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
where
hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
hitWalls = filter (isJust . hitPoint) (IM.elems ws)
f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2)))
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall]
wallsOnCirc p r wls = IM.elems $ IM.filter f wls
where f wl = circOnSeg (_wlLine wl !! 0) (_wlLine wl !! 1) p r
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where (x,y) = zoneOfPoint p
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
-- possible BUG, was associated with thingsHitLongLine
-- assumes _wallsZone is correct level generation
-- there is certainly a problem somewhere here: it may be in the zoning, or
-- within this function
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wallsAlongLine #-}
wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
kps = zoneOfLineIntMap a b
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
f wl = circOnSeg (_wlLine wl !! 0) (_wlLine wl !! 1) p r
wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
{-# INLINE wallsNearZone' #-}
wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
wallsAlongCirc p r w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
where f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
allWalls :: World -> IM.IntMap Wall
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w
@@ -239,279 +111,125 @@ creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
zoneSize :: Float
zoneSize = 50
--zoneSize = 100
floorHun :: Float -> Int
floorHun x = floor $ x / zoneSize
zoneOfPoint :: Point2 -> (Int,Int)
zoneOfPoint (x,y) = (floorHun x, floorHun y)
zoneNearPoint :: Point2 -> [(Int,Int)]
zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where x = floorHun x'
y = floorHun y'
zoneAroundPoint :: Point2 -> [(Int,Int)]
zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
where x = floorHun x'
y = floorHun y'
zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs
where x = floorHun x'
y = floorHun y'
xs = IS.fromAscList [x-i..x+i]
ys = IS.fromAscList [y-i..y+i]
-- the laser seemed to be occasionally missing creatures,
-- if this reoccurs, maybe change
-- divide line factor from 2 to 1.5
bres :: Point2 -> Point2 -> [(Int,Int)]
bres a b = digitalLine (zoneOfPoint a) (zoneOfPoint b)
bresx :: Point2 -> Point2 -> [(Int,Int)]
bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLineIntMap #-}
zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
-- $ digitalLine (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n))
-- where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]]
-- n = zoneSize * 0.5
expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
{-# INLINE expandLine #-}
expandLine xs = IM.map expandSet
$ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
where im = IM.fromListWith IS.union $ map (\(a,b)->(a,IS.singleton b)) xs
expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
--expandSet s = s
where mk = IS.findMax s
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
-- looking at this again, I am not convinced it deals correctly with the
-- rotation of the world
zoneOfScreen :: World -> [(Int,Int)]
zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
where (x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling $ wh / (_cameraZoom w * zoneSize)
wh = max (getWindowX w) (getWindowY w)
zoneOfDoubleScreen :: World -> [(Int,Int)]
zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
where (x,y) = zoneOfPoint $ _cameraCenter w
n = (ceiling $ wh / (_cameraZoom w * zoneSize)) * 2
wh = max (getWindowX w) (getWindowY w)
zoneOfSight :: World -> [(Int,Int)]
zoneOfSight w = [(a,b) | a <- [minimum xs .. maximum xs]
, b <- [minimum ys .. maximum ys]
]
where (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w]
screenPolygon :: World -> [Point2]
screenPolygon w = [tr,tl,bl,br]
where scRot = rotateV (_cameraRot w)
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w)
tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w)
br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
where f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y
ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
ixNZ z p = lookLookups (zoneNearPoint p) z
lookLookup :: Int -> Int -> (IM.IntMap (IM.IntMap a)) -> Maybe a
lookLookup i j z = case IM.lookup i z of
Just z' -> IM.lookup j z'
Nothing -> Nothing
lookLookups :: [(Int,Int)] -> (IM.IntMap (IM.IntMap a)) -> [a]
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
-- looks for first collision of a point with walls
-- if found, gives point and reflection velocity
collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWalls p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,)
(reflectIn (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
) (intersectSegSeg' p1 p2 x y)
) . _wlLine
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
-- looks for if a point collides with walls
collidePointWallsSimple :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWallsSimple p1 p2 = any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWalkable p1 p2 ws = any (isJust
. ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) unwalkableWalls
where unwalkableWalls = IM.filter (fromMaybe True . (^? doorPathable)) ws
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) ws
) ++ [p2]
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
{-# INLINE collidePointIndirect #-}
collidePointIndirect p1 p2 ws = listToMaybe
$ sortOn (dist p1)
$ IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) notWindows
where
notWindows = IM.filter (not . _wlIsSeeThrough) ws
collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) notWindows
where notWindows = IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))
) ws
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointFireVision p1 p2 ws = any ( isJust
. ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
)
$ IM.filter notBlockWindow ws
where notBlockWindow wl = case wl ^? blHP of
Just _ -> not $ _wlIsSeeThrough wl
Nothing -> True
{- | Expands a line out to a given thickness. -}
lineGeom :: Float -> Point2 -> Point2 -> [Point2]
lineGeom t x y
| x == y = []
| otherwise = [x +.+ n x y, x -.- n x y, y +.+ n x y, y -.- n x y]
where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
wedgeGeom :: Float -> Point2 -> Point2 -> [Point2]
where
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
{- | A triangular wedge thick at the first point and
- tapering off to the second. -}
wedgeGeom
:: Float -- Thickness
-> Point2
-> Point2
-> [Point2]
wedgeGeom t x y
| x == y = []
| otherwise = [x +.+ n x y, x -.- n x y, y]
where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
where
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
wedgeOfThickness t x y
| x == y = blank
| otherwise = pictures [uncurry translate x $ circleSolid (0.5*t)
,polygon [x +.+ n x y, x -.- n x y, y]
]
where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
insertInZoneWith :: Int -> Int -> (a -> a -> a) -> a -> IM.IntMap (IM.IntMap a)
insertInZoneWith
:: Int -- ^ First Key
-> Int -- ^ Second Key
-> (a -> a -> a) -- ^ Combining function
-> a -- ^ Value to insert
-> IM.IntMap (IM.IntMap a)
-> IM.IntMap (IM.IntMap a)
insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj
where-- f :: IM.IntMap a -> IM.IntMap a -> IM.IntMap a
where
f _ = IM.insertWith fun y obj
insertIMInZone :: Int -> Int -> Int -> a -> IM.IntMap (IM.IntMap (IM.IntMap a))
{- | I believe this overwrites the value if it already exists, but not sure. -}
insertIMInZone
:: Int -- ^ First key
-> Int -- ^ Second key
-> Int -- ^ Third key
-> a -- ^ Item to insert
-> IM.IntMap (IM.IntMap (IM.IntMap a))
-> IM.IntMap (IM.IntMap (IM.IntMap a))
insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton obid obj
where f _ = IM.insertWith g y $ IM.singleton obid obj
where
f _ = IM.insertWith g y $ IM.singleton obid obj
g _ = IM.insert obid obj
adjustIMZone :: (a -> a) -> Int -> Int -> Int -> IM.IntMap (IM.IntMap (IM.IntMap a))
adjustIMZone
:: (a -> a) -- ^ Update function
-> Int -- ^ First key
-> Int -- ^ Second key
-> Int -- ^ Third key
-> IM.IntMap (IM.IntMap (IM.IntMap a))
adjustIMZone f x y n m = IM.adjust f' x m
where f' = IM.adjust f'' y
-> IM.IntMap (IM.IntMap (IM.IntMap a))
adjustIMZone f x y n = IM.adjust f' x
where
f' = IM.adjust f'' y
f'' = IM.adjust f n
{- | Find a key value one higher than any key in the map, or zero if the map is
- empty -}
newKey :: IM.IntMap a -> Int
newKey m = case IM.lookupMax m of
Just (n,_) -> n+1
Nothing -> 0
newKey = maybe 0 ((+ 1) . fst) . IM.lookupMax
{- | Finds unused projectile key. -}
newProjectileKey :: World -> Int
newProjectileKey w = case IM.lookupMax (_projectiles w) of
Just (n,_) -> n+1
Nothing -> 0
newProjectileKey = newKey . _projectiles
{- | Finds unused creature key. -}
newCrKey :: World -> Int
newCrKey w = case IM.lookupMax (_creatures w) of
Just (n,_) -> n+1
Nothing -> 0
newCrKey = newKey . _creatures
{- | Insert an element with some new key. -}
insertNewKey :: a -> IM.IntMap a -> IM.IntMap a
insertNewKey x m = case IM.lookupMax m of
Nothing -> IM.singleton 0 x
Just (k,_) -> IM.insert (k+1) x m
{- | TODO: determine precisely what this does. -}
reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
reflectPointCreature p1 p2 cr =
case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
reflectPointCreature p1 p2 cr = case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
Nothing -> Nothing
Just p3 -> Just ( p1
Just p3 -> Just
( p1
, errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr)
--, errorNormalizeV 36 $
-- ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
-- -.- _crOldPos cr
, _crID cr)
{- | TODO: determine precisely what this does. -}
reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
reflectPointCreatures p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(reflectPointCreature p1 p2) cs
where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
reflectCircCreature :: Float -> Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
reflectCircCreature rad p1 p2 cr =
case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of
reflectPointCreatures p1 p2 cs
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe (reflectPointCreature p1 p2) cs
where
f (a,_,_) = magV (a -.- p1)
{- | TODO: determine precisely what this does. -}
reflectCircCreature
:: Float -- ^ Radius
-> Point2 -- ^ Start point
-> Point2 -- ^ End point
-> Creature
-> Maybe (Point2, Point2, Int)
reflectCircCreature rad p1 p2 cr = case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of
Nothing -> Nothing
Just p3 -> Just ( p1
Just p3 -> Just
( p1
, errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr)
, _crID cr
)
reflectCircCreatures :: Float -> Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
reflectCircCreatures rad p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(reflectCircCreature rad p1 p2) cs
where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
-- collides a point with forcefields
{- | TODO: determine precisely what this does. -}
reflectCircCreatures
:: Float -- ^ Radius
-> Point2 -- ^ Start point
-> Point2 -- ^ End point
-> IM.IntMap Creature
-> Maybe (Point2,Point2,Int)
reflectCircCreatures rad p1 p2 cs
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe (reflectCircCreature rad p1 p2) cs
where
f (a,_,_) = magV (a -.- p1)
-- | collides a point with forcefields
-- if found, returns point of collision, deflection if required, and the id
collidePointFFs = undefined
collidePointFF = undefined
@@ -531,36 +249,27 @@ collidePointFF = undefined
-- f p = (p, (ref, _ffID ff))
--
-- looks for first collision of a point with walls
-- if found, gives point and reflection velocity, reflection damped in normal
collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWalls' p1 p2 ws
= listToMaybe $ sortBy f $ IM.elems
$ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
) . _wlLine
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
-- looks for first collision of a circle with walls
-- if found, gives point and reflection velocity, reflection damped in normal
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls' p1 p2 rad ws
= listToMaybe $ sortBy f $ IM.elems
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1))
(( \(x:y:_) -> fmap
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
) . shiftByRad . _wlLine
)
. shiftByRad . _wlLine
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
shiftByRad (a:b:_) = map ((+.+) (rad *.* normalizeV (vNormal (a -.- b))))
[a +.+ rad *.* (normalizeV (a -.-b))
,b +.+ rad *.* (normalizeV (b -.-a))
where
f (a,_) = magV (p1 -.- a)
shiftByRad (a:b:_) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
[a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
]
-- this shifts the wall out, and for outer corners extends the wall
-- not sure what this does for inner corners, hopefully won't cause a problem
@@ -568,129 +277,134 @@ collideCircWalls' p1 p2 rad ws
-- unfortunately, doesn't allow for collisions when the circle spawns on the
-- wall
-- looks for first collision of a point with walls
-- if found, gives point and normal of wall
-- | Looks for first collision of a point with walls.
-- If found, gives point and normal of wall.
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,) ( vNormal $ x -.- y ))
(intersectSegSeg' p1 p2 x y)
) . _wlLine
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
collidePointWallsNorm p1 p2 ws
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe (( \(x:y:_) -> intersectSegSeg' p1 p2 x y <&> (, vNormal $ x -.- y ) )
. _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
{- | Looks for first collision of a point with walls.
If found, gives point and colour of wall.
-}
collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color)
collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
( (\(m, c) -> fmap (flip (,) c) m)
. (\w -> (intersectSegSeg' p1 p2
(_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
collidePointWallsCol p1 p2 ws
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe ( (\(m, c) -> m <&> (, c))
. (\w -> (intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))) ws
where
f (a,_) = magV (p1 -.- a)
{- | Looks for first collision of a point with walls.
If found, gives point, and normal and colour of wall.
-}
collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
collidePointWallsNormCol p1 p2 ws
= listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws
where f (a,_,_) (b,_,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
ls w = let (x:y:_) = _wlLine w
in (intersectSegSeg' p1 p2 x y, vNormal (x -.- y), _wlColor w)
m w = let (a1,a2,a3) = ls w
in fmap (\a4 -> (a4,a2,a3)) a1
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe m ws
where
f (a,_,_) = magV $ p1 -.- a
m w =
let (x:y:_) = _wlLine w
in intersectSegSeg' p1 p2 x y <&> (, vNormal (x -.- y), _wlColor w)
-- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc' p1 p2 (_crRad x) (_crPos x)
)
(_creatures w)
where csnd (_,a) (_,b) = compare a b
collidePointCreatures p1 p2 w
= fmap fst
. listToMaybe
. sortOn snd
. IM.toList
. IM.mapMaybe (\x -> collidePointCirc' p1 p2 (_crRad x) (_crPos x))
$_creatures w
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
--fixed amount, thus collides a moving circle with creaures.
collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc' p1 p2 (rad + _crRad x) (_crPos x)
)
(_creatures w)
where csnd (_,a) (_,b) = compare a b
-- | Returns the first creature, if any, that a point intersects with, gives point
collideCircCreatures p1 p2 rad w
= fmap fst
. listToMaybe
. sortOn snd
. IM.toList
. IM.mapMaybe (\x -> collidePointCirc' p1 p2 (rad + _crRad x) (_crPos x))
$ _creatures w
-- | Returns the first creature id, if any, that a point intersects with, gives point
--in creature on line.
collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int)
collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
)
(_creatures w)
collidePointCrsPoint p1 p2 w
= fmap f
. listToMaybe
. sortOn (snd . snd)
. IM.toList
. IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
$ _creatures w
where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
{- | Finds the first creature hit on a line.
Maybe evaluates the creature id and hit point. -}
collideCircCrsPoint :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int)
collideCircCrsPoint p1 p2 rad w
= fmap f
. listToMaybe
. sortBy (csndsnd)
. sortOn (snd . snd)
. IM.toList
$ IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
)
(_creatures w)
. IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x))
$ _creatures w
where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
-- | Makes a creature not hittable.
collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
collidePointCrsWithoutPoint cid p1 p2 w
= fmap f
. listToMaybe
. sortBy (csndsnd)
. sortOn (snd . snd)
. IM.toList
$ IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
)
(IM.delete cid $ _creatures w)
. IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
. IM.delete cid
$ _creatures w
where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
{- | Test if a circle collides with any wall. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad)
$ fmap _wlLine $ IM.elems $ wallsNearPoint p w
crsNearLine :: Float -> [Point2] -> World -> Bool
crsNearLine d (p1:p2:_) w = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c))
$ IM.filter (\cr -> _crMass cr > 4) $ _creatures w
circOnSomeWall p rad w
= any (\(x:y:_) -> circOnSeg x y p rad)
. fmap _wlLine
. IM.elems
$ wallsNearPoint p w
{- | Test whether there is a creature of weight 4 or greater near a line. -}
isHeavyCrNearLine :: Float -> [Point2] -> World -> Bool
isHeavyCrNearLine d (p1:p2:_) w
= any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c))
. IM.filter (\cr -> _crMass cr > 4)
$ _creatures w
{- | Adds the distance to the creature radius, tests whether the center is in
the circle of this size centered at the point -}
crsNearPoint :: Float -> Point2 -> World -> Bool
crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w)
{- | Produce an unordered list of creatures on a line. -}
crsOnLine :: Point2 -> Point2 -> World -> [Creature]
crsOnLine p1 p2 w
= IM.elems
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
$ _creatures w
{- | Produce an unordered list of creatures on a wide line. -}
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
crsOnThickLine thickness p1 p2 w
= IM.elems
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
$ _creatures w
{- | Find 'Maybe' the closest creature to a point, within a circle.
-}
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
nearestCrInRad p r w
= let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
nearestCrInRad p r w =
let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
sortedCrs = sortOn (dist p . _crPos) $ IM.elems crs
in listToMaybe sortedCrs
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape.
-}
nearestCrInTri
@@ -698,90 +412,72 @@ nearestCrInTri
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInTri p dir x w
= let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
nearestCrInTri p dir x w =
let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
sortedCrs = sortOn (dist p . _crPos) $ IM.elems crs
in listToMaybe sortedCrs
where
tri = [p
tri =
[p
,p +.+ rotateV (dir-pi/4) (x,0)
,p +.+ rotateV (dir+pi/4) (x,0)
]
{- | Find 'Maybe' the closes creature in front of a point in a given direction for
a given distance.
The shapes within which creatures are searched are a triangle then rectangle.
-}
The shapes within which creatures are searched are a triangle then rectangle. -}
nearestCrInFront
:: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInFront p dir x w
= let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
nearestCrInFront p dir x w =
let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
sortedCrs = sortOn (dist p . _crPos) $ IM.elems crs
in listToMaybe sortedCrs
where
rec = [p
,pR
,pR1
,pL1
,pL
]
rec = [p, pR, pR1, pL1, pL ]
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
pR1 = pR +.+ rotateV dir (x/2,0)
pL1 = pL +.+ rotateV dir (x/2,0)
{- | Test whether a creature is in a polygon.
-}
{- | Test whether a creature is in a polygon. -}
crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
{- | Transform coordinates from world position to normalised screen coordinates.
-}
{- | Transform coordinates from world position to normalised screen coordinates. -}
worldPosToScreen :: World -> Point2 -> Point2
worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
where
doTranslate p = p -.- _cameraCenter w
doZoom p = _cameraZoom w *.* p
doRotate p = rotateV (0 - _cameraRot w) p
doWindowScale (x,y) = ( x * 2 / getWindowX w
doRotate p = rotateV (negate $ _cameraRot w) p
doWindowScale (x,y) =
( x * 2 / getWindowX w
, y * 2 / getWindowY w
)
{- | Transform coordinates from the map position to normalised screen
coordinates.
-}
coordinates. -}
cartePosToScreen :: World -> Point2 -> Point2
cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
where
doTranslate p = p -.- _carteCenter w
doZoom p = _carteZoom w *.* p
doRotate p = rotateV (0 - _carteRot w) p
doWindowScale (x,y) = ( x * 2 / getWindowX w
doRotate p = rotateV (negate $ _carteRot w) p
doWindowScale (x,y) =
( x * 2 / getWindowX w
, y * 2 / getWindowY w
)
{- | The mouse position in world coordinates.
-}
{- | The mouse position in world coordinates. -}
mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
{- | The mouse position in map coordinates
-}
{- | The mouse position in map coordinates -}
mouseCartePos :: World -> Point2
mouseCartePos w = _carteCenter w +.+ (1/_carteZoom w) *.* rotateV (_carteRot w) (_mousePos w)
{- | Create a logistic function given three parameters.
-}
{- | Create a logistic function given three parameters. -}
logistic :: Float -> Float -> Float -> (Float -> Float)
logistic x0 l k x = l / (1 + exp (k*(x0 - x)))
{- | given a target and a start point, shift toward the end point by a given
amount.
If close enough, end up on the end point
-}
If close enough, end up on the end point -}
mvPointTowardAtSpeed
:: Float -- ^ Speed.
-> Point2 -- ^ End point.
@@ -790,14 +486,12 @@ mvPointTowardAtSpeed
mvPointTowardAtSpeed speed !ep !p
| dist p ep < speed = ep
| otherwise = p +.+ speed *.* normalizeV (ep -.- p)
{- | given a target and a start point, shift toward the end point by 1.
If close enough, end up on the end point
-}
If close enough, end up on the end point -}
mvPointToward
:: Point2 -- ^ End point.
-> Point2 -- ^ Start point.
-> Point2
mvPointToward !ep !p | dist p ep < 1 = ep
mvPointToward !ep !p
| dist p ep < 1 = ep
| otherwise = p +.+ normalizeV (ep -.- p)
src/Dodge/Base/Collide.hs
+211
View File
@@ -0,0 +1,211 @@
{-# LANGUAGE TupleSections #-}
{- | Basic collision detection for a moving point -}
module Dodge.Base.Collide
where
import Dodge.Data
import Dodge.Base.Zone
import Geometry
import Data.List
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-}
hasLOS p1 p2 w = (not $ pointHitsWalls p1 p2 nearbyWalls)
where
nearbyWalls = wallsAlongLine p1 p2 w
-- | looks for first collision of a point with walls
-- if found, gives point and reflection velocity
reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
reflectPointWalls p1 p2 ws
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe
(( \(x:y:_) ->
fmap ( (, reflectIn (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
)
. _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
-- | Looks for first collision of a point with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
reflectPointWallsDamped
:: Float -- ^ Damping factor, probably should be in (0,1)
-> Point2
-> Point2
-> IM.IntMap Wall
-> Maybe (Point2,Point2)
reflectPointWallsDamped dfact p1 p2 ws
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe
(( \(x:y:_) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y))))
(intersectSegSeg' p1 p2 x y))
. _wlLine
) ws
where
f (a,_) = magV (p1 -.- a)
-- | Test if a point collides with walls
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
pointHitsWalls p1 p2
= any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine
-- | Test if there something blocking a walk
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWalkable p1 p2 ws
= any (isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
furthestPointWalkable p1 p2 ws
= fromMaybe p2
. listToMaybe
. sortOn (dist p1)
. IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
{-# INLINE collidePointIndirect #-}
collidePointIndirect p1 p2 ws
= listToMaybe
. sortOn (dist p1)
. IM.elems
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
$ IM.filter (not . _wlIsSeeThrough) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
collidePointFire p1 p2 ws
= listToMaybe
. sortOn (dist p1)
. IM.elems
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine )
$ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointFireVision p1 p2 ws
= any ( isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
$ IM.filter notBlockWindow ws
where
notBlockWindow wl = case wl ^? blHP of
Just _ -> not $ _wlIsSeeThrough wl
Nothing -> True
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w of
Just _ -> False
Nothing -> True
isWalkable :: Point2 -> Point2 -> World -> Bool
isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls
where
nearbyWalls = wallsAlongLine p1 p2 w
canSee :: Int -> Int -> World -> Bool
canSee i j w = hasLOS p1 p2 w
where
p1 = _crPos (_creatures w IM.! i)
p2 = _crPos (_creatures w IM.! j)
nearbyWalls = wallsAlongLine p1 p2 w
canSeePoint :: Int -> Point2 -> World -> Bool
canSeePoint i p w = hasLOS p1 p w
where
nearbyWalls = wallsAlongLine p1 p w
p1 = _crPos (_creatures w IM.! i)
pathToPointFireable :: Int -> Point2 -> World -> Bool
pathToPointFireable i p w
= not
. pointHitsWalls (_crPos (_creatures w IM.! i)) p
$ IM.filter (not . isJust . \wl -> wl ^? blHP) $ wallsAlongLine p1 p w
where
p1 = _crPos (_creatures w IM.! i)
canSeePointAll :: Int -> Point2 -> World -> Bool
canSeePointAll i targPos w
= and
$ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
where
cr = _creatures w IM.! i
cpos = _crPos cr
radius = _crRad cr
canSeeAny :: Int -> Int -> World -> Bool
canSeeAny fromID toID w
= or
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
where
cr = _creatures w IM.! toID
cpos = _crPos cr
radius = _crRad cr
canSeeAll :: Int -> Int -> World -> Bool
canSeeAll fromID toID w
= and
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
where
cr = _creatures w IM.! toID
cpos = _crPos cr
radius = _crRad cr
canWalk :: Int -> Int -> World -> Bool
canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
where
ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeIndirect :: Int -> Int -> World -> Bool
canSeeIndirect i j w = not . isJust . collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
where
ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeFire :: Point2 -> Point2 -> World -> Bool
canSeeFire p p' w = not $ collidePointFireVision p p' $ wallsAlongLine p p' w
canSeeFireVision :: Int -> Int -> World -> Bool
canSeeFireVision i j w = canSeeFire ipos jpos w
where
ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
{- | Test whether both of the outside lines between two creatures are blocked -}
canSeeFireVisionAny :: Int -> Int -> World -> Bool
canSeeFireVisionAny i j w
= not
$ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj)
(wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
&& collidePointFireVision (ipos -.- ni) (jpos -.- nj)
(wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
where
icr = _creatures w IM.! i
jcr = _creatures w IM.! j
ipos = _crPos icr
jpos = _crPos jcr
n = normalizeV $ vNormal $ ipos -.- jpos
ni = _crRad icr *.* n
nj = _crRad jcr *.* n
{- | Test whether either of the outside lines between two creatures are blocked -}
canSeeFireVisionAll :: Int -> Int -> World -> Bool
canSeeFireVisionAll i j w
= not
$ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj)
(wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
|| collidePointFireVision (ipos -.- ni) (jpos -.- nj)
(wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
where
icr = _creatures w IM.! i
jcr = _creatures w IM.! j
ipos = _crPos icr
jpos = _crPos jcr
n = normalizeV $ vNormal $ ipos -.- jpos
ni = _crRad icr *.* n
nj = _crRad jcr *.* n
src/Dodge/Base/Window.hs
+24
View File
@@ -0,0 +1,24 @@
{- | Getting the window size geometry. -}
module Dodge.Base.Window
where
import Dodge.Data
import Dodge.Config.Data
import Geometry
screenPolygon :: World -> [Point2]
screenPolygon w = [tr,tl,bl,br]
where
scRot = rotateV (_cameraRot w)
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w)
tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w)
br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
halfWidth,halfHeight :: World -> Float
halfWidth w = getWindowX w / 2
halfHeight w = getWindowY w / 2
getWindowX = _windowX . _config
getWindowY = _windowY . _config
src/Dodge/Base/Zone.hs
+172
View File
@@ -0,0 +1,172 @@
{- | Deals with the specific implementations of zoning for Dodge.
- These are not yet fixed down. -}
module Dodge.Base.Zone
where
import Dodge.Data
import Dodge.Base.Window
import Geometry
import Data.Maybe
import Data.List
import Data.Bifunctor
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
zoneSize :: Float
zoneSize = 50
--zoneSize = 100
floorHun :: Float -> Int
floorHun x = floor $ x / zoneSize
zoneOfPoint :: Point2 -> (Int,Int)
zoneOfPoint (x,y) = (floorHun x, floorHun y)
zoneNearPoint :: Point2 -> [(Int,Int)]
zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where
x = floorHun x'
y = floorHun y'
zoneAroundPoint :: Point2 -> [(Int,Int)]
zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
where
x = floorHun x'
y = floorHun y'
zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs
where
x = floorHun x'
y = floorHun y'
xs = IS.fromAscList [x-i..x+i]
ys = IS.fromAscList [y-i..y+i]
-- the laser seemed to be occasionally missing creatures,
-- if this reoccurs, maybe change
-- divide line factor from 2 to 1.5
bres :: Point2 -> Point2 -> [(Int,Int)]
bres a b = digitalLine (zoneOfPoint a) (zoneOfPoint b)
bresx :: Point2 -> Point2 -> [(Int,Int)]
bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
where
(x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (aa,ab) (ba,bb)
= nub
. concatMap f
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
where
f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLineIntMap #-}
zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where
(x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
{-# INLINE expandLine #-}
expandLine xs = IM.map expandSet
$ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
where
im = IM.fromListWith IS.union $ map (second IS.singleton) xs
-- the second was suggested by hlint, but it increases laziness, so might
-- not be ideal
expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
where
mk = IS.findMax s
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
-- looking at this again, I am not convinced it deals correctly with the
-- rotation of the world
zoneOfScreen :: World -> [(Int,Int)]
zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
where
(x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling $ wh / (_cameraZoom w * zoneSize)
wh = max (getWindowX w) (getWindowY w)
zoneOfDoubleScreen :: World -> [(Int,Int)]
zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
where
(x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
wh = max (getWindowX w) (getWindowY w)
zoneOfSight :: World -> [(Int,Int)]
zoneOfSight w =
[(a,b)
| a <- [minimum xs .. maximum xs]
, b <- [minimum ys .. maximum ys]
]
where
(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w]
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
where
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y
ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
ixNZ z p = lookLookups (zoneNearPoint p) z
lookLookup :: Int -> Int -> IM.IntMap (IM.IntMap a) -> Maybe a
lookLookup i j z = case IM.lookup i z of
Just z' -> IM.lookup j z'
Nothing -> Nothing
lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
-- possible BUG, was associated with thingsHitLongLine
-- assumes _wallsZone is correct level generation
-- there is certainly a problem somewhere here: it may be in the zoning, or
-- within this function
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wallsAlongLine #-}
wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
kps = zoneOfLineIntMap a b
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
{-# INLINE wallsNearZone' #-}
wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
wallsAlongCirc p r w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
where f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where
(x,y) = zoneOfPoint p
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
src/Dodge/Creature.hs
+16 -84
View File
@@ -13,8 +13,10 @@ import Dodge.WorldEvent.Cloud
import Dodge.Creature.YourControl
import Dodge.Creature.Inanimate
import Dodge.Creature.State
import Dodge.Creature.Picture
import Dodge.Item
import Dodge.Picture.Layer
import Dodge.Creature.Picture
import Picture
import Geometry
@@ -37,15 +39,12 @@ import qualified Data.Map as M
import Foreign.ForeignPtr
import Control.Concurrent
colouredEnemy col = pictures [color col $ circleSolid 10, circLine 10]
spawnerCrit :: Creature
spawnerCrit = defaultCreature
{ _crUpdate = stateUpdate $ spawnerAI chaseCrit
, _crHP = 300
, _crPict = basicCrPict blue
, _crState = defaultState {_goals = [[WaitFor 0]]
}
, _crState = defaultState {_goals = [[WaitFor 0]] }
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
smallChaseCrit :: Creature
@@ -54,8 +53,10 @@ smallChaseCrit = defaultCreature
, _crHP = 1
, _crRad = 4
, _crPict = basicCrPict green
, _crState = defaultState {_goals = [[Wait]]
,_faction = ChaseCritters}
, _crState = defaultState
{_goals = [[Wait]]
,_faction = ChaseCritters
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4
}
@@ -64,8 +65,10 @@ chaseCrit = defaultCreature
{ _crUpdate = stateUpdate chaseAI
, _crHP = 300
, _crPict = basicCrPict green
, _crState = defaultState {_goals = [[Wait]]
,_faction = ChaseCritters}
, _crState = defaultState
{_goals = [[Wait]]
,_faction = ChaseCritters
}
, _crInv = IM.empty
}
armourChaseCrit :: Creature
@@ -142,40 +145,17 @@ pistolCrit = defaultCreature
autoCrit :: Creature
autoCrit = defaultCreature
{ _crPict = basicCrPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate basicShooterAI
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
--, _crState = ShooterWait
, _crState = defaultState {_goals = [[InitGuard]]}
, _crHP = 300
}
addArmour :: Creature -> Creature
addArmour = over crInv insarmour
where insarmour xs = IM.insert i frontArmour xs
where i = newKey xs
equipOnTop :: (Creature -> Picture) -> Creature -> Picture
--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
equipOnTop f cr = pictures [onLayer CrLayer (f cr) , drawEquipment cr]
drawEquipment :: Creature -> Picture
drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
where f (i,it) = case it ^? itEquipPict of
Just g -> g cr i
_ -> blank
--drawEquipment :: Creature -> ([Picture],[Picture])
--drawEquipment cr = (map fst p1, map fst p2)
-- where f (k,it) = join $ (it ^? itEquipPict) <*> (pure cr) <*> (pure k)
-- picts = sortBy (compare `on` snd) $ mapMaybe f $ IM.toList (_crInv cr)
-- (p1,p2) = partition (\ x -> snd x < 0) picts
frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20
, color red $ circLine 20
]
where
insarmour xs = IM.insert (newKey xs) frontArmour xs
--packCrits :: (Int -> World -> World) -> [Int] -> [Creature]
--packCrits ai is = [(defaultCreature i)
@@ -220,27 +200,7 @@ frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20
-- , line [(-3,3),(3,-3)]
-- , line [(0,-3),(0,3)]
-- ]
flamerPict = const $ pictures [color (light $ light $ light $ dim blue) $ circleSolid 10, circLine 10]
goalPict cr = let r = _crRad cr in case _crState cr of
CrSt {_goals = gls ,_crDamage = crDam }
-- | crDam > _crHP cr -> color white $ circleSolid r
| otherwise -> case head gls of
[] -> sizeColEnemy r white
(MoveToFor p i:_) -> dGoals $ sizeColEnemy r green
(WaitFor x:_) -> dGoals $ sizeColEnemy r yellow
(FireAt p:_) -> dGoals $ sizeColEnemy r red
(Reload:_) -> dGoals $ sizeColEnemy r orange
(PathTo p:_) -> dGoals $ sizeColEnemy r cyan
(SubPathTo p i _:_) -> dGoals $ sizeColEnemy r blue
(Search i:_) -> dGoals $ sizeColEnemy r black
_ -> dGoals $ sizeColEnemy r magenta
where dGoals p = pictures [p, rotate (0 - _crDir cr) $ scale 0.1 0.1 $ color white $ text $ show gls]
_ -> sizeColEnemy r (light $ dim green)
{-
{- |
The creature you control.
ID 0.
-}
@@ -254,12 +214,12 @@ startCr = defaultCreature
, _crUpdate = stateUpdate yourControl
, _crRad = 10
, _crMass = 10
, _crHP = 1000000
, _crHP = 1000
, _crMaxHP = 1500
, _crInv = startInventory
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
}
{-
{- |
Items you start with.
-}
startInventory = IM.fromList (zip [0..20]
@@ -287,31 +247,3 @@ startInventory = IM.fromList (zip [0..20]
smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor
sizeEnemy col cr
| pdam > 200 = color red $ circleSolid $ _crRad cr
| pdam > 100 = color white $ circleSolid $ _crRad cr
| mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
| otherwise = pictures [color col $ circleSolid $ _crRad cr
, circLine $ _crRad cr ]
where
pdam = sum $ concatMap (map _dmAmount) $ _crPastDamage $ _crState cr
sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r]
basicCrPict :: Color -> Creature -> Picture
basicCrPict col cr = pictures [ onLayer CrLayer $ bluntScale naked , drawEquipment cr]
where
cdir = _crDir cr
naked | pdam > 200 = color red $ circleSolid $ _crRad cr
| pdam > 100 = color white $ circleSolid $ _crRad cr
| otherwise = pictures [color col' $ circleSolid $ _crRad cr, circLine $ _crRad cr]
pastDams = _crPastDamage $ _crState cr
pdam = sum $ concatMap (map _dmAmount) $ pastDams
col' = light . light . light $ light col
bluntDam :: Maybe Point2
bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
bluntScale = case fmap argV bluntDam of
Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
_ -> id
isBluntDam (Blunt {}) = True
isBluntDam _ = False
src/Dodge/Creature/Action.hs
+6 -6
View File
@@ -288,15 +288,15 @@ blinkAction
:: Int -- ^ Creature id
-> World
-> World
blinkAction n w = soundOnce teleSound
$ set (creatures . ix n . crPos) p3
$ blinkShockwave n p3
$ inverseShockwaveAt cp 40 2 2 2
w
blinkAction n w
= soundOnce teleSound
. set (creatures . ix n . crPos) p3
. blinkShockwave n p3
$ inverseShockwaveAt cp 40 2 2 2 w
where
p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
cp = _crPos $ _creatures w IM.! n
p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w
p2 = reflectPointWalls cp p1 $ wallsAlongLine cp p1 w
r = 1.5 * _crRad (_creatures w IM.! n)
p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
src/Dodge/Creature/Picture.hs
+53
View File
@@ -0,0 +1,53 @@
{- |
Drawing of creatures.
Takes into account damage etc. -}
module Dodge.Creature.Picture
( basicCrPict
, circLine
) where
import Dodge.Data
import Dodge.Picture.Layer
import Picture
import Geometry
import Control.Lens
import Data.List
import qualified Data.IntMap.Strict as IM
basicCrPict
:: Color -- ^ Creature color
-> Creature
-> Picture
basicCrPict col cr = pictures [ onLayer CrLayer . piercingMod $ bluntScale naked , drawEquipment cr]
where
cdir = _crDir cr
naked
| pdam > 200 = color red $ circleSolid $ _crRad cr
| pdam > 100 = color white $ circleSolid $ _crRad cr
| otherwise = pictures [color col' $ circleSolid $ _crRad cr, circLine $ _crRad cr]
pastDams = _crPastDamage $ _crState cr
pdam = sum $ concatMap (map _dmAmount) $ pastDams
col' = light . light . light $ light col
bluntDam :: Maybe Point2
bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
bluntScale = case fmap argV bluntDam of
Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
_ -> id
isBluntDam (Blunt {}) = True
isBluntDam _ = False
piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
isPiercingDam (Piercing {}) = True
isPiercingDam _ = False
piercingMod = case fmap argV piercingDam of
Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
_ -> id
drawEquipment
:: Creature
-> Picture
drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
where
f (i,it) = case it ^? itEquipPict of
Just g -> g cr i
_ -> blank
circLine x = line [(0,0),(x,0)]
src/Dodge/Data.hs
+2 -1
View File
@@ -416,7 +416,8 @@ data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
data Wall
= Wall
{ _wlLine :: [Point2] , _wlID :: Int
{ _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
src/Dodge/Item/Weapon/UseEffect.hs
+1 -1
View File
@@ -177,7 +177,7 @@ updateTractor colID time i w
q = _pjVel pj
p1 = _pjPos pj
p' = _pjStartPos pj
p2 = maybe p' fst $ collidePointWalls p1 p' $ wallsNearPoint p' w
p2 = maybe p' fst $ reflectPointWalls p1 p' $ wallsNearPoint p' w
p4 = vNormal p5
p5 = errorNormalizeV 12 $ p2 -.- p1
p3 = p1 +.+ p4
src/Dodge/Picture.hs
+13 -3
View File
@@ -23,9 +23,19 @@ vvThickLine = lineOfThickness 6
-- shit this is ugly
lineOfThickness :: Float -> [Point2] -> Picture
lineOfThickness t = pictures . f
where f (x:y:ys)
where
f (x:y:ys)
| x == y = f (x:ys)
| otherwise
= polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
wedgeOfThickness t x y
| x == y = blank
| otherwise = pictures
[uncurry translate x $ circleSolid (0.5*t)
,polygon [x +.+ n x y, x -.- n x y, y]
]
where
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
src/Dodge/Picture/Layer.hs
+1 -1
View File
@@ -19,7 +19,7 @@ Lists are lexicographically ordered if input values are always less than 100.
Higher numbers will get placed on top of lower numbers.
-}
onLayerL :: [Int] -> Picture -> Picture
onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
onLayerL is = setDepth (1 - sum (zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
{- | For depth testing, set layer values.
-}
src/Dodge/Room/Airlock.hs
+2 -2
View File
@@ -23,7 +23,7 @@ airlockOneWay n = Room
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [PS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
,PS (0,75) 0 $ PutDoubleDoor col (cond) (0,0) (0,40)
,PS (0,75) 0 $ PutDoubleDoor col cond (0,0) (0,40)
,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True))
]
@@ -60,7 +60,7 @@ airlock0 n = Room
]
, _rmPS =
[PS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
,PS (0,80) 0 $ PutDoubleDoor col (cond) (1,0) (39,0)
,PS (0,80) 0 $ PutDoubleDoor col cond (1,0) (39,0)
,PS (35,50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
src/Dodge/Room/Boss.hs
+1 -1
View File
@@ -66,7 +66,7 @@ randomMediumRoom = takeOne
[ roomOctogon 300
, roomCross 180 300
, roomShuriken 200 300
, roomTwistCross 230 300 (0)
, roomTwistCross 230 300 0
]
roomCross
src/Dodge/Room/Corridor.hs
+1 -1
View File
@@ -21,7 +21,7 @@ corridor = Room
lnks =
[((20,70) ,0)
,((20,70), pi/6)
,((20,70), 0-pi/6)
,((20,70), negate $ pi/6)
,((20,10) ,pi)
]
corridorN :: Room
src/Dodge/Room/LongDoor.hs
+19 -16
View File
@@ -40,7 +40,7 @@ twinSlowDoorRoom drID w h x = Room
, _rmPS =
[ PS (0,h/2) 0 putLamp
, PS (25,5) 0 putLamp
, PS (negate $ 25,5) 0 putLamp
, PS (negate 25,5) 0 putLamp
, PS (0,0) 0 $ PutDoor col (not . cond) drL
, PS (0,0) 0 $ PutDoor col (not . cond) drR
, PS (0,h-5) pi $ PutButton $ makeButton col
@@ -57,7 +57,7 @@ twinSlowDoorRoom drID w h x = Room
[0..nDrp]
drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp]
nDrp = ceiling $ h
nDrp = ceiling h
cond w = or $ M.lookup (DoorNumOpen drID) (_worldState w)
col = dim $ dim $ bright red
@@ -82,31 +82,34 @@ slowDoorRoom = do
,( (x/2+50,5),0)
]
let n = 25
xs <- sequence $ replicate n $ state $ randomR (10,x-10)
ys <- sequence $ replicate n $ state $ randomR (h+20,y)
rs <- sequence $ replicate n $ state $ randomR (0,2*pi)
xs <- replicateM n $ state $ randomR (10,x-10)
ys <- replicateM n $ state $ randomR (h+20,y)
rs <- replicateM n $ state $ randomR (0,2*pi)
let ps = zip xs ys
xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> PS p r randC1) ps rs
lsources = [PS (x/2,30) 0 putLamp, PS (x/2,y-30) 0 putLamp]
let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
let pillarsa = []
let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
let cond x = (snd . fst) x > h + 40
let cond2 x = (snd . fst) x < h - 40
cond2 x = (snd . fst) x < h - 40
but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
-- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
]
fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
$ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
fmap connectRoom
(filterLinks cond =<<
changeLinkTo cond2
(set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRectAutoLinks x y
))
)
)
randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
src/Dodge/Room/Procedural.hs
+5 -3
View File
@@ -62,8 +62,10 @@ roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
makeGrid x nx y ny = nub $ concatMap doublePair
$ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
makeGrid x nx y ny
= nub
. concatMap doublePair
. concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
$ gridPoints x nx y ny
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
@@ -230,7 +232,7 @@ centerVaultRoom n w h d = do
nsDoors = rectNSWE (d + 20) (negate (d +20)) (-20) 20
weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20))
centerPoly = rectWdthHght (d - 20) (d - 20)
polys = centerPoly : nsDoors : weDoors : (take 4 $ iterate (map vNormal) northPoly)
polys = centerPoly : nsDoors : weDoors : take 4 (iterate (map vNormal) northPoly)
return $ Room
{ _rmPolys = polys
, _rmLinks =
src/Dodge/Update/Camera.hs
+1 -1
View File
@@ -165,7 +165,7 @@ farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (ve
tRays = rotF [(y, maxViewDistance) | y <- zs]
bRays = rotF [(y,-maxViewDistance) | y <- zs]
rotF = map (h . (+.+) cpos . rotateV (_cameraRot w))
zs = takeWhile (< maxViewDistance) [-maxViewDistance,0 - 0.8*maxViewDistance..]
zs = takeWhile (< maxViewDistance) [-maxViewDistance,negate $ 0.8*maxViewDistance..]
maxViewDistance = 800
src/Dodge/WorldEvent/Explosion.hs
+4 -5
View File
@@ -63,11 +63,11 @@ makeExplosionAt
:: Point2 -- ^ Position
-> World
-> World
makeExplosionAt p w = soundOncePos grenadeBang p
makeExplosionAt p w
= soundOncePos grenadeBang p
. addFlames
. explosionFlashAt p
$ makeShockwaveAt [] p 50 10 1 white
w
$ makeShockwaveAt [] p 50 10 1 white w
where
fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w
fPs' = replicateM 75 (randInCirc 15) & evalState $ _randGen w
@@ -79,6 +79,5 @@ makeExplosionAt p w = soundOncePos grenadeBang p
mF q v size time = makeFlameletTimed q v Nothing size time
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
addFlames w = foldr ($) w newFs
pushAgainstWalls q = maybe q (uncurry (+.+))
$ collidePointWalls p q $ wallsNearPoint q w
pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q $ wallsNearPoint q w
src/Dodge/WorldEvent/SpawnParticle.hs
+5 -4
View File
@@ -304,7 +304,7 @@ moveTeslaArc p d i w =
sID = newProjectileKey w
q1 = last $ init ps'
q2 = last ps'
hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
hitWall = reflectPointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
(d1,_) = randomR (-0.7,0.7) $ _randGen w
sv = maybe (q2 -.- q1) snd hitWall
@@ -362,7 +362,7 @@ crOrWallSensitive p dir wlAttract w =
. sortBy (compare `on` dist p)
$ mapMaybe
( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (+ dir)
@@ -385,11 +385,12 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
$ catMaybes [cr,wlp]
where
cr = E3x1 <$> nearestCrInFront p dir 100 w
wlp = fmap E3x2 $ listToMaybe
wlp = fmap E3x2
$ listToMaybe
$ sortBy (compare `on` dist p)
$ mapMaybe
( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (+) dir