126 lines
4.1 KiB
Haskell
126 lines
4.1 KiB
Haskell
-- | Creation, update and destruction of destructible walls.
|
|
module Dodge.Placement.PlaceSpot.Block (
|
|
plBlock,
|
|
plLineBlock,
|
|
) where
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Control.Lens
|
|
import qualified Data.IntSet as IS
|
|
import Data.List
|
|
import Dodge.Base
|
|
import Dodge.Data.World
|
|
import Dodge.Path
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
|
|
plBlock ::
|
|
-- | Block polygon
|
|
[Point2] ->
|
|
Block ->
|
|
-- | Base Pane
|
|
Wall ->
|
|
World ->
|
|
(Int, World)
|
|
plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
|
|
plBlock (p : ps) bl wl w =
|
|
(,) blid $
|
|
w
|
|
& cWorld . lWorld . blocks . at blid
|
|
?~ bl
|
|
{ _blID = blid
|
|
, _blWallIDs = IS.fromList is
|
|
, _blShadows = []
|
|
, _blFootprint = p : ps
|
|
}
|
|
& insertWalls blid wls
|
|
where
|
|
blid = IM.newKey $ w ^. cWorld . lWorld . blocks
|
|
lns = zip (p : ps) (ps ++ [p])
|
|
i = IM.newKey $ w ^. cWorld . lWorld . walls
|
|
is = [i .. i + length lns -1]
|
|
wls =
|
|
zipWith
|
|
(\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid)
|
|
is
|
|
lns
|
|
|
|
-- | Splits a line into many four cornered blocks.
|
|
plLineBlock ::
|
|
-- | Base pane
|
|
Wall ->
|
|
Float ->
|
|
-- | Start point (symmetric)
|
|
Point2 ->
|
|
-- | End point (symmetric)
|
|
Point2 ->
|
|
World ->
|
|
(Int, World)
|
|
plLineBlock basePane blwidth a b gw =
|
|
( 0
|
|
, -- , foldr insertWall (insertBlocks gw) listWalls
|
|
insertBlocks gw
|
|
)
|
|
where
|
|
depth = blwidth
|
|
psOnLine = divideLineOddNumPoints blwidth 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 $ gw ^. cWorld . lWorld . walls
|
|
blid = IM.newKey $ gw ^. cWorld . lWorld . blocks
|
|
insertBlock (i, p) =
|
|
insertWalls (i + blid) (makeWallAt p i)
|
|
. over
|
|
(cWorld . lWorld . blocks)
|
|
( IM.insert
|
|
(i + blid)
|
|
Block
|
|
{ _blID = i + blid
|
|
, _blWallIDs = IS.fromList $ ksAtI i
|
|
, _blHP = 1000
|
|
, _blShadows = shadowsAt i
|
|
, _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
|
|
, _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
|
|
, _blObstructs = mempty
|
|
, _blMaterial = _wlMaterial basePane
|
|
, _blHeight = 100
|
|
, _blPos = p
|
|
, _blDraw = BlockDrawMempty
|
|
}
|
|
)
|
|
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
|
|
, _wlUnshadowed = visStatus
|
|
}
|
|
|
|
-- | Must be done after inserting the block
|
|
insertWalls :: Int -> [Wall] -> World -> World
|
|
insertWalls blid wls w = w' & cWorld . lWorld . blocks . ix blid . blObstructs .~ Set.unions paths
|
|
where
|
|
(w', paths) = mapAccumR (flip insertWall) w wls
|
|
|
|
insertWall :: Wall -> World -> (World, Set PathEdgeNodes)
|
|
insertWall wl =
|
|
uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
|
|
. (cWorld . lWorld . walls . at (_wlID wl) ?~ wl)
|