Redo more complex selection positions--results in slowdown

2022-07-01 16:23:05 +01:00
parent 207d52a719
commit 9e9c449fe6
5 changed files with 102 additions and 57 deletions
@@ -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)
@@ -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
@@ -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]
@@ -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

@@ -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'