diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index 09cef2ffa..a3f216a0a 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -21,7 +21,7 @@ data Configuration = Configuration , _windowPosY :: Int , _gameplay_rotate_to_wall :: Bool , _debug_view_clip_bounds :: RoomClipping - , _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet + , _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet } deriving (Generic, Show) data DebugBool @@ -44,6 +44,8 @@ data DebugBool | Show_far_wall_detect | Show_select | Inspect_wall + | Show_nodes_near_select + | Show_path_between deriving (Generic, Eq,Ord,Bounded, Enum, Show) data ResFactor = FullRes | HalfRes | QuarterRes deriving (Generic, Show, Eq, Ord, Enum, Bounded) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index b290260d7..cb82f08f7 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -172,7 +172,10 @@ data World = World , _genRooms :: IM.IntMap Room , _deathDelay :: Maybe Int , _testFloat :: Float - , _wSelect :: (Point2,Point2) + , _lLine :: (Point2,Point2) + , _rLine :: (Point2,Point2) + , _lSelect :: Point2 + , _rSelect :: Point2 } data WorldHammer = SubInvHam diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 41420c833..53746c236 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -4,6 +4,7 @@ import Dodge.Zone.Size import Dodge.Zone.Object import Dodge.Base import Geometry.Vector3D +import Geometry.Zone --import Dodge.Config.KeyConfig --import Dodge.Menu --import Picture @@ -18,6 +19,7 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Map as M import qualified Data.Set as S import Data.Graph.Inductive.Graph hiding ((&)) +--import Data.Graph.Inductive.NodeMap --import qualified Data.Vector.Fusion.Stream.Monadic as VS defaultWorld :: World defaultWorld = World @@ -111,7 +113,10 @@ defaultWorld = World , _testFloat = 0 , _boundBox = square 100 , _boundDist = (100,-100,100,-100) - , _wSelect = (0,0) + , _lLine = (0,0) + , _rLine = (0,0) + , _lSelect = 0 + , _rSelect = 0 } defaultWorldHammers :: M.Map WorldHammer HammerPosition defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound] diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index fe3045588..75b42a4da 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -16,6 +16,8 @@ import Dodge.Graph import Dodge.GameRoom import Dodge.Update.Camera import Dodge.Item.Draw +import Dodge.Render.List +import Dodge.Path --import Dodge.Zone import Geometry import Geometry.Zone @@ -28,9 +30,12 @@ import Geometry.ConvexPoly --import Data.Foldable import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.Map.Strict as M +--import qualified Data.Set as Set import Control.Lens import Data.Maybe import qualified Streaming.Prelude as S +import qualified Data.Graph.Inductive as FGL +import qualified Data.Set as Set -- TODO only filter out shapes outside the range of the furthest shown light source worldSPic :: Configuration -> World -> SPic @@ -76,34 +81,54 @@ extraPics cfig w = pictures (_decorations w) -- <> runIdentity (S.foldMap_ clDraw (_clouds w)) <> concatMapPic clDraw (_clouds w ) <> concatMapPic ppDraw (_pressPlates w ) - <> soundPics cfig w <> viewClipBounds cfig w - <> drawMousePosition cfig w - <> drawWallIDs cfig w - <> drawPathing cfig w - <> drawCrInfo cfig w - <> cfigdraw View_boundaries (const viewBoundaries) - <> cfigdraw Show_bound_box (const drawBoundingBox) - <> cfigdraw Show_wall_search_rays (const drawWallSearchRays) - <> cfigdraw Show_dda_test (const drawDDATest) - <> cfigdraw Show_far_wall_detect (const drawFarWallDetect) - <> cfigdraw Show_select (const drawWorldSelect) - <> cfigdraw Inspect_wall (const drawInspectWalls) - <> cfigdraw Cr_awareness (const drawCreatureDisplayTexts) + <> debugDraw cfig w + +debugDraw :: Configuration -> World -> Picture +debugDraw cfig w = pic + <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts) where - cfigdraw boption draw - | debugOn boption cfig = draw cfig w - | otherwise = mempty + (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig) + f (Left s) = ([s],mempty) + f (Right pic') = (mempty,pic') + +debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture +debugDraw' cfig w bl = case bl of + Noclip -> Left "Noclip" + Remove_LOS -> Left "No line of sight" + Cull_more_lights -> Left "Cull more lights" + Close_shape_culling -> Left "Close shape culling" + Bound_box_screen -> Left "bound box screen, this should be moved" + Show_ms_frame -> Right mempty + View_boundaries -> Right $ viewBoundaries w + Show_bound_box -> Right $ drawBoundingBox w + Show_wall_search_rays -> Right $ drawWallSearchRays w + Show_dda_test -> Right $ drawDDATest w + Show_far_wall_detect -> Right $ drawFarWallDetect w + Show_select -> Right $ drawWorldSelect w + Inspect_wall -> Right $ drawInspectWalls w + Cr_awareness -> Right $ drawCreatureDisplayTexts w + Show_sound -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w + Cr_status -> Right $ drawCrInfo cfig w + Mouse_position -> Right $ drawMousePosition cfig w + Walls_info -> Right $ drawWlIDs cfig w + Pathing -> Right $ drawPathing cfig w + Show_nodes_near_select -> Right $ drawNodesNearSelect w + Show_path_between -> Right $ drawPathBetween w drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w) +drawPathBetween :: World -> Picture +drawPathBetween _ = mempty +drawNodesNearSelect :: World -> Picture +drawNodesNearSelect _ = mempty drawInspectWalls :: World -> Picture drawInspectWalls w = foldMap (drawInspectWall w) $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $ IM.elems $ _walls w where - (a,b) = _wSelect w + (a,b) = _lLine w drawInspectWall :: World -> Wall -> Picture drawInspectWall _ wl = setLayer DebugLayer $ @@ -117,10 +142,12 @@ drawInspectWall _ wl = setLayer DebugLayer $ -- (a,b) = _wSelect w drawWorldSelect :: World -> Picture -drawWorldSelect w = setLayer DebugLayer . color cyan - $ line [a,b] +drawWorldSelect w = setLayer DebugLayer + $ color cyan (line [a,b]) + <> color magenta (line [c,d]) where - (a,b) = _wSelect w + (a,b) = _lLine w + (c,d) = _rLine w drawFarWallDetect :: World -> Picture drawFarWallDetect w = setLayer DebugLayer @@ -196,11 +223,6 @@ mcSPic :: Machine -> SPic mcSPic bt = uncurryV translateSPf (_mcPos bt) $ rotateSP (_mcDir bt) (_mcDraw bt bt) -soundPics :: Configuration -> World -> Picture -soundPics cfig w - | debugOn Show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w - | otherwise = [] - soundPic :: Configuration -> World -> Sound -> Picture soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w where @@ -215,23 +237,17 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w f x = 1 - 0.5 * (1 - x) drawMousePosition :: Configuration -> World -> Picture -drawMousePosition cfig w - | not $ debugOn Mouse_position cfig = mempty - | otherwise - = setLayer FixedCoordLayer . winScale cfig - . uncurryV translate p - . scale 0.1 0.1 - . text - $ shortPoint2 mwp +drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig + . uncurryV translate p + . scale 0.1 0.1 + . text + $ shortPoint2 mwp where p = worldPosToScreen w mwp mwp = mouseWorldPos w -drawWallIDs :: Configuration -> World -> Picture -drawWallIDs cfig w - | debugOn Walls_info cfig = setLayer FixedCoordLayer - $ foldMap f (_walls w) - | otherwise = mempty +drawWlIDs :: Configuration -> World -> Picture +drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w) where f wl | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test" @@ -243,16 +259,28 @@ drawWallIDs cfig w where p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl) +--edgeToPic :: [Point2] -> PathEdge -> Picture +--edgeToPic poly pe +-- | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty +-- | null $ _peObstacles pe +-- = anarrow green +-- | hasobstacle BlockObstacle +-- = anarrow red +-- | hasobstacle AutoDoorObstacle = anarrow yellow +-- | otherwise = anarrow cyan +-- where +-- hasobstacle = (`Set.member` _peObstacles pe) +-- anarrow col = color col $ arrow sp ep +-- sp = _peStart pe +-- ep = _peEnd pe + drawPathing :: Configuration -> World -> Picture -drawPathing cfig w - | debugOn Pathing cfig - = setLayer DebugLayer $ - (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr) - <> concatMap dispInc (graphToIncidence gr) - | otherwise = [] - where - dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n - gr = _pathGraph w +drawPathing cfig w = setLayer DebugLayer mempty +-- $ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr) +-- <> concatMap dispInc (graphToIncidence gr) +-- where +-- dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n +-- gr = _pathGraph w crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String]) crDisplayInfo cfig w cr @@ -274,11 +302,9 @@ crDisplayInfo cfig w cr crOnScreen = pointOnScreen cfig w $ _crPos cr drawCrInfo :: Configuration -> World -> Picture -drawCrInfo cfig w - | debugOn Cr_status cfig = setLayer FixedCoordLayer +drawCrInfo cfig w = setLayer FixedCoordLayer $ renderInfoListsAt (2*hw - 400) 0 cfig w $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w - | otherwise = mempty where hw = halfWidth cfig diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index af3ccbf32..869dfc33e 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -103,10 +103,19 @@ zoneClouds w = w & clZoning %~ \zn -> --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w)) updateWorldSelect :: World -> World -updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of - Nothing -> w - Just False -> w & wSelect . _1 .~ mouseWorldPos w - Just True -> w & wSelect . _2 .~ mouseWorldPos w +updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of + (Nothing ,Nothing) -> w + (Just False,Nothing) -> w & lLine . _1 .~ mwp + (Just True ,Nothing) -> w & lLine . _2 .~ mwp + (Nothing ,_) -> w + (Just False,_) -> w & rLine . _1 .~ mwp + (Just True ,_) -> w & rLine . _2 .~ mwp + where + mwp = mouseWorldPos w + f | ButtonLeft `M.member` _mouseButtons w = lSelect .~ mwp + | otherwise = id + g | ButtonRight `M.member` _mouseButtons w = rSelect .~ mwp + | otherwise = id mcChooseUpdate :: Machine -> Machine -> World -> World mcChooseUpdate mc mc'