From e21178b688da6d15446534023ba78425e38479cf Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 3 May 2021 23:59:20 +0200 Subject: [PATCH] Refactoring --- src/Dodge/AIs.hs | 23 +- src/Dodge/Base.hs | 836 ++++++++------------------ src/Dodge/Base/Collide.hs | 211 +++++++ src/Dodge/Base/Window.hs | 24 + src/Dodge/Base/Zone.hs | 172 ++++++ src/Dodge/Creature.hs | 100 +-- src/Dodge/Creature/Action.hs | 12 +- src/Dodge/Creature/Picture.hs | 53 ++ src/Dodge/Data.hs | 3 +- src/Dodge/Item/Weapon/UseEffect.hs | 2 +- src/Dodge/Picture.hs | 22 +- src/Dodge/Picture/Layer.hs | 2 +- src/Dodge/Room/Airlock.hs | 4 +- src/Dodge/Room/Boss.hs | 2 +- src/Dodge/Room/Corridor.hs | 2 +- src/Dodge/Room/LongDoor.hs | 45 +- src/Dodge/Room/Procedural.hs | 10 +- src/Dodge/Update/Camera.hs | 2 +- src/Dodge/WorldEvent/Explosion.hs | 9 +- src/Dodge/WorldEvent/SpawnParticle.hs | 27 +- 20 files changed, 830 insertions(+), 731 deletions(-) create mode 100644 src/Dodge/Base/Collide.hs create mode 100644 src/Dodge/Base/Window.hs create mode 100644 src/Dodge/Base/Zone.hs create mode 100644 src/Dodge/Creature/Picture.hs diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs index 92b15c717..326a14826 100644 --- a/src/Dodge/AIs.hs +++ b/src/Dodge/AIs.hs @@ -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) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index e8c128874..bcb4fad0c 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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) - f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2))) + 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) - -> 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 - f _ = IM.insertWith fun y obj + where + f _ = IM.insertWith fun y obj -insertIMInZone :: Int -> Int -> Int -> a -> IM.IntMap (IM.IntMap (IM.IntMap 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 - g _ = IM.insert obid obj - -adjustIMZone :: (a -> a) -> Int -> Int -> Int -> 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 - where f' = IM.adjust f'' y - f'' = IM.adjust f n - - + where + f _ = IM.insertWith g y $ IM.singleton obid obj + g _ = IM.insert obid obj +adjustIMZone + :: (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 = 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 - + 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 - Nothing -> Nothing - 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) - +reflectPointCreature p1 p2 cr = case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of + Nothing -> Nothing + Just p3 -> Just + ( p1 + , errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) + +.+ (_crPos 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 - Nothing -> Nothing - 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 +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 + , errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) + +.+ (_crPos cr -.- _crOldPos cr) + , _crID cr + ) +{- | 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,166 +249,162 @@ 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 - $ IM.mapMaybe - (( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1)) - . (+.+ errorNormalizeV 40 (vNormal (x -.- y))) - ) - (intersectSegSeg' p1 p2 x y) - ) . 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)) - ] + = listToMaybe + . sortOn f + . IM.elems + $ IM.mapMaybe + (( \(x:y:_) -> fmap + ((, reflectInParam 0.5 (x -.- y) (p2 -.- p1)) + . (+.+ errorNormalizeV 40 (vNormal (x -.- y))) + ) + (intersectSegSeg' p1 p2 x y) + ) + . shiftByRad . _wlLine + ) ws + 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 -- the alternative would be to separately bounce off corner points... -- 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 - in listToMaybe sortedCrs - +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 - in listToMaybe sortedCrs +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 - ,p +.+ rotateV (dir-pi/4) (x,0) - ,p +.+ rotateV (dir+pi/4) (x,0) - ] + 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 - in listToMaybe sortedCrs +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 - , y * 2 / getWindowY w - ) - + doTranslate p = p -.- _cameraCenter w + doZoom p = _cameraZoom w *.* p + 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 - , y * 2 / getWindowY w - ) - -{- | The mouse position in world coordinates. - -} + doTranslate p = p -.- _carteCenter w + doZoom p = _carteZoom w *.* p + doRotate p = rotateV (negate $ _carteRot w) p + doWindowScale (x,y) = + ( x * 2 / getWindowX w + , y * 2 / getWindowY w + ) +{- | 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 - | otherwise = p +.+ normalizeV (ep -.- p) - +mvPointToward !ep !p + | dist p ep < 1 = ep + | otherwise = p +.+ normalizeV (ep -.- p) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs new file mode 100644 index 000000000..a3c56f743 --- /dev/null +++ b/src/Dodge/Base/Collide.hs @@ -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 diff --git a/src/Dodge/Base/Window.hs b/src/Dodge/Base/Window.hs new file mode 100644 index 000000000..b347dbae7 --- /dev/null +++ b/src/Dodge/Base/Window.hs @@ -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 diff --git a/src/Dodge/Base/Zone.hs b/src/Dodge/Base/Zone.hs new file mode 100644 index 000000000..fc02d1f94 --- /dev/null +++ b/src/Dodge/Base/Zone.hs @@ -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 diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 15165dcf9..35ca80636 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -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 diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 973c18de0..127e43a92 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -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) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs new file mode 100644 index 000000000..65213b793 --- /dev/null +++ b/src/Dodge/Creature/Picture.hs @@ -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)] diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index ecb27f7ec..5fee2fd62 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/UseEffect.hs b/src/Dodge/Item/Weapon/UseEffect.hs index c0a41c42f..6a1a3ecec 100644 --- a/src/Dodge/Item/Weapon/UseEffect.hs +++ b/src/Dodge/Item/Weapon/UseEffect.hs @@ -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 diff --git a/src/Dodge/Picture.hs b/src/Dodge/Picture.hs index cf05fcdf7..ca9b2dfde 100644 --- a/src/Dodge/Picture.hs +++ b/src/Dodge/Picture.hs @@ -23,9 +23,19 @@ vvThickLine = lineOfThickness 6 -- shit this is ugly lineOfThickness :: Float -> [Point2] -> Picture lineOfThickness t = pictures . f - 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) - f _ = [] - n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b)) + 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) + 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)) diff --git a/src/Dodge/Picture/Layer.hs b/src/Dodge/Picture/Layer.hs index 5ad43117a..4cb0b8e5b 100644 --- a/src/Dodge/Picture/Layer.hs +++ b/src/Dodge/Picture/Layer.hs @@ -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. -} diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index ecdd07900..5d3359b7f 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -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)) diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index 410bb0507..0d3928ea5 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -66,7 +66,7 @@ randomMediumRoom = takeOne [ roomOctogon 300 , roomCross 180 300 , roomShuriken 200 300 - , roomTwistCross 230 300 (0) + , roomTwistCross 230 300 0 ] roomCross diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index f14dcdba5..d98ce648d 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -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 diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 874556bbf..139068b78 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -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) - ++ 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) - ++ putBlockRect (2*x/3-20) (2*x/3+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) + 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) - $ roomRectAutoLinks x y - )) + 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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index e07c99437..f86944d41 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -62,9 +62,11 @@ 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) - $ gridPoints x nx y ny +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] gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x @@ -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 = diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index b4b06cf7e..0c5c1fd7f 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -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 diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index a108b5dd5..95611aa22 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -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 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index cff151045..52efc4c2a 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -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,17 +385,18 @@ 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 - $ sortBy (compare `on` dist p) - $ mapMaybe - ( fmap fst - . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) - . (+.+) p - . (\d -> rotateV d (100,0)) - . (+) dir - ) - [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8] - --[-pi/4,-pi/8,0,pi/8,pi/4] + wlp = fmap E3x2 + $ listToMaybe + $ sortBy (compare `on` dist p) + $ mapMaybe + ( fmap fst + . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w) + . (+.+) p + . (\d -> rotateV d (100,0)) + . (+) dir + ) + [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8] + --[-pi/4,-pi/8,0,pi/8,pi/4] g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first g (E3x1 cr1) = dist p $ _crPos cr1