diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 794f7dac5..09cbdfde1 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -948,6 +948,7 @@ data Block = Block , _blHP :: Int , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists , _blFootprint :: [Point2] + , _blObstructs :: [(Point2,Point2)] , _blPos :: Point2 , _blDir :: Float , _blDraw :: Block -> SPic @@ -1408,8 +1409,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutCoord Point2 | PutMod Modification | PutTrigger (World -> Bool) - | PutLineBlock {_putWall :: Wall , _putWidth :: Float - , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2} + | PutLineBlock {_putWall :: Wall , _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/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs index 913282282..d6f751844 100644 --- a/src/Dodge/Data/PathGraph.hs +++ b/src/Dodge/Data/PathGraph.hs @@ -10,7 +10,7 @@ data PathGraph = PathGraph { _pgGraph :: Gr Point2 PathEdge , _pgNodeMap :: Map Point2 Int , _pgNodeCount :: Int - , _pgEdgeMap :: Map (V2 Point2) Int2 + , _pgEdgeMap :: Map (V2 Point2) (Int,Int,PathEdge) } data PathEdge = PathEdge {_peStart :: Point2 diff --git a/src/Dodge/Default/Block.hs b/src/Dodge/Default/Block.hs index 8d5941d77..c7813c4c8 100644 --- a/src/Dodge/Default/Block.hs +++ b/src/Dodge/Default/Block.hs @@ -14,6 +14,7 @@ defaultBlock = Block , _blDir = 0 , _blDraw = const mempty , _blDeath = makeBlockDebris + , _blObstructs = [] } defaultDirtBlock :: Block defaultDirtBlock = defaultBlock & blHP .~ 50 diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index ac59a61d0..178151f82 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -117,11 +117,12 @@ toPathEdge :: Point2 -> Point2 -> PathEdge 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) + -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int + -> (Gr Point2 b, Map (V2 Point2) (Int,Int,b)) 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) + , M.insert (V2 a b) (f a,f b,efunc a b) em) f a = nm M.! a insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int) diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index 69fe1c1e2..328525219 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 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 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 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 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 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 9ad5bb90a..1c344a545 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 a b -> plLineBlock wl (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 2984294cc..ef5522996 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 @@ -16,46 +16,45 @@ import qualified IntMapHelp as IM import Control.Lens import qualified Data.IntSet as IS -placeBlock +plBlock :: [Point2] -- ^ Block polygon -> Block -> Wall -- ^ Base Pane -> World -> (Int,World) -placeBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" -placeBlock (p:ps) bl wl w = (,) blid $ w +plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" +plBlock (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 - } + & 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] wls = zipWith - (\j (a,b) -> wl - { _wlLine = (a,b) - , _wlID = j - , _wlStructure = BlockPart blid - } - ) is lns + (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) + is + lns {- | Splits a line into many four cornered blocks. -} -placeLineBlock +plLineBlock :: Wall -- ^ Base pane - -> Float -- ^ Block width - -> Float -- ^ Block depth -> Point2 -- ^ Start point (symmetric) -> Point2 -- ^ End point (symmetric) -> World -> (Int, World) -placeLineBlock basePane blockWidth depth a b gw = ( 0 +plLineBlock basePane a b gw = ( 0 , foldr insertWall (insertBlocks gw) listWalls ) where - psOnLine = divideLineOddNumPoints blockWidth a b + blwidth = 10 + depth = 10 + psOnLine = divideLineOddNumPoints blwidth a b halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1) blockCenPs = snd $ evenOddSplit psOnLine numBlocks = length blockCenPs @@ -70,6 +69,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0 , _blHP = 1000, _blShadows = shadowsAt i , _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise) + , _blObstructs = [] , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris} insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3] diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs index 04c376569..880e87e0d 100644 --- a/src/Dodge/Room/Pillar.hs +++ b/src/Dodge/Room/Pillar.hs @@ -24,13 +24,13 @@ blockPillar w' h' = ps0jPushPS (aline tl tr) $ ps0jPushPS (aline br bl) $ sps0 (aline bl tl) where - w = w' - 9 - h = h' - 9 + w = w' - 10 + h = h' - 10 tl = V2 (-w) h tr = V2 w h br = V2 w (-h) bl = V2 (-w) (-h) - aline = PutLineBlock baseBlockPane 9 9 + aline = PutLineBlock baseBlockPane smallPillar :: PSType smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5 @@ -39,9 +39,9 @@ crossPillar :: Float -> Float -> Placement crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0)) $ sps0 (aline (V2 0 (-h)) (V2 0 h)) where - w = w' - 9 - h = h' - 9 - aline = PutLineBlock baseBlockPane 9 9 + w = w' - 10 + h = h' - 10 + aline = PutLineBlock baseBlockPane roomPillarsSquare :: RandomGen g => State g Room roomPillarsSquare = do