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.Creature.Action
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.WorldEvent import Dodge.WorldEvent
import Dodge.Creature.Picture
import Geometry import Geometry
import Picture import Picture
@@ -18,18 +18,16 @@ import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query.SP import Data.Graph.Inductive.Query.SP
import qualified Data.ByteString as B 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.Set as S
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M import qualified Data.Map as M
import Control.Lens
import Foreign.ForeignPtr import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Concurrent import Control.Concurrent
import System.Random
import Foreign.ForeignPtr
factionIs :: Faction -> Creature -> Bool factionIs :: Faction -> Creature -> Bool
factionIs f c = (_faction $ _crState $ c) == f 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) (SetPosture pture:_) -> ((f,g), replaceAction [] $ set (crState . stance . posture) pture cr)
(MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) (MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr)
(MoveByFor p i:_) -> ((f,g'), replaceAction [MoveByFor p (i-1)] . 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) (wallsAlongLine cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) w)
-> ((f,g),replaceAction [] cr) -> ((f,g),replaceAction [] cr)
| otherwise -> ((tryUseItem cid . 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 (t,g') = randomR (fireRate+10,fireRate+15) g
retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400 retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400
where f p = fromMaybe (ypos +.+ p) $ fmap fst 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' = cpos +.+ 300 *.* (cpos -.- ypos)
retreatP'' = fromMaybe retreatP' $ fmap fst retreatP'' = fromMaybe retreatP' $ fmap fst
$ collidePointWalls ypos retreatP' $ reflectPointWalls ypos retreatP'
$ wallsAlongLine ypos retreatP' w $ wallsAlongLine ypos retreatP' w
retreatP = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs retreatP = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs
fireActions = [TurnToward yposoff, Fire, TurnTo ypos, WaitFor t 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) 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 #-} {-# 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.Data
import Dodge.Base.Zone
import Dodge.Base.Window
import Dodge.Base.Collide
import Dodge.Config.Data import Dodge.Config.Data
import Geometry import Geometry
import Picture import Picture
@@ -24,11 +36,13 @@ rightPad i x xs = take i $ xs ++ repeat x
midPad :: Int -> a -> [a] -> [a] -> [a] midPad :: Int -> a -> [a] -> [a] -> [a]
midPad i x xs ys = xs ++ replicate j x ++ ys 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 :: Int -> a -> [a] -> [a] -> [a]
midPadL i x xs ys = take j (xs ++ repeat x) ++ ys 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 :: (a -> Bool) -> [a] -> [a]
takeUntil f ps = case span (not . f) ps of 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))) 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 :: Wall -> Point2
wallNormal wl = normalizeV . vNormal $ a -.- b wallNormal wl = normalizeV . vNormal $ a -.- b
where (a:b:_) = _wlLine wl where
(a:b:_) = _wlLine wl
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
wallsOnLine p1 p2 ws = hitWalls wallsOnLine p1 p2 ws = hitWalls
where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1) where
hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws) 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 :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Wall
wallOnLine p1 p2 ws wallOnLine p1 p2 ws
= listToMaybe $ sortBy f hitWalls = listToMaybe $ sortBy f hitWalls
where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1) where
--where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1) hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws) hitWalls = filter (isJust . hitPoint) (IM.elems ws)
f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2))) f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2)))
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall] wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall]
wallsOnCirc p r wls = IM.elems $ IM.filter f wls 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 where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s)) f wl = circOnSeg (_wlLine wl !! 0) (_wlLine wl !! 1) p r
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
allWalls :: World -> IM.IntMap Wall allWalls :: World -> IM.IntMap Wall
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w 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 f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty _ -> 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 :: Float -> Point2 -> Point2 -> [Point2]
lineGeom t x y lineGeom t x y
| x == y = [] | x == y = []
| otherwise = [x +.+ n x y, x -.- n x y, y +.+ n x y, y -.- n 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)) where
n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
wedgeGeom :: Float -> Point2 -> Point2 -> [Point2] {- | A triangular wedge thick at the first point and
- tapering off to the second. -}
wedgeGeom
:: Float -- Thickness
-> Point2
-> Point2
-> [Point2]
wedgeGeom t x y wedgeGeom t x y
| x == y = [] | x == y = []
| otherwise = [x +.+ n x y, x -.- n x y, 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 insertInZoneWith
wedgeOfThickness t x y :: Int -- ^ First Key
| x == y = blank -> Int -- ^ Second Key
| otherwise = pictures [uncurry translate x $ circleSolid (0.5*t) -> (a -> a -> a) -- ^ Combining function
,polygon [x +.+ n x y, x -.- n x y, y] -> a -- ^ Value to insert
] -> IM.IntMap (IM.IntMap a)
where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
insertInZoneWith :: Int -> Int -> (a -> a -> a) -> a -> IM.IntMap (IM.IntMap a)
-> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj 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 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)) -> IM.IntMap (IM.IntMap (IM.IntMap a))
insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton obid obj 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 g _ = IM.insert obid obj
adjustIMZone
adjustIMZone :: (a -> a) -> Int -> Int -> Int -> IM.IntMap (IM.IntMap (IM.IntMap a)) :: (a -> a) -- ^ Update function
-> Int -- ^ First key
-> Int -- ^ Second key
-> Int -- ^ Third key
-> IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap (IM.IntMap (IM.IntMap a))
adjustIMZone f x y n m = IM.adjust f' x m -> IM.IntMap (IM.IntMap (IM.IntMap a))
where f' = IM.adjust f'' y adjustIMZone f x y n = IM.adjust f' x
where
f' = IM.adjust f'' y
f'' = IM.adjust f n 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 :: IM.IntMap a -> Int
newKey m = case IM.lookupMax m of newKey = maybe 0 ((+ 1) . fst) . IM.lookupMax
Just (n,_) -> n+1 {- | Finds unused projectile key. -}
Nothing -> 0
newProjectileKey :: World -> Int newProjectileKey :: World -> Int
newProjectileKey w = case IM.lookupMax (_projectiles w) of newProjectileKey = newKey . _projectiles
Just (n,_) -> n+1 {- | Finds unused creature key. -}
Nothing -> 0
newCrKey :: World -> Int newCrKey :: World -> Int
newCrKey w = case IM.lookupMax (_creatures w) of newCrKey = newKey . _creatures
Just (n,_) -> n+1 {- | Insert an element with some new key. -}
Nothing -> 0
insertNewKey :: a -> IM.IntMap a -> IM.IntMap a insertNewKey :: a -> IM.IntMap a -> IM.IntMap a
insertNewKey x m = case IM.lookupMax m of insertNewKey x m = case IM.lookupMax m of
Nothing -> IM.singleton 0 x Nothing -> IM.singleton 0 x
Just (k,_) -> IM.insert (k+1) x m Just (k,_) -> IM.insert (k+1) x m
{- | TODO: determine precisely what this does. -}
reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int) reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
reflectPointCreature p1 p2 cr = reflectPointCreature p1 p2 cr = case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
Nothing -> Nothing Nothing -> Nothing
Just p3 -> Just ( p1 Just p3 -> Just
( p1
, errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) , errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr) +.+ (_crPos cr -.- _crOldPos cr)
--, errorNormalizeV 36 $
-- ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
-- -.- _crOldPos cr
, _crID cr) , _crID cr)
{- | TODO: determine precisely what this does. -}
reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int) reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
reflectPointCreatures p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe reflectPointCreatures p1 p2 cs
(reflectPointCreature p1 p2) cs = listToMaybe
where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1)) . sortOn f
. IM.elems
$ IM.mapMaybe (reflectPointCreature p1 p2) cs
reflectCircCreature :: Float -> Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int) where
reflectCircCreature rad p1 p2 cr = f (a,_,_) = magV (a -.- p1)
case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of {- | 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 Nothing -> Nothing
Just p3 -> Just ( p1 Just p3 -> Just
( p1
, errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) , errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr) +.+ (_crPos cr -.- _crOldPos cr)
, _crID cr , _crID cr
) )
{- | TODO: determine precisely what this does. -}
reflectCircCreatures :: Float -> Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int) reflectCircCreatures
reflectCircCreatures rad p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe :: Float -- ^ Radius
(reflectCircCreature rad p1 p2) cs -> Point2 -- ^ Start point
where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1)) -> Point2 -- ^ End point
-> IM.IntMap Creature
-- collides a point with forcefields -> 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 -- if found, returns point of collision, deflection if required, and the id
collidePointFFs = undefined collidePointFFs = undefined
collidePointFF = undefined collidePointFF = undefined
@@ -531,36 +249,27 @@ collidePointFF = undefined
-- f p = (p, (ref, _ffID ff)) -- f p = (p, (ref, _ffID ff))
-- --
-- looks for first collision of a point with walls -- | Looks for first collision of a circle with walls.
-- if found, gives point and reflection velocity, reflection damped in normal -- 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
collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2) collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls' p1 p2 rad ws collideCircWalls' p1 p2 rad ws
= listToMaybe $ sortBy f $ IM.elems = listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe $ 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))) . (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
) )
(intersectSegSeg' p1 p2 x y) (intersectSegSeg' p1 p2 x y)
) . shiftByRad . _wlLine )
. shiftByRad . _wlLine
) ws ) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) where
shiftByRad (a:b:_) = map ((+.+) (rad *.* normalizeV (vNormal (a -.- b)))) f (a,_) = magV (p1 -.- a)
[a +.+ rad *.* (normalizeV (a -.-b)) shiftByRad (a:b:_) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
,b +.+ rad *.* (normalizeV (b -.-a)) [a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
] ]
-- this shifts the wall out, and for outer corners extends the wall -- 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 -- 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 -- unfortunately, doesn't allow for collisions when the circle spawns on the
-- wall -- wall
-- looks for first collision of a point with walls -- | Looks for first collision of a point with walls.
-- if found, gives point and normal of wall -- If found, gives point and normal of wall.
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe collidePointWallsNorm p1 p2 ws
(( \(x:y:_) -> fmap (flip (,) ( vNormal $ x -.- y )) = listToMaybe
(intersectSegSeg' p1 p2 x y) . sortOn f
) . _wlLine . IM.elems
) ws $ IM.mapMaybe (( \(x:y:_) -> intersectSegSeg' p1 p2 x y <&> (, vNormal $ x -.- y ) )
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) . _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
{- | Looks for first collision of a point with walls. {- | Looks for first collision of a point with walls.
If found, gives point and colour of wall. If found, gives point and colour of wall.
-} -}
collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color) collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color)
collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe collidePointWallsCol p1 p2 ws
( (\(m, c) -> fmap (flip (,) c) m) = listToMaybe
. (\w -> (intersectSegSeg' p1 p2 . sortOn f
(_wlLine w !! 0) (_wlLine w !! 1), _wlColor w)) . IM.elems
) ws $ IM.mapMaybe ( (\(m, c) -> m <&> (, c))
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) . (\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. {- | Looks for first collision of a point with walls.
If found, gives point, and normal and colour of wall. If found, gives point, and normal and colour of wall.
-} -}
collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color) collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
collidePointWallsNormCol p1 p2 ws collidePointWallsNormCol p1 p2 ws
= listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws = listToMaybe
where f (a,_,_) (b,_,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) . sortOn f
ls w = let (x:y:_) = _wlLine w . IM.elems
in (intersectSegSeg' p1 p2 x y, vNormal (x -.- y), _wlColor w) $ IM.mapMaybe m ws
m w = let (a1,a2,a3) = ls w where
in fmap (\a4 -> (a4,a2,a3)) a1 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. -- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $ collidePointCreatures p1 p2 w
IM.mapMaybe (\x -> = fmap fst
collidePointCirc' p1 p2 (_crRad x) (_crPos x) . listToMaybe
) . sortOn snd
(_creatures w) . IM.toList
where csnd (_,a) (_,b) = compare a b . IM.mapMaybe (\x -> collidePointCirc' p1 p2 (_crRad x) (_crPos x))
$_creatures w
-- | As for 'collidePointCreatures', only increases the radius of creatures by a -- | As for 'collidePointCreatures', only increases the radius of creatures by a
--fixed amount, thus collides a moving circle with creaures. --fixed amount, thus collides a moving circle with creaures.
collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $ collideCircCreatures p1 p2 rad w
IM.mapMaybe (\x -> = fmap fst
collidePointCirc' p1 p2 (rad + _crRad x) (_crPos x) . listToMaybe
) . sortOn snd
(_creatures w) . IM.toList
where csnd (_,a) (_,b) = compare a b . 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
-- | Returns the first creature, if any, that a point intersects with, gives point
--in creature on line. --in creature on line.
collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int) collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int)
collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $ collidePointCrsPoint p1 p2 w
IM.mapMaybe (\x -> = fmap f
collidePointCirc'' p1 p2 (_crRad x) (_crPos x) . listToMaybe
) . sortOn (snd . snd)
(_creatures w) . IM.toList
. IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
$ _creatures w
where where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID) 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 :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int)
collideCircCrsPoint p1 p2 rad w collideCircCrsPoint p1 p2 rad w
= fmap f = fmap f
. listToMaybe . listToMaybe
. sortBy (csndsnd) . sortOn (snd . snd)
. IM.toList . IM.toList
$ IM.mapMaybe (\x -> . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x))
collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x) $ _creatures w
)
(_creatures w)
where where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID) f (cID,(p,_)) = (p,cID)
-- | Makes a creature not hittable. -- | Makes a creature not hittable.
collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int) collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
collidePointCrsWithoutPoint cid p1 p2 w collidePointCrsWithoutPoint cid p1 p2 w
= fmap f = fmap f
. listToMaybe . listToMaybe
. sortBy (csndsnd) . sortOn (snd . snd)
. IM.toList . IM.toList
$ IM.mapMaybe (\x -> . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
collidePointCirc'' p1 p2 (_crRad x) (_crPos x) . IM.delete cid
) $ _creatures w
(IM.delete cid $ _creatures w)
where where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID) f (cID,(p,_)) = (p,cID)
{- | Test if a circle collides with any wall. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad) circOnSomeWall p rad w
$ fmap _wlLine $ IM.elems $ wallsNearPoint p w = any (\(x:y:_) -> circOnSeg x y p rad)
. fmap _wlLine
crsNearLine :: Float -> [Point2] -> World -> Bool . IM.elems
crsNearLine d (p1:p2:_) w = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c)) $ wallsNearPoint p w
$ IM.filter (\cr -> _crMass cr > 4) $ _creatures 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 :: Float -> Point2 -> World -> Bool
crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w) 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 :: Point2 -> Point2 -> World -> [Creature]
crsOnLine p1 p2 w crsOnLine p1 p2 w
= IM.elems = IM.elems
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr)) . IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
$ _creatures w $ _creatures w
{- | Produce an unordered list of creatures on a wide line. -}
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature] crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
crsOnThickLine thickness p1 p2 w crsOnThickLine thickness p1 p2 w
= IM.elems = IM.elems
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness)) . IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
$ _creatures w $ _creatures w
{- | Find 'Maybe' the closest creature to a point, within a circle. {- | Find 'Maybe' the closest creature to a point, within a circle.
-} -}
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
nearestCrInRad p r w nearestCrInRad p r w =
= let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs sortedCrs = sortOn (dist p . _crPos) $ IM.elems crs
in listToMaybe sortedCrs in listToMaybe sortedCrs
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape. {- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape.
-} -}
nearestCrInTri nearestCrInTri
@@ -698,90 +412,72 @@ nearestCrInTri
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis). -> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance. -> Float -- ^ Distance.
-> World -> Maybe Creature -> World -> Maybe Creature
nearestCrInTri p dir x w nearestCrInTri p dir x w =
= let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs sortedCrs = sortOn (dist p . _crPos) $ IM.elems crs
in listToMaybe sortedCrs in listToMaybe sortedCrs
where where
tri = [p tri =
[p
,p +.+ rotateV (dir-pi/4) (x,0) ,p +.+ rotateV (dir-pi/4) (x,0)
,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 {- | Find 'Maybe' the closes creature in front of a point in a given direction for
a given distance. 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 nearestCrInFront
:: Point2 :: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis). -> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance. -> Float -- ^ Distance.
-> World -> Maybe Creature -> World -> Maybe Creature
nearestCrInFront p dir x w nearestCrInFront p dir x w =
= let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs sortedCrs = sortOn (dist p . _crPos) $ IM.elems crs
in listToMaybe sortedCrs in listToMaybe sortedCrs
where where
rec = [p rec = [p, pR, pR1, pL1, pL ]
,pR
,pR1
,pL1
,pL
]
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0) pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
pL = 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) pR1 = pR +.+ rotateV dir (x/2,0)
pL1 = pL +.+ 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 :: Creature -> [Point2] -> Bool
crInPolygon cr = errorPointInPolygon 3 (_crPos cr) 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 :: World -> Point2 -> Point2
worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
where where
doTranslate p = p -.- _cameraCenter w doTranslate p = p -.- _cameraCenter w
doZoom p = _cameraZoom w *.* p doZoom p = _cameraZoom w *.* p
doRotate p = rotateV (0 - _cameraRot w) p doRotate p = rotateV (negate $ _cameraRot w) p
doWindowScale (x,y) = ( x * 2 / getWindowX w doWindowScale (x,y) =
( x * 2 / getWindowX w
, y * 2 / getWindowY w , y * 2 / getWindowY w
) )
{- | Transform coordinates from the map position to normalised screen {- | Transform coordinates from the map position to normalised screen
coordinates. coordinates. -}
-}
cartePosToScreen :: World -> Point2 -> Point2 cartePosToScreen :: World -> Point2 -> Point2
cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
where where
doTranslate p = p -.- _carteCenter w doTranslate p = p -.- _carteCenter w
doZoom p = _carteZoom w *.* p doZoom p = _carteZoom w *.* p
doRotate p = rotateV (0 - _carteRot w) p doRotate p = rotateV (negate $ _carteRot w) p
doWindowScale (x,y) = ( x * 2 / getWindowX w doWindowScale (x,y) =
( x * 2 / getWindowX w
, y * 2 / getWindowY w , y * 2 / getWindowY w
) )
{- | The mouse position in world coordinates. -}
{- | The mouse position in world coordinates.
-}
mouseWorldPos :: World -> Point2 mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) 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 :: World -> Point2
mouseCartePos w = _carteCenter w +.+ (1/_carteZoom w) *.* rotateV (_carteRot w) (_mousePos w) 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 :: Float -> Float -> Float -> (Float -> Float)
logistic x0 l k x = l / (1 + exp (k*(x0 - x))) 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 {- | given a target and a start point, shift toward the end point by a given
amount. amount.
If close enough, end up on the end point If close enough, end up on the end point -}
-}
mvPointTowardAtSpeed mvPointTowardAtSpeed
:: Float -- ^ Speed. :: Float -- ^ Speed.
-> Point2 -- ^ End point. -> Point2 -- ^ End point.
@@ -790,14 +486,12 @@ mvPointTowardAtSpeed
mvPointTowardAtSpeed speed !ep !p mvPointTowardAtSpeed speed !ep !p
| dist p ep < speed = ep | dist p ep < speed = ep
| otherwise = p +.+ speed *.* normalizeV (ep -.- p) | otherwise = p +.+ speed *.* normalizeV (ep -.- p)
{- | given a target and a start point, shift toward the end point by 1. {- | 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 mvPointToward
:: Point2 -- ^ End point. :: Point2 -- ^ End point.
-> Point2 -- ^ Start point. -> Point2 -- ^ Start point.
-> Point2 -> Point2
mvPointToward !ep !p | dist p ep < 1 = ep mvPointToward !ep !p
| dist p ep < 1 = ep
| otherwise = p +.+ normalizeV (ep -.- p) | 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.YourControl
import Dodge.Creature.Inanimate import Dodge.Creature.Inanimate
import Dodge.Creature.State import Dodge.Creature.State
import Dodge.Creature.Picture
import Dodge.Item import Dodge.Item
import Dodge.Picture.Layer import Dodge.Picture.Layer
import Dodge.Creature.Picture
import Picture import Picture
import Geometry import Geometry
@@ -37,15 +39,12 @@ import qualified Data.Map as M
import Foreign.ForeignPtr import Foreign.ForeignPtr
import Control.Concurrent import Control.Concurrent
colouredEnemy col = pictures [color col $ circleSolid 10, circLine 10]
spawnerCrit :: Creature spawnerCrit :: Creature
spawnerCrit = defaultCreature spawnerCrit = defaultCreature
{ _crUpdate = stateUpdate $ spawnerAI chaseCrit { _crUpdate = stateUpdate $ spawnerAI chaseCrit
, _crHP = 300 , _crHP = 300
, _crPict = basicCrPict blue , _crPict = basicCrPict blue
, _crState = defaultState {_goals = [[WaitFor 0]] , _crState = defaultState {_goals = [[WaitFor 0]] }
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)] , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
} }
smallChaseCrit :: Creature smallChaseCrit :: Creature
@@ -54,8 +53,10 @@ smallChaseCrit = defaultCreature
, _crHP = 1 , _crHP = 1
, _crRad = 4 , _crRad = 4
, _crPict = basicCrPict green , _crPict = basicCrPict green
, _crState = defaultState {_goals = [[Wait]] , _crState = defaultState
,_faction = ChaseCritters} {_goals = [[Wait]]
,_faction = ChaseCritters
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)] , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4 , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4
} }
@@ -64,8 +65,10 @@ chaseCrit = defaultCreature
{ _crUpdate = stateUpdate chaseAI { _crUpdate = stateUpdate chaseAI
, _crHP = 300 , _crHP = 300
, _crPict = basicCrPict green , _crPict = basicCrPict green
, _crState = defaultState {_goals = [[Wait]] , _crState = defaultState
,_faction = ChaseCritters} {_goals = [[Wait]]
,_faction = ChaseCritters
}
, _crInv = IM.empty , _crInv = IM.empty
} }
armourChaseCrit :: Creature armourChaseCrit :: Creature
@@ -142,40 +145,17 @@ pistolCrit = defaultCreature
autoCrit :: Creature autoCrit :: Creature
autoCrit = defaultCreature autoCrit = defaultCreature
{ _crPict = basicCrPict red { _crPict = basicCrPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate basicShooterAI , _crUpdate = stateUpdate basicShooterAI
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,autoGun),(1,medkit 100)] , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
, _crInvSel = 0 , _crInvSel = 0
, _crRad = 10 , _crRad = 10
--, _crState = ShooterWait
, _crState = defaultState {_goals = [[InitGuard]]} , _crState = defaultState {_goals = [[InitGuard]]}
, _crHP = 300 , _crHP = 300
} }
addArmour :: Creature -> Creature addArmour :: Creature -> Creature
addArmour = over crInv insarmour addArmour = over crInv insarmour
where insarmour xs = IM.insert i frontArmour xs where
where i = newKey xs insarmour xs = IM.insert (newKey xs) frontArmour 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
]
--packCrits :: (Int -> World -> World) -> [Int] -> [Creature] --packCrits :: (Int -> World -> World) -> [Int] -> [Creature]
--packCrits ai is = [(defaultCreature i) --packCrits ai is = [(defaultCreature i)
@@ -220,27 +200,7 @@ frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20
-- , line [(-3,3),(3,-3)] -- , line [(-3,3),(3,-3)]
-- , line [(0,-3),(0,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. The creature you control.
ID 0. ID 0.
-} -}
@@ -254,12 +214,12 @@ startCr = defaultCreature
, _crUpdate = stateUpdate yourControl , _crUpdate = stateUpdate yourControl
, _crRad = 10 , _crRad = 10
, _crMass = 10 , _crMass = 10
, _crHP = 1000000 , _crHP = 1000
, _crMaxHP = 1500 , _crMaxHP = 1500
, _crInv = startInventory , _crInv = startInventory
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10] , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
} }
{- {- |
Items you start with. Items you start with.
-} -}
startInventory = IM.fromList (zip [0..20] startInventory = IM.fromList (zip [0..20]
@@ -287,31 +247,3 @@ startInventory = IM.fromList (zip [0..20]
smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor 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 :: Int -- ^ Creature id
-> World -> World
-> World -> World
blinkAction n w = soundOnce teleSound blinkAction n w
$ set (creatures . ix n . crPos) p3 = soundOnce teleSound
$ blinkShockwave n p3 . set (creatures . ix n . crPos) p3
$ inverseShockwaveAt cp 40 2 2 2 . blinkShockwave n p3
w $ inverseShockwaveAt cp 40 2 2 2 w
where where
p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
cp = _crPos $ _creatures w IM.! n 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) r = 1.5 * _crRad (_creatures w IM.! n)
p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2) 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 data Wall
= Wall = Wall
{ _wlLine :: [Point2] , _wlID :: Int { _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color , _wlColor :: Color
, _wlSeen :: Bool , _wlSeen :: Bool
, _wlIsSeeThrough :: 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 q = _pjVel pj
p1 = _pjPos pj p1 = _pjPos pj
p' = _pjStartPos 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 p4 = vNormal p5
p5 = errorNormalizeV 12 $ p2 -.- p1 p5 = errorNormalizeV 12 $ p2 -.- p1
p3 = p1 +.+ p4 p3 = p1 +.+ p4
src/Dodge/Picture.hs
+13 -3
View File
@@ -23,9 +23,19 @@ vvThickLine = lineOfThickness 6
-- shit this is ugly -- shit this is ugly
lineOfThickness :: Float -> [Point2] -> Picture lineOfThickness :: Float -> [Point2] -> Picture
lineOfThickness t = pictures . f lineOfThickness t = pictures . f
where f (x:y:ys) where
f (x:y:ys)
| x == y = f (x:ys) | x == y = f (x:ys)
| otherwise | otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
= polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = [] f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b)) 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. Higher numbers will get placed on top of lower numbers.
-} -}
onLayerL :: [Int] -> Picture -> Picture 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. {- | For depth testing, set layer values.
-} -}
src/Dodge/Room/Airlock.hs
+2 -2
View File
@@ -23,7 +23,7 @@ airlockOneWay n = Room
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [] , _rmPath = []
, _rmPS = [PS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40) , _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 ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True)) (M.insert (DoorNumOpen n) True))
] ]
@@ -60,7 +60,7 @@ airlock0 n = Room
] ]
, _rmPS = , _rmPS =
[PS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0) [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 ,PS (35,50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True)) (over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False)) (over worldState (M.insert (DoorNumOpen n) False))
src/Dodge/Room/Boss.hs
+1 -1
View File
@@ -66,7 +66,7 @@ randomMediumRoom = takeOne
[ roomOctogon 300 [ roomOctogon 300
, roomCross 180 300 , roomCross 180 300
, roomShuriken 200 300 , roomShuriken 200 300
, roomTwistCross 230 300 (0) , roomTwistCross 230 300 0
] ]
roomCross roomCross
src/Dodge/Room/Corridor.hs
+1 -1
View File
@@ -21,7 +21,7 @@ corridor = Room
lnks = lnks =
[((20,70) ,0) [((20,70) ,0)
,((20,70), pi/6) ,((20,70), pi/6)
,((20,70), 0-pi/6) ,((20,70), negate $ pi/6)
,((20,10) ,pi) ,((20,10) ,pi)
] ]
corridorN :: Room corridorN :: Room
src/Dodge/Room/LongDoor.hs
+19 -16
View File
@@ -40,7 +40,7 @@ twinSlowDoorRoom drID w h x = Room
, _rmPS = , _rmPS =
[ PS (0,h/2) 0 putLamp [ PS (0,h/2) 0 putLamp
, PS (25,5) 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) drL
, PS (0,0) 0 $ PutDoor col (not . cond) drR , PS (0,0) 0 $ PutDoor col (not . cond) drR
, PS (0,h-5) pi $ PutButton $ makeButton col , PS (0,h-5) pi $ PutButton $ makeButton col
@@ -57,7 +57,7 @@ twinSlowDoorRoom drID w h x = Room
[0..nDrp] [0..nDrp]
drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral) drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp] [0..nDrp]
nDrp = ceiling $ h nDrp = ceiling h
cond w = or $ M.lookup (DoorNumOpen drID) (_worldState w) cond w = or $ M.lookup (DoorNumOpen drID) (_worldState w)
col = dim $ dim $ bright red col = dim $ dim $ bright red
@@ -82,31 +82,34 @@ slowDoorRoom = do
,( (x/2+50,5),0) ,( (x/2+50,5),0)
] ]
let n = 25 let n = 25
xs <- sequence $ replicate n $ state $ randomR (10,x-10) xs <- replicateM n $ state $ randomR (10,x-10)
ys <- sequence $ replicate n $ state $ randomR (h+20,y) ys <- replicateM n $ state $ randomR (h+20,y)
rs <- sequence $ replicate n $ state $ randomR (0,2*pi) rs <- replicateM n $ state $ randomR (0,2*pi)
let ps = zip xs ys let ps = zip xs ys
xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10) xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y) ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> PS p r randC1) ps rs 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] 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' barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
let pillarsa = [] pillarsa = []
let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20) 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 (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 (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) ++ 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) ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc] pillars <- takeOne [pillarsa, pillarsb, pillarsc]
let cond x = (snd . fst) x > h + 40 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) but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
-- ,PutSwitchDoor (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 fmap connectRoom
$ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) (filterLinks cond =<<
changeLinkTo cond2
(set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRectAutoLinks x y $ 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) roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)] makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
makeGrid x nx y ny = nub $ concatMap doublePair makeGrid x nx y ny
$ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y) = nub
. concatMap doublePair
. concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
$ gridPoints x nx y ny $ gridPoints x nx y ny
gridPoints :: Float -> Int -> Float -> Int -> [Point2] 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 nsDoors = rectNSWE (d + 20) (negate (d +20)) (-20) 20
weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20)) weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20))
centerPoly = rectWdthHght (d - 20) (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 return $ Room
{ _rmPolys = polys { _rmPolys = polys
, _rmLinks = , _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] tRays = rotF [(y, maxViewDistance) | y <- zs]
bRays = rotF [(y,-maxViewDistance) | y <- zs] bRays = rotF [(y,-maxViewDistance) | y <- zs]
rotF = map (h . (+.+) cpos . rotateV (_cameraRot w)) 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 maxViewDistance = 800
src/Dodge/WorldEvent/Explosion.hs
+4 -5
View File
@@ -63,11 +63,11 @@ makeExplosionAt
:: Point2 -- ^ Position :: Point2 -- ^ Position
-> World -> World
-> World -> World
makeExplosionAt p w = soundOncePos grenadeBang p makeExplosionAt p w
= soundOncePos grenadeBang p
. addFlames . addFlames
. explosionFlashAt p . explosionFlashAt p
$ makeShockwaveAt [] p 50 10 1 white $ makeShockwaveAt [] p 50 10 1 white w
w
where where
fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w
fPs' = replicateM 75 (randInCirc 15) & 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 mF q v size time = makeFlameletTimed q v Nothing size time
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
addFlames w = foldr ($) w newFs addFlames w = foldr ($) w newFs
pushAgainstWalls q = maybe q (uncurry (+.+)) pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q $ wallsNearPoint q w
$ collidePointWalls 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 sID = newProjectileKey w
q1 = last $ init ps' q1 = last $ init ps'
q2 = last 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 (d1,_) = randomR (-0.7,0.7) $ _randGen w
sv = maybe (q2 -.- q1) snd hitWall sv = maybe (q2 -.- q1) snd hitWall
@@ -362,7 +362,7 @@ crOrWallSensitive p dir wlAttract w =
. sortBy (compare `on` dist p) . sortBy (compare `on` dist p)
$ mapMaybe $ mapMaybe
( fmap fst ( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p . (+.+) p
. (\d -> rotateV d (100,0)) . (\d -> rotateV d (100,0))
. (+ dir) . (+ dir)
@@ -385,11 +385,12 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
$ catMaybes [cr,wlp] $ catMaybes [cr,wlp]
where where
cr = E3x1 <$> nearestCrInFront p dir 100 w cr = E3x1 <$> nearestCrInFront p dir 100 w
wlp = fmap E3x2 $ listToMaybe wlp = fmap E3x2
$ listToMaybe
$ sortBy (compare `on` dist p) $ sortBy (compare `on` dist p)
$ mapMaybe $ mapMaybe
( fmap fst ( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
. (+.+) p . (+.+) p
. (\d -> rotateV d (100,0)) . (\d -> rotateV d (100,0))
. (+) dir . (+) dir