justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Commit before adjusting wall zoning

Browse Source
This commit is contained in:
justin
2022-07-01 09:17:22 +01:00
parent 4e893931a8
commit 870225b6b6
8 changed files with 40 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+2 -2
View File
@@ -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)]
src/Dodge/Data/PathGraph.hs
+1 -1
View File
@@ -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
src/Dodge/Default/Block.hs
+1
View File
@@ -14,6 +14,7 @@ defaultBlock = Block
, _blDir = 0
, _blDraw = const mempty
, _blDeath = makeBlockDebris
, _blObstructs = []
}
defaultDirtBlock :: Block
defaultDirtBlock = defaultBlock & blHP .~ 50
src/Dodge/Path.hs
+3 -2
View File
@@ -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)
src/Dodge/Placement/Instance/Wall.hs
+5 -6
View File
@@ -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 =
src/Dodge/Placement/PlaceSpot.hs
+2 -2
View File
@@ -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)
src/Dodge/Placement/PlaceSpot/Block.hs
+20 -20
View File
@@ -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]
src/Dodge/Room/Pillar.hs
+6 -6
View File
@@ -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