From 82db86f55fdbbcf19f4eaddebf42876d2e969cf5 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 30 Jul 2022 14:21:13 +0100 Subject: [PATCH] Fix bugs in zoning --- src/Dodge/Base/Collide.hs | 2 +- src/Dodge/Damage.hs | 17 ++-- src/Dodge/Data.hs | 7 +- src/Dodge/Data/Config.hs | 1 + src/Dodge/Data/World.hs | 1 + src/Dodge/Default/World.hs | 1 + src/Dodge/Draw.hs | 46 ++++++++++ src/Dodge/Machine/Update.hs | 2 +- src/Dodge/Placement/Instance/Sensor.hs | 40 +++++---- src/Dodge/Render/Label.hs | 31 +++++++ src/Dodge/Render/ShapePicture.hs | 111 ++++++++++++------------- src/Dodge/Spark.hs | 24 +++--- src/Dodge/Update.hs | 11 ++- src/Dodge/WorldEvent/ThingsHit.hs | 51 ++---------- src/Dodge/Zoning/Base.hs | 6 +- src/Dodge/Zoning/Creature.hs | 10 ++- 16 files changed, 204 insertions(+), 157 deletions(-) create mode 100644 src/Dodge/Draw.hs create mode 100644 src/Dodge/Render/Label.hs diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 6a1ab771f..5a0a50004 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -327,7 +327,7 @@ canSeeIndirect i j w = hasLOSIndirect ipos jpos w anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl) where - hitCr = IS.foldr f False $ crsNearSeg sp ep w + hitCr = IS.foldr f False $ crixsNearSeg sp ep w f cid bl = maybe False diff --git a/src/Dodge/Damage.hs b/src/Dodge/Damage.hs index 7120a7455..9a2958fdb 100644 --- a/src/Dodge/Damage.hs +++ b/src/Dodge/Damage.hs @@ -1,23 +1,28 @@ -module Dodge.Damage where +{-# LANGUAGE LambdaCase #-} +module Dodge.Damage + ( damageCrWl + , damageDirection + , damageCrWlID + , maxDamageType + ) where import qualified Data.Map.Strict as M import Dodge.Data.CrWlID import Dodge.Data.World -import Dodge.Wall.Damage import FoldableHelp import Geometry.Vector import LensHelp import qualified IntMapHelp as IM damageCrWlID :: Damage -> CrWlID -> World -> World -damageCrWlID dam crwl = case crwl of +damageCrWlID dam = \case NothingID -> id CrID cid -> cWorld . creatures . ix cid . crState . csDamage .:~ dam WlID wlid -> cWorld . wallDamages %~ IM.insertWith (++) wlid [dam] -damageCrWall :: Damage -> Either Creature Wall -> World -> World -damageCrWall dt (Left cr) = cWorld . creatures . ix (_crID cr) . crState . csDamage .:~ dt -damageCrWall dt (Right wl) = damageWall dt wl +damageCrWl :: Damage -> Either Creature Wall -> World -> World +damageCrWl dt (Left cr) = cWorld . creatures . ix (_crID cr) . crState . csDamage .:~ dt +damageCrWl dt (Right wl) = cWorld . wallDamages %~ IM.insertWith (++) (_wlID wl) [dt] damageDirection :: [Damage] -> Maybe Float damageDirection ds = do diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 1c6aa0696..ae0c98a3e 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} - {- | -Contains base datatypes that cannot be seperated into -different modules because they are interdependent; -circular imports are probably not a good idea. +Rexports all Dodge.Data.x files. -} module Dodge.Data ( module Dodge.Data.World, diff --git a/src/Dodge/Data/Config.hs b/src/Dodge/Data/Config.hs index a0c75ff48..32b6e0b57 100644 --- a/src/Dodge/Data/Config.hs +++ b/src/Dodge/Data/Config.hs @@ -46,6 +46,7 @@ data DebugBool | Bound_box_screen | Show_wall_search_rays | Show_dda_test + | Collision_test | Show_far_wall_detect | Show_select | Inspect_wall diff --git a/src/Dodge/Data/World.hs b/src/Dodge/Data/World.hs index a488312a2..e5547ff4c 100644 --- a/src/Dodge/Data/World.hs +++ b/src/Dodge/Data/World.hs @@ -34,6 +34,7 @@ data World = World , _testFloat :: Float , _lLine :: (Point2, Point2) , _rLine :: (Point2, Point2) + , _lrLine :: (Point2, Point2) , _lSelect :: Point2 , _rSelect :: Point2 , _backspaceTimer :: Int diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index b3ab4a43c..4f3915ed7 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -23,6 +23,7 @@ defaultWorld = , _mousePos = V2 0 0 , _hammers = defaultWorldHammers , _testFloat = 0 + , _lrLine = (0, 0) , _lLine = (0, 0) , _rLine = (0, 0) , _lSelect = 0 diff --git a/src/Dodge/Draw.hs b/src/Dodge/Draw.hs new file mode 100644 index 000000000..6404c8765 --- /dev/null +++ b/src/Dodge/Draw.hs @@ -0,0 +1,46 @@ +{- | +Rexports all Dodge.x.Draw files. +-} +module Dodge.Draw ( + module Dodge.Beam.Draw, + module Dodge.Block.Draw, + module Dodge.Item.Draw, + module Dodge.Bullet.Draw, + module Dodge.Button.Draw, + module Dodge.Cloud.Draw, + module Dodge.EnergyBall.Draw, + module Dodge.Flame.Draw, + module Dodge.Laser.Draw, + module Dodge.LightSource.Draw, + module Dodge.LinearShockwave.Draw, + module Dodge.Machine.Draw, + module Dodge.Projectile.Draw, + module Dodge.Prop.Draw, + module Dodge.RadarSweep.Draw, + module Dodge.Spark.Draw, + module Dodge.Targeting.Draw, + module Dodge.Tesla.Arc.Draw, + module Dodge.TractorBeam.Draw, + module Dodge.Shockwave.Draw, +) where + +import Dodge.Beam.Draw +import Dodge.Item.Draw +import Dodge.Block.Draw +import Dodge.Bullet.Draw +import Dodge.Button.Draw +import Dodge.Cloud.Draw +import Dodge.EnergyBall.Draw +import Dodge.Flame.Draw +import Dodge.Laser.Draw +import Dodge.LightSource.Draw +import Dodge.LinearShockwave.Draw +import Dodge.Machine.Draw +import Dodge.Projectile.Draw +import Dodge.Prop.Draw +import Dodge.RadarSweep.Draw +import Dodge.Shockwave.Draw +import Dodge.Spark.Draw +import Dodge.Targeting.Draw +import Dodge.Tesla.Arc.Draw +import Dodge.TractorBeam.Draw diff --git a/src/Dodge/Machine/Update.hs b/src/Dodge/Machine/Update.hs index dd6293072..3f5c48174 100644 --- a/src/Dodge/Machine/Update.hs +++ b/src/Dodge/Machine/Update.hs @@ -70,7 +70,7 @@ mcSensorTriggerUpdate :: Sensor -> Machine -> World -> World mcSensorTriggerUpdate se mc = fromMaybe id $ do trid <- mc ^? mcMounts . ix ObTrigger bval <- mcTriggerVal se - return $ cWorld . triggers . ix trid .~ bval + return $ cWorld . triggers . ix trid ||~ bval mcTriggerVal :: Sensor -> Maybe Bool mcTriggerVal se = case se of diff --git a/src/Dodge/Placement/Instance/Sensor.hs b/src/Dodge/Placement/Instance/Sensor.hs index 0e45671f3..91d51d318 100644 --- a/src/Dodge/Placement/Instance/Sensor.hs +++ b/src/Dodge/Placement/Instance/Sensor.hs @@ -19,26 +19,34 @@ damageSensor :: PlacementSpot -> Placement damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $ - \lsid -> psPtJpl ps $ - PutUsingGenParams $ - \gw -> - ( gw - , PutMachine - (reverse $ square wdth) - ( defaultMachine - & mcColor .~ yellow - & mcMounts . at ObTrigger .~ mtrid - & mcMounts . at ObLightSource ?~ lsid - & mcType .~ McSensor (DamageSensor False 0 dt (_sensorCoding (_genParams (_cWorld gw)) M.! dt) (damageTypeThreshold dt)) - ) - defaultSensorWall + \lsid -> psPtJpl ps + . PutUsingGenParams + $ \gw -> + ( gw + , PutMachine + (reverse $ square wdth) + ( defaultMachine + & mcColor .~ yellow + & mcMounts . at ObTrigger .~ mtrid + & mcMounts . at ObLightSource ?~ lsid + & mcType + .~ McSensor + ( DamageSensor + False + 0 + dt + (_sensorCoding (_genParams (_cWorld gw)) M.! dt) + (damageTypeThreshold dt) + ) ) + defaultSensorWall + ) damageTypeThreshold :: DamageType -> Int damageTypeThreshold dt = case dt of - FLAMING -> 1000 - LASERING -> 1000 - ELECTRICAL -> 5 + FLAMING -> 1000 + LASERING -> 1000 + ELECTRICAL -> 500 _ -> undefined lightSensor :: diff --git a/src/Dodge/Render/Label.hs b/src/Dodge/Render/Label.hs new file mode 100644 index 000000000..33a53fcce --- /dev/null +++ b/src/Dodge/Render/Label.hs @@ -0,0 +1,31 @@ +module Dodge.Render.Label + where +import Dodge.Base.Coordinate +import Dodge.ShortShow +import Dodge.Base.WinScale +import Picture +import Dodge.Data.Universe +import Geometry + +drawLabCrossCol :: Configuration -> World -> Color -> Point2 -> Picture +drawLabCrossCol cfig w col p = drawCrossCol col p + <> drawPointLabel cfig w p + +drawPointLabel :: Configuration -> World -> Point2 -> Picture +drawPointLabel cfig w p = + setLayer FixedCoordLayer . winScale cfig + . uncurryV translate p' + . scale 0.1 0.1 + . text + $ shortPoint2 p + where + p' = worldPosToScreen w p + +drawCrossCol :: Color -> Point2 -> Picture +drawCrossCol col p = setLayer DebugLayer . color col . uncurryV translate p $ crossPic 5 + +drawCross :: Point2 -> Picture +drawCross = drawCrossCol red + +crossPic :: Float -> Picture +crossPic x = line [V2 x x, V2 (- x) (- x)] <> line [V2 (- x) x, V2 x (- x)] diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index e3273542e..f81c659ac 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -2,7 +2,8 @@ module Dodge.Render.ShapePicture ( worldSPic, ) where -import Dodge.Zoning.Base +import Dodge.Render.Label +import Dodge.WorldEvent.ThingsHit import Control.Lens import Data.Foldable import qualified Data.Graph.Inductive as FGL @@ -10,47 +11,28 @@ import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as Set import Dodge.Base -import Dodge.Beam.Draw -import Dodge.Block.Draw -import Dodge.Bullet.Draw -import Dodge.Button.Draw -import Dodge.Cloud.Draw import Dodge.Creature.Picture import Dodge.Creature.Picture.Awareness import Dodge.Data.Config import Dodge.Data.World import Dodge.Debug.Picture -import Dodge.EnergyBall.Draw -import Dodge.Flame.Draw +import Dodge.Draw import Dodge.Flare import Dodge.GameRoom import Dodge.Graph -import Dodge.Item.Draw.SPic -import Dodge.Laser.Draw -import Dodge.LightSource.Draw -import Dodge.LinearShockwave.Draw -import Dodge.Machine.Draw import Dodge.Path import Dodge.Picture.SizeInvariant -import Dodge.Projectile.Draw -import Dodge.Prop.Draw import Dodge.RadarBlip -import Dodge.RadarSweep.Draw import Dodge.Render.InfoBox import Dodge.Render.List -import Dodge.Shockwave.Draw import Dodge.ShortShow import Dodge.SoundLogic.LoadSound -import Dodge.Spark.Draw -import Dodge.Targeting.Draw -import Dodge.Tesla.Arc.Draw -import Dodge.TractorBeam.Draw import Dodge.Update.Camera import Dodge.Zone import Dodge.Zoning +import Dodge.Zoning.Base import Geometry import Geometry.ConvexPoly ---import Geometry.Zone import qualified IntMapHelp as IM import Padding import Picture @@ -172,36 +154,47 @@ debugDraw cfig w <> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts) | otherwise = mempty where - (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig) + pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig) + ts = map show (Set.toList $ _debug_booleans cfig) -debugDraw' :: Configuration -> World -> DebugBool -> ([String], Picture) +debugDraw' :: Configuration -> World -> DebugBool -> Picture {-# INLINE debugDraw' #-} debugDraw' cfig w bl = case bl of - Show_debug -> lstring "Show debug" - Noclip -> lstring "Noclip" - Remove_LOS -> lstring "No line of sight" - Cull_more_lights -> lstring "Cull more lights" - Close_shape_culling -> lstring "Close shape culling" - Bound_box_screen -> lstring "bound box screen, this should be moved" - Show_ms_frame -> rdraw mempty - View_boundaries -> rdraw $ viewBoundaries w - Show_bound_box -> rdraw $ drawBoundingBox w - Show_wall_search_rays -> rdraw $ drawWallSearchRays w - Show_dda_test -> rdraw $ drawDDATest w - Show_far_wall_detect -> rdraw $ drawFarWallDetect w - Show_select -> rdraw $ drawWorldSelect w - Inspect_wall -> rdraw $ drawInspectWalls w - Cr_awareness -> rdraw $ drawCreatureDisplayTexts w - Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w - Cr_status -> rdraw $ drawCrInfo cfig w - Mouse_position -> rdraw $ drawMousePosition cfig w - Walls_info -> rdraw $ drawWlIDs cfig w - Pathing -> rdraw $ drawPathing cfig w - Show_nodes_near_select -> rdraw $ drawNodesNearSelect w - Show_path_between -> rdraw $ drawPathBetween w + Show_debug -> mempty + Noclip -> mempty + Remove_LOS -> mempty + Cull_more_lights -> mempty + Close_shape_culling -> mempty + Bound_box_screen -> mempty + Show_ms_frame -> mempty + View_boundaries -> viewBoundaries w + Show_bound_box -> drawBoundingBox w + Show_wall_search_rays -> drawWallSearchRays w + Show_dda_test -> drawDDATest w + Show_far_wall_detect -> drawFarWallDetect w + Show_select -> drawWorldSelect w + Inspect_wall -> drawInspectWalls w + Cr_awareness -> drawCreatureDisplayTexts w + Show_sound -> pictures $ M.map (soundPic cfig w) $ _playingSounds w + Cr_status -> drawCrInfo cfig w + Mouse_position -> drawMousePosition cfig w + Walls_info -> drawWlIDs cfig w + Pathing -> drawPathing cfig w + Show_nodes_near_select -> drawNodesNearSelect w + Show_path_between -> drawPathBetween w + Collision_test -> drawCollisionTest cfig w + +drawCollisionTest :: Configuration -> World -> Picture +drawCollisionTest cfig w = + setLayer DebugLayer (color orange $ line [a,b]) + <> foldMap (drawCross . fst) (crHit a b w) + <> foldMap (drawCross . _crPos) (crsNearSeg a b w) +-- <> foldMap (drawZoneCol green crZoneSize) (zoneOfSeg' crZoneSize a b) + <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint' crZoneSize) (xIntercepts' crZoneSize a b) + <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint' crZoneSize) (yIntercepts' crZoneSize a b) + <> foldMap (drawLabCrossCol cfig w blue) (xIntercepts' crZoneSize a b) where - lstring str = ([str], mempty) - rdraw pic = (mempty, pic) + (a, b) = _lrLine w drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures (_cWorld w)) @@ -229,9 +222,11 @@ drawNodesNearSelect w = drawInspectWalls :: World -> Picture drawInspectWalls w = - foldMap (drawInspectWall w) $ + setLayer DebugLayer (color orange $ line [a,b]) <> + foldMap (drawInspectWall w) ( filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $ IM.elems $ _walls (_cWorld w) + ) where (a, b) = _lLine w @@ -287,25 +282,21 @@ drawFarWallDetect w = drawDDATest :: World -> Picture drawDDATest w = foldMap (drawZoneCol orange 50) ps --- runIdentity (S.foldMap_ (drawZoneCol orange 50) ps) --- <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps') --- <> runIdentity (S.foldMap_ drawCross qs) --- <> color blue (runIdentity (S.foldMap_ drawCross qs')) + -- runIdentity (S.foldMap_ (drawZoneCol orange 50) ps) + -- <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps') + -- <> runIdentity (S.foldMap_ drawCross qs) + -- <> color blue (runIdentity (S.foldMap_ drawCross qs')) <> setLayer DebugLayer (color yellow (line [cvf, mwp])) where cvf = _cameraViewFrom (_cWorld w) mwp = mouseWorldPos w --ps = ddaStreamX 50 cvf mwp ps = zoneOfSeg' 50 cvf mwp - --ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) - --qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) - --qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) -drawCross :: Point2 -> Picture -drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5 +--ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) +--qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) +--qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) -crossPic :: Float -> Picture -crossPic x = line [V2 x x, V2 (- x) (- x)] <> line [V2 (- x) x, V2 x (- x)] drawZoneCol :: Color -> Float -> V2 Int -> Picture drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p]) diff --git a/src/Dodge/Spark.hs b/src/Dodge/Spark.hs index 06a9e0ea4..c5d2b5c7c 100644 --- a/src/Dodge/Spark.hs +++ b/src/Dodge/Spark.hs @@ -7,12 +7,12 @@ module Dodge.Spark ( randSpark, ) where +import Dodge.Damage import Color import Control.Monad.State import Dodge.Data.World import Dodge.WorldEvent.ThingsHit import Geometry -import qualified IntMapHelp as IM import LensHelp import System.Random @@ -37,8 +37,7 @@ sparkDam :: World -> World sparkDam sk sp ep mayEiCrWl = case mayEiCrWl of - (hitp, Left cr) -> cWorld . creatures . ix (_crID cr) . crState . csDamage .:~ thedam hitp - (hitp, Right wl) -> cWorld . wallDamages %~ IM.insertWith (++) (_wlID wl) [thedam hitp] + (hitp, eicrwl) -> damageCrWl (thedam hitp) eicrwl where thedam hitp = Damage (_skDamageType sk) 1 sp hitp ep NoDamageEffect @@ -56,22 +55,21 @@ randColDirSpark :: World randColDirSpark randcol randdir pos w = w - & cWorld . sparks .:~ spark & randGen .~ g + & cWorld . sparks + .:~ Spark + { _skVel = rotateV dir (V2 5 0) + , _skColor = col + , _skPos = pos + , _skOldPos = pos + , _skWidth = 1 + , _skDamageType = SPARKING + } where ((col, dir), g) = (`runState` _randGen w) $ do c <- randcol d <- randdir return (c, d) - spark = - Spark - { _skVel = rotateV dir (V2 5 0) - , _skColor = col - , _skPos = pos - , _skOldPos = pos - , _skWidth = 1 - , _skDamageType = SPARKING - } randSpark :: DamageType -> diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index a55166ecb..fba008d2a 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -158,12 +158,15 @@ zoneClouds w = updateWorldSelect :: World -> World updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of - (Nothing, Nothing) -> w (Just False, Nothing) -> w & lLine . _1 .~ mwp + & lrLine . _1 .~ mwp (Just True, Nothing) -> w & lLine . _2 .~ mwp - (Nothing, _) -> w - (Just False, _) -> w & rLine . _1 .~ mwp - (Just True, _) -> w & rLine . _2 .~ mwp + & lrLine . _1 .~ mwp + (Nothing,Just False) -> w & rLine . _1 .~ mwp + & lrLine . _2 .~ mwp + (Nothing,Just True) -> w & rLine . _2 .~ mwp + & lrLine . _2 .~ mwp + _ -> w where mwp = mouseWorldPos w f diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 8641abece..a4a8c18bc 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -10,6 +10,7 @@ module Dodge.WorldEvent.ThingsHit ( thingsHitExceptCr, crsHitRadial, wlsHitRadial, + crHit, ) where import Control.Lens @@ -38,16 +39,6 @@ thingsHit sp ep w = (map (second Left) (crsHit sp ep w)) (map (second Right) (wlsHit sp ep w)) ---{- List those objects that appear on a line. -} ---thingsHit --- :: Point2 -- ^ Line start point --- -> Point2 -- ^ Line end point --- -> World --- -> StreamOf (Point2, Either Creature Wall) ---thingsHit sp ep w = void $ S.mergeOn (dist sp . fst) --- (S.map (second Left) (S.each $ crsHit sp ep w)) --- (S.map (second Right) (wlsHit sp ep w)) - crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)] crsHit sp ep w | sp == ep = mempty @@ -56,7 +47,7 @@ crsHit sp ep w . overlap1SegCrs sp ep . mapMaybe (\cid -> w ^? cWorld . creatures . ix cid) . IS.toList - . crsNearSeg sp ep + . crixsNearSeg sp ep $ w thingHitFilt :: @@ -71,16 +62,12 @@ thingHitFilt fcr fwl sp ep = List.find (f . snd) . thingsHit sp ep f (Left cr) = fcr cr f (Right wl) = fwl wl ---thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool) --- -> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) ---thingHitFilt fcr fwl sp ep = runIdentity . S.head_ . S.filter (f . snd) . thingsHit sp ep --- where --- f (Left cr) = fcr cr --- f (Right wl) = fwl wl - thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) thingHit sp ep = listToMaybe . thingsHit sp ep +crHit :: Point2 -> Point2 -> World -> Maybe (Point2,Creature) +crHit sp ep = listToMaybe . sortOn (dist sp . fst) . crsHit sp ep + {- List objects that appear on a line. Can filter out a creature. -} thingsHitExceptCr :: @@ -98,20 +85,6 @@ thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep crNotCid (_, Left cr) = _crID cr /= cid crNotCid _ = True ---{- List objects that appear on a line. ---Can filter out a creature. -} ---thingsHitExceptCr --- :: Maybe Int -- ^ A possible creature ID --- -> Point2 -- ^ Line start point --- -> Point2 -- ^ Line end point --- -> World --- -> StreamOf (Point2, Either Creature Wall) ---thingsHitExceptCr Nothing sp ep = thingsHit sp ep ---thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep --- where --- crNotCid (_,Left cr) = _crID cr /= cid --- crNotCid _ = True - wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)] wlsHit sp ep | sp == ep = const mempty @@ -120,13 +93,6 @@ wlsHit sp ep . overlapSegWalls sp ep . wlsNearSeg sp ep ---wlsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Wall) ---wlsHit sp ep --- | sp == ep = const mempty --- | otherwise = sortStreamOn (dist sp . fst) --- . overlapSegWalls sp ep --- . wlsNearSeg sp ep - wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)] wlsHitRadial p r = mapMaybe f . wlsNearCirc p r where @@ -134,13 +100,6 @@ wlsHitRadial p r = mapMaybe f . wlsNearCirc p r where v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl ---wlsHitRadial :: Point2 -> Float -> World -> StreamOf (Point2, Wall) ---wlsHitRadial p r = S.mapMaybe f . wlsInsideCirc p r --- where --- f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl) --- where --- v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl - crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)] crsHitRadial p r = mapMaybe f . crsNearCirc p r where diff --git a/src/Dodge/Zoning/Base.hs b/src/Dodge/Zoning/Base.hs index ba79a5e87..e6f327dd6 100644 --- a/src/Dodge/Zoning/Base.hs +++ b/src/Dodge/Zoning/Base.hs @@ -43,9 +43,11 @@ xIntercepts' :: Float -> Point2 -> Point2 -> [Point2] {-# INLINE xIntercepts' #-} xIntercepts' s (V2 sx sy) (V2 ex ey) | xdx == 0 = [] - | xdx > 0 = zipWith V2 [sx', sx' + xdx * 50 .. ex] ([sy', sy' + ydx * 50 .. ey] ++ repeat ey) - | otherwise = zipWith V2 [sx' -50, sx' + xdx * 50 -50 .. ex -50] ([sy', sy' + ydx * 50 .. ey] ++ repeat ey) + | otherwise = zipWith V2 [halfstep + sx', halfstep + sx' + xdx * s .. ex] ([sy', sy' + ydx * s .. ey] ++ repeat ey) where + halfstep + | xdx > 0 = -s/2 + | otherwise = s/2 xdx = signum (ex - sx) ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero sy' = sy + ydx * abs (sx - sx') diff --git a/src/Dodge/Zoning/Creature.hs b/src/Dodge/Zoning/Creature.hs index 3be20a438..5e034f944 100644 --- a/src/Dodge/Zoning/Creature.hs +++ b/src/Dodge/Zoning/Creature.hs @@ -15,8 +15,14 @@ crIXsNearPoint p w = zoneExtract (zoneOfPoint' crZoneSize p) (w ^. cWorld . crZo crsNearPoint :: Point2 -> World -> [Creature] crsNearPoint p w = mapMaybe (\cid -> w ^? cWorld . creatures . ix cid) . IS.toList $ crIXsNearPoint p w -crsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet -crsNearSeg sp ep w = zonesExtract (w ^. cWorld . crZoning) (zoneOfSeg' crZoneSize sp ep) +crsNearSeg :: Point2 -> Point2 -> World -> [Creature] +crsNearSeg sp ep w = + mapMaybe (\cid -> w ^? cWorld . creatures . ix cid) + . IS.toList + $ crixsNearSeg sp ep w + +crixsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet +crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . crZoning) (zoneOfSeg' crZoneSize sp ep) crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet crIXsNearCirc p r = crsNearRect (p +.+ V2 r r) (p -.- V2 r r)