diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index c2fd5ede5..f3c6c590b 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1406,7 +1406,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutMod Modification | PutTrigger (World -> Bool) | PutLineBlock {_putWall :: Wall , _putWidth :: Float - , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2} + , _putStartPoint :: Point2, _putEndPoint :: Point2} | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutSlideDr Door Wall Float Point2 Point2 | PutDoor Color (World -> Bool) [(Point2,Point2)] diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index 69fe1c1e2..500dd0f37 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -35,23 +35,22 @@ singleBlock a = ] {- Places a line of blocks between two points. -Width 9, also extends out from each point by 9. -} blockLine :: Point2 -> Point2 -> Placement -blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b +blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 a b {- Places an breakable window between two points. Width 8, also extends out from each point by 8. -} windowLine :: Point2 -> Point2 -> Placement -windowLine a b = sps0 $ PutLineBlock defaultWindow 8 8 a b +windowLine a b = sps0 $ PutLineBlock defaultWindow 8 a b {- Places an unbreakable window between two points. Width 7, also extends out from each point by 7. -} crystalLine :: Point2 -> Point2 -> Placement -crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 7 a b +crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 a b --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall -- where -- ps = @@ -77,7 +76,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall up = vNormal left windowLineType :: Point2 -> Point2 -> PSType -windowLineType = PutLineBlock defaultWindow 8 8 +windowLineType = PutLineBlock defaultWindow 8 baseBlockPane :: Wall baseBlockPane = defaultWall @@ -124,7 +123,7 @@ putBlockRect' w h = ps0jPushPS (aline tl tr) tr = V2 w h br = V2 w (-h) bl = V2 (-w) (-h) - aline = PutLineBlock baseBlockPane 9 9 + aline = PutLineBlock baseBlockPane 9 putBlockRect :: Float -> Float -> Float -> Float -> [Placement] putBlockRect a x b y = diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 5663cb04f..c65e3220d 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -99,9 +99,9 @@ placeSpotID ps pt w = case pt of PutCoord cp -> plNewID coordinates (doShift cp) w PutSlideDr wl dr off a b -> plSlideDoor wl dr off (doShift a) (doShift b) w - PutBlock bl wl ps' -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) + PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) wl w - PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w + PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w) PutNothing -> (0,w) PutID i -> (i, w) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 1aa411e7a..644fb0845 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -1,7 +1,7 @@ {- | Creation, update and destruction of destructible walls. -} module Dodge.Placement.PlaceSpot.Block - ( placeBlock - , placeLineBlock + ( plBlock + , plLineBlock ) where import Dodge.Data @@ -17,63 +17,45 @@ import Control.Lens import Data.List import qualified Data.IntSet as IS -addBlock +plBlock :: [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 - & blocks %~ IM.insert blid bl - {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[] - , _blFootprint = p:ps - } + -> (Int,World) +plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" +plBlock (p:ps) bl wl w = (,) blid $ w + & flip (foldr insertWall) wls + & blocks . at blid ?~ bl + { _blID = blid + , _blWallIDs = IS.fromList is + , _blShadows = [] + , _blFootprint = p:ps + } where blid = IM.newKey $ _blocks 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 - { _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" + wls = zipWith + (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) + is + lns -placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World) -placeBlock poly bl wl w - = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) - where - pairs = loopPairs poly - wWithBlock = addBlock poly wl bl w - {- | Splits a line into many four cornered blocks. -} -placeLineBlock +plLineBlock :: Wall -- ^ Base pane - -> Float -- ^ Block width - -> Float -- ^ Block depth + -> Float -> Point2 -- ^ Start point (symmetric) -> Point2 -- ^ End point (symmetric) -> World -> (Int, World) -placeLineBlock basePane blockWidth depth a b gw = ( 0 - , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls) +plLineBlock basePane blwidth a b gw = ( 0 + , foldr insertWall (insertBlocks gw) listWalls ) where - psOnLine = divideLineOddNumPoints blockWidth a b + depth = blwidth + psOnLine = divideLineOddNumPoints blwidth a b halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1) blockCenPs = snd $ evenOddSplit psOnLine numBlocks = length blockCenPs @@ -108,4 +90,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/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs index dc93bb1cb..62558e503 100644 --- a/src/Dodge/Room/Pillar.hs +++ b/src/Dodge/Room/Pillar.hs @@ -30,7 +30,7 @@ blockPillar w' h' = ps0jPushPS (aline tl tr) tr = V2 w h br = V2 w (-h) bl = V2 (-w) (-h) - aline = PutLineBlock baseBlockPane 9 9 + aline = PutLineBlock baseBlockPane 9 smallPillar :: PSType smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5 @@ -41,7 +41,7 @@ crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0)) where w = w' - 9 h = h' - 9 - aline = PutLineBlock baseBlockPane 9 9 + aline = PutLineBlock baseBlockPane 9 roomPillarsSquare :: RandomGen g => State g Room roomPillarsSquare = do