115 lines
4.3 KiB
Haskell
115 lines
4.3 KiB
Haskell
{- | Creation, update and destruction of destructible walls. -}
|
|
module Dodge.Placement.PlaceSpot.Block
|
|
( placeBlock
|
|
, placeLineBlock
|
|
)
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Path
|
|
import Dodge.Block.Debris
|
|
--import Dodge.LevelGen.LevelStructure
|
|
import Dodge.Base
|
|
import Dodge.Zone
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
|
|
import Control.Lens
|
|
import Data.List
|
|
import qualified Data.IntSet as IS
|
|
|
|
addBlock
|
|
:: [Point2] -- ^ Block polygon
|
|
-> Wall -- ^ Base Pane
|
|
-> Int -- ^ First layer of health
|
|
-> [Int] -- ^ Extra layers of health
|
|
-> BlockMaterial
|
|
-> World
|
|
-> World
|
|
addBlock (p:ps) wl hp hps bm w
|
|
| hp <= 0 && null hps = w
|
|
| hp <= 0 = addBlock (p:ps) wl (head hps + hp) (tail hps) bm w
|
|
| otherwise = w
|
|
& wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
|
|
& walls %~ IM.union panes
|
|
& blocks %~ IM.insert blid Block
|
|
{_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[], _blMaterial = bm
|
|
, _blFootprint = p:ps, _blPos = centroid (p:ps), _blDraw = const mempty
|
|
, _blDeath = makeBlockDebris bm}
|
|
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*zoneSize
|
|
= insertIMInZone x y wlid wl'
|
|
| otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
|
|
where
|
|
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
|
|
wlid = _wlID wl
|
|
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
|
|
addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
|
|
|
|
placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> World -> (Int,World)
|
|
placeBlock poly i wl is bm w
|
|
= (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
|
|
where
|
|
pairs = loopPairs poly
|
|
wWithBlock = addBlock poly wl i is bm w
|
|
|
|
{- | Splits a line into many four cornered blocks. -}
|
|
placeLineBlock
|
|
:: Wall -- ^ Base pane
|
|
-> BlockMaterial
|
|
-> Float -- ^ Block width
|
|
-> Float -- ^ Block depth
|
|
-> Point2 -- ^ Start point (symmetric)
|
|
-> Point2 -- ^ End point (symmetric)
|
|
-> World
|
|
-> (Int, World)
|
|
placeLineBlock basePane bm blockWidth depth a b gw = ( 0
|
|
, removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
|
|
)
|
|
where
|
|
psOnLine = divideLineOddNumPoints blockWidth a b
|
|
halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
|
|
blockCenPs = snd $ evenOddSplit psOnLine
|
|
numBlocks = length blockCenPs
|
|
is = [0.. numBlocks - 1]
|
|
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
|
|
cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
|
|
linesAt p = loopPairs $ cornersAt p
|
|
wlid = IM.newKey $ _walls gw
|
|
blid = IM.newKey $ _blocks gw
|
|
insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block
|
|
{ _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
|
|
, _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm
|
|
, _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
|
|
, _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris bm}
|
|
insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
|
|
ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
|
|
visibilityAt i
|
|
| i == 0 = [False,True,True ,True]
|
|
| i == numBlocks - 1 = [True ,True,False,True]
|
|
| otherwise = [False,True,False,True]
|
|
shadowsAt i
|
|
| i == 0 = ksAtI 1
|
|
| i == numBlocks - 1 = ksAtI $ numBlocks - 2
|
|
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
|
|
makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
|
|
makePane i visStatus k ps = basePane
|
|
{_wlID = k
|
|
,_wlStructure = BlockPart $ i + blid
|
|
,_wlLine = ps
|
|
,_wlDraw = visStatus
|
|
}
|
|
listWalls = concat $ zipWith makeWallAt blockCenPs is
|
|
insertWall wl = over walls $ IM.insert (_wlID wl) wl
|