Redo more complex selection positions--results in slowdown

src/Dodge/Config/Data.hs

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

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

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]

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
+    <> debugDraw cfig w
-    <> drawWallIDs cfig w
+
-    <> drawPathing cfig w
+debugDraw :: Configuration -> World -> Picture
-    <> drawCrInfo cfig w
+debugDraw cfig w = pic
-    <> cfigdraw View_boundaries (const viewBoundaries)
+    <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
-    <> 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)
   where
-    cfigdraw boption draw
+    (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig)
-        | debugOn boption cfig = draw cfig w
+    f (Left s) = ([s],mempty)
-        | otherwise = 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 
+drawWorldSelect w = setLayer DebugLayer
-    $ line [a,b]
+    $  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,10 +237,7 @@ 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
+drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
-    | not $ debugOn Mouse_position cfig = mempty
-    | otherwise
-        = setLayer FixedCoordLayer . winScale cfig
     . uncurryV translate p
     . scale 0.1 0.1
     . text 
@@ -227,11 +246,8 @@ drawMousePosition cfig w
     p = worldPosToScreen w mwp
     mwp = mouseWorldPos w
 
-drawWallIDs :: Configuration -> World -> Picture
+drawWlIDs :: Configuration -> World -> Picture
-drawWallIDs cfig w 
+drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
-    | debugOn Walls_info cfig = setLayer FixedCoordLayer 
-        $ foldMap f (_walls w)
-    | otherwise = mempty
   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
+drawPathing cfig w = setLayer DebugLayer mempty
-    | debugOn Pathing cfig 
+--    $  foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
-        = setLayer DebugLayer $ 
+--    <> concatMap dispInc (graphToIncidence gr)
-        (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
+--  where
-        <> concatMap dispInc (graphToIncidence gr)
+--    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
-    | otherwise = []
+--    gr = _pathGraph w
-  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
+drawCrInfo cfig w = setLayer FixedCoordLayer 
-    | debugOn Cr_status cfig = setLayer FixedCoordLayer 
         $ renderInfoListsAt (2*hw - 400) 0 cfig w
         $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
-    | otherwise = mempty
   where
     hw = halfWidth cfig
 

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
+updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of
-    Nothing     -> w
+    (Nothing   ,Nothing)  -> w
-    Just False  -> w & wSelect . _1 .~ mouseWorldPos w
+    (Just False,Nothing)  -> w & lLine . _1 .~ mwp
-    Just True   -> w & wSelect . _2 .~ mouseWorldPos w
+    (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'