Cleanup and reorganise
This commit is contained in:
@@ -1,6 +1,7 @@
|
||||
{- | Creation, update and destruction of destructible walls. -}
|
||||
module Dodge.LevelGen.Block
|
||||
( putBlock
|
||||
, putLineBlock
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
@@ -60,3 +61,49 @@ putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock
|
||||
pairs = zip (p:ps) (ps ++ [p])
|
||||
wWithBlock = addBlock (p:ps) i c b is w
|
||||
putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon"
|
||||
|
||||
{- | Splits a line into many four cornered blocks. -}
|
||||
putLineBlock
|
||||
:: Wall -- ^ Base pane
|
||||
-> Float -- ^ Block width
|
||||
-> Float -- ^ Block depth
|
||||
-> Point2 -- ^ Start point (symmetric)
|
||||
-> Point2 -- ^ End point (symmetric)
|
||||
-> World
|
||||
-> (Int, World)
|
||||
putLineBlock basePane blockWidth depth a b w = (,) 0
|
||||
$ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
|
||||
where
|
||||
d = dist a b
|
||||
rot = argV (b -.- a)
|
||||
psOnLine = divideLineOddNumPoints blockWidth a b
|
||||
halfBlockWidth = d / 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 rot) cornerPoints
|
||||
linesAt p = makeLoopPairs $ cornersAt p
|
||||
k = IM.newKey $ _walls w
|
||||
blid = IM.newKey $ _blocks w
|
||||
insertBlock i = over blocks $ IM.insert (i+blid) Block
|
||||
{_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
|
||||
insertBlocks = flip (foldr insertBlock) is
|
||||
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
|
||||
visibilityAt i
|
||||
| i == 0 = [ True,True,False,True]
|
||||
| i == numBlocks - 1 = [False,True, True,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'
|
||||
,_wlBlockID = Just' $ i + blid
|
||||
,_wlLine = ps
|
||||
,_wlDraw = visStatus
|
||||
}
|
||||
listWalls = concat $ zipWith makeWallAt blockCenPs is
|
||||
insertWall wl = over walls $ IM.insert (_wlID wl) wl
|
||||
|
||||
@@ -1,12 +1,9 @@
|
||||
module Dodge.LevelGen.DoorPane
|
||||
( rectanglePairs
|
||||
) where
|
||||
--import Dodge.Data
|
||||
import Geometry.Vector
|
||||
import Geometry.Data
|
||||
|
||||
|
||||
|
||||
rectanglePairs :: Float -> Point2 -> Point2 -> [(Point2,Point2)]
|
||||
rectanglePairs wdth a b =
|
||||
[ (aup, ad)
|
||||
|
||||
@@ -1,44 +0,0 @@
|
||||
module Dodge.LevelGen.InnerWalls
|
||||
where
|
||||
--import Dodge.Data
|
||||
--import Dodge.Base
|
||||
--import Geometry
|
||||
|
||||
--import Control.Lens
|
||||
--import qualified Data.IntMap.Strict as IM
|
||||
------------------------------------------------------------------------------------
|
||||
-- idea: create inner walls to draw and to cast shadows
|
||||
--createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
||||
--createInnerWalls wls = IM.map (createInnerWall wls) wls
|
||||
--
|
||||
--createInnerWall :: IM.IntMap Wall -> Wall -> Wall
|
||||
--createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
|
||||
-- where wl0 = _wlLine wl !! 0
|
||||
-- wl1 = _wlLine wl !! 1
|
||||
-- wlLeft = findWallLeft wl walls
|
||||
-- wlRight = findWallRight wl walls
|
||||
-- wlN = normalizeV $ vNormal $ wl1 -.- wl0
|
||||
-- rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0)
|
||||
-- lN = normalizeV $ vNormal $ (_wlLine wlLeft !! 1) -.- (_wlLine wlLeft !! 0)
|
||||
-- wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN)
|
||||
-- wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN)
|
||||
--
|
||||
--findWallLeft :: Wall -> IM.IntMap Wall -> Wall
|
||||
--findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
|
||||
-- [w] -> w
|
||||
-- wls -> error $ "findWallLeft: " ++ show (map _wlID wls)
|
||||
-- ++ " wlLines: "++ show (map _wlLine wls)
|
||||
--
|
||||
--findWallRight :: Wall -> IM.IntMap Wall -> Wall
|
||||
--findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
|
||||
-- [w] -> w
|
||||
-- wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
|
||||
-- show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
|
||||
-- ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
|
||||
-- ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
|
||||
--
|
||||
--findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
--findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
|
||||
--
|
||||
--findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
--findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls
|
||||
@@ -1,56 +0,0 @@
|
||||
{- | Splits a line into many four cornered blocks. -}
|
||||
module Dodge.LevelGen.LineBlock
|
||||
( putLineBlock
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
|
||||
import Control.Lens
|
||||
|
||||
putLineBlock
|
||||
:: Wall -- ^ Base pane
|
||||
-> Float -- ^ Block width
|
||||
-> Float -- ^ Block depth
|
||||
-> Point2 -- ^ Start point (symmetric)
|
||||
-> Point2 -- ^ End point (symmetric)
|
||||
-> World
|
||||
-> (Int, World)
|
||||
putLineBlock basePane blockWidth depth a b w = (,) 0
|
||||
$ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
|
||||
where
|
||||
d = dist a b
|
||||
rot = argV (b -.- a)
|
||||
psOnLine = divideLineOddNumPoints blockWidth a b
|
||||
halfBlockWidth = d / 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 rot) cornerPoints
|
||||
linesAt p = makeLoopPairs $ cornersAt p
|
||||
k = IM.newKey $ _walls w
|
||||
blid = IM.newKey $ _blocks w
|
||||
insertBlock i = over blocks $ IM.insert (i+blid) Block
|
||||
{_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
|
||||
insertBlocks = flip (foldr insertBlock) is
|
||||
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
|
||||
visibilityAt i
|
||||
| i == 0 = [ True,True,False,True]
|
||||
| i == numBlocks - 1 = [False,True, True,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'
|
||||
,_wlBlockID = Just' $ i + blid
|
||||
,_wlLine = ps
|
||||
,_wlDraw = visStatus
|
||||
}
|
||||
listWalls = concat $ zipWith makeWallAt blockCenPs is
|
||||
insertWall wl = over walls $ IM.insert (_wlID wl) wl
|
||||
@@ -11,7 +11,6 @@ import Geometry
|
||||
|
||||
import Control.Lens
|
||||
|
||||
-- This deserves a clean up
|
||||
mvP :: Float -> Point2 -> Point2 -> Point2
|
||||
{-# INLINE mvP #-}
|
||||
mvP !speed !ep !p = mvPointTowardAtSpeed speed ep p
|
||||
@@ -38,4 +37,3 @@ changeZonedWall
|
||||
-> World
|
||||
-> World
|
||||
changeZonedWall eff n (x,y) = over (wallsZone . znObjects) $ adjustIMZone eff x y n
|
||||
|
||||
|
||||
@@ -25,7 +25,7 @@ removePathsCrossing :: Point2 -> Point2 -> World -> World
|
||||
removePathsCrossing a b w = w
|
||||
& pathGraph .~ newGraph
|
||||
& pathGraphP .~ pg'
|
||||
& pathPoints .~ (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
& pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
|
||||
where
|
||||
pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
|
||||
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
|
||||
Reference in New Issue
Block a user