diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index da97ea03e..ac59a61d0 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} module Dodge.Path ( pointTowardsImpulse , makePathBetween @@ -118,7 +118,7 @@ toPathEdge sp' ep = PathEdge sp' ep mempty insertEdges :: (Point2 -> Point2 -> b) -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int -> (Gr Point2 b,Map (V2 Point2) Int2) -insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ (S.each pairset) +insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ S.each pairset where insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr' , M.insert (V2 a b) (V2 (f a) (f b)) em) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index c44d8081e..2984294cc 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -9,23 +9,22 @@ import Dodge.Path import Dodge.Block.Debris --import Dodge.LevelGen.LevelStructure import Dodge.Base -import Dodge.Zone +--import Dodge.Zone import Geometry import qualified IntMapHelp as IM import Control.Lens -import Data.List import qualified Data.IntSet as IS -addBlock +placeBlock :: [Point2] -- ^ Block polygon - -> Wall -- ^ Base Pane -> Block + -> Wall -- ^ Base Pane -> World - -> World -addBlock (p:ps) wl bl w = w - & wlZoning . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes - & walls %~ IM.union panes + -> (Int,World) +placeBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" +placeBlock (p:ps) bl wl w = (,) blid $ w + & flip (foldr insertWall) wls & blocks %~ IM.insert blid bl {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[] , _blFootprint = p:ps @@ -35,32 +34,14 @@ addBlock (p:ps) wl bl w = w lns = zip (p:ps) (ps ++ [p]) i = IM.newKey $ _walls w is = [i.. i + length lns-1] - panes = IM.fromList $ zipWith - (\j (a,b) -> (,) j wl + wls = zipWith + (\j (a,b) -> wl { _wlLine = (a,b) , _wlID = j , _wlStructure = BlockPart blid } - ) is lns - wallInZone wl' - | uncurry dist (_wlLine wl') <= 2*wlZoneSize - = insertIMInZone x y wlid wl' - | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips - where - V2 x y = wlZoneOfPoint $ uncurry midPoint (_wlLine wl) - wlid = _wlID wl - ips = map (unv2 . wlZoneOfPoint) $ uncurry (divideLine (2*wlZoneSize)) (_wlLine wl) - unv2 (V2 x' y') = (x',y') -addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon" + ) is lns -placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World) -placeBlock poly bl wl w - = (0, foldr (uncurry (addObstacleCrossing' BlockObstacle)) wWithBlock pairs) --- = (0, wWithBlock) - where - pairs = loopPairs poly - wWithBlock = addBlock poly wl bl w - {- | Splits a line into many four cornered blocks. -} placeLineBlock :: Wall -- ^ Base pane @@ -71,8 +52,7 @@ placeLineBlock -> World -> (Int, World) placeLineBlock basePane blockWidth depth a b gw = ( 0 --- , (foldr insertWall (insertBlocks gw) listWalls) - , addObstacleCrossing' BlockObstacle a b (foldr insertWall (insertBlocks gw) listWalls) + , foldr insertWall (insertBlocks gw) listWalls ) where psOnLine = divideLineOddNumPoints blockWidth a b @@ -109,4 +89,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0 ,_wlDraw = visStatus } listWalls = concat $ zipWith makeWallAt blockCenPs is - insertWall wl = over walls $ IM.insert (_wlID wl) wl + +insertWall :: Wall -> World -> World +insertWall wl = (walls . at (_wlID wl) ?~ wl) + . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 580985db0..99c7e85c8 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -35,6 +35,7 @@ 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 @@ -119,9 +120,13 @@ drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w) drawPathBetween :: World -> Picture -drawPathBetween w = color yellow - $ foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w) +drawPathBetween w = setLayer DebugLayer + $ color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist) + <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0) + <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just) where + nodepos = (`getNodePos` w) + nodelist = makePathBetween sp ep w sp = _lSelect w ep = _rSelect w @@ -274,17 +279,21 @@ edgeToPic :: [Point2] -> PathEdge -> Picture edgeToPic poly pe | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty | null $ _peObstacles pe - = color green $ arrow sp ep - | otherwise = color red $ arrow sp ep + = 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 = setLayer DebugLayer $ - (foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) $ FGL.labEdges gr) - --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w) - <> concatMap dispInc (graphToIncidence gr) +drawPathing cfig w = setLayer DebugLayer + $ 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 = _pgGraph $ _pathGraph w diff --git a/src/Picture.hs b/src/Picture.hs index b83a27345..8f0f26bac 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} +--{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE BangPatterns #-} module Picture ( module Picture.Data , module Picture.Base