Cleanup: broken pathfinding
This commit is contained in:
@@ -1,108 +0,0 @@
|
||||
{- | Creation, update and destruction of destructible walls. -}
|
||||
module Dodge.LevelGen.Block
|
||||
( placeBlock
|
||||
, placeLineBlock
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Zone
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Dodge.Default.Wall
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
|
||||
import Control.Lens
|
||||
import Data.List
|
||||
import qualified Data.IntSet as IS
|
||||
|
||||
addBlock
|
||||
:: [Point2] -- ^ Block polygon
|
||||
-> Int -- ^ First layer of health
|
||||
-> Color
|
||||
-> Opacity -- ^ Is the block see through?
|
||||
-> [Int] -- ^ Extra layers of health
|
||||
-> World
|
||||
-> World
|
||||
addBlock (p:ps) hp col opacity hps w
|
||||
| hp <= 0 && null hps = w
|
||||
| hp <= 0 = addBlock (p:ps) (head hps + hp) col opacity (tail hps) 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=[]})
|
||||
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 defaultWall
|
||||
{ _wlLine = (a,b)
|
||||
, _wlID = j
|
||||
, _wlColor = col
|
||||
, _wlOpacity = opacity
|
||||
, _wlStructure = BlockPart blid
|
||||
, _wlFireThrough = True
|
||||
}
|
||||
) 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 -> Color -> Opacity -> [Int] -> World -> (Int,World)
|
||||
placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
|
||||
where
|
||||
pairs = loopPairs poly
|
||||
wWithBlock = addBlock poly i c opac is w
|
||||
|
||||
{- | Splits a line into many four cornered blocks. -}
|
||||
placeLineBlock
|
||||
:: 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 w = (,) 0
|
||||
$ removePathsCrossing a b $ foldr insertWall (insertBlocks w) 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 w
|
||||
blid = IM.newKey $ _blocks w
|
||||
insertBlock i = over blocks $ IM.insert (i+blid) Block
|
||||
{_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
|
||||
insertBlocks = flip (foldr insertBlock) is
|
||||
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
|
||||
@@ -1,32 +0,0 @@
|
||||
module Dodge.LevelGen.Pathing
|
||||
( removePathsCrossing
|
||||
, pairsToGraph
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Zone
|
||||
import Geometry
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.Graph.Inductive hiding ((&))
|
||||
--import Data.Graph.Inductive.NodeMap
|
||||
|
||||
pairsToGraph :: (Ord a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
|
||||
pairsToGraph f pairs =
|
||||
let nodes' = nub (map fst pairs ++ map snd pairs)
|
||||
pairs' = map (\(x,y)->(x,y,f x y)) pairs
|
||||
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes' >> insMapEdgesM pairs'
|
||||
|
||||
removePathsCrossing :: Point2 -> Point2 -> World -> World
|
||||
removePathsCrossing a b w = w
|
||||
& pathGraph .~ newGraph
|
||||
& pathGraphP .~ pg'
|
||||
& 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]
|
||||
newGraph = pairsToGraph dist pg'
|
||||
@@ -1,137 +0,0 @@
|
||||
--{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.LevelGen.TriggerDoor
|
||||
( placeDoor
|
||||
, placeSlideDoor
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Default.Wall
|
||||
import Dodge.Wall.Move
|
||||
import Dodge.LevelGen.DoorPane
|
||||
import Picture
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.SoundLogic.LoadSound
|
||||
import Dodge.Data.SoundOrigin
|
||||
|
||||
import Data.List
|
||||
import Control.Lens
|
||||
--import Data.Graph.Inductive hiding ((&))
|
||||
import qualified Data.IntSet as IS
|
||||
placeDoor
|
||||
:: Color
|
||||
-> (World -> Bool) -- ^ Opening condition
|
||||
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
|
||||
-- Bumped out up and down by 9, not widened
|
||||
-> World
|
||||
-> (Int,World)
|
||||
placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
|
||||
where
|
||||
drid = IM.newKey $ _doors w
|
||||
addDoor = IM.insert drid $ Door
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
, _drStatus = DoorInt 0
|
||||
, _drTrigger = cond
|
||||
, _drMech = doorMechanismStepwise nsteps drid wlids pss
|
||||
}
|
||||
nsteps = length pss - 1
|
||||
wlids = take 4 [IM.newKey $ _walls w ..]
|
||||
wlps' = uncurry (rectanglePairs 9) $ head pss
|
||||
addWalls w' = foldl' addWall w' $ zip wlids wlps'
|
||||
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
|
||||
{ _wlLine = wlps
|
||||
, _wlID = wlid
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlPathable = False
|
||||
}
|
||||
-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
|
||||
-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
|
||||
doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
|
||||
doorMechanismStepwise nsteps drid wlids pss dr w
|
||||
| toOpen = case _drStatus dr of
|
||||
DoorInt x | x == nsteps -> w
|
||||
DoorInt x -> setWalls (x+1)
|
||||
_ -> w
|
||||
| otherwise = case _drStatus dr of
|
||||
DoorInt 0 -> w
|
||||
DoorInt x -> setWalls (x-1)
|
||||
_ -> w
|
||||
where
|
||||
playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
|
||||
toOpen = _drTrigger dr w
|
||||
setWalls n = playSound (foldl' (&) w (zipWith moveWallID wlids newps))
|
||||
& doors . ix drid . drStatus .~ DoorInt n
|
||||
where
|
||||
newps = uncurry (rectanglePairs 9) (pss !! n)
|
||||
-- it is not at all clear that the zoning selects the correct walls
|
||||
|
||||
doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door -> World -> World
|
||||
doorMechanism drid speed wlidOpCps dr w
|
||||
| toOpen && dstatus /= DoorOpen = moveUpdate $ foldl' doOpen w wlidOpCps
|
||||
| not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
|
||||
| otherwise = w
|
||||
where
|
||||
moveUpdate = playSound . setStatus
|
||||
playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
|
||||
setStatus
|
||||
| dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
|
||||
| dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
|
||||
| otherwise = doors . ix drid . drStatus .~ DoorHalfway
|
||||
(wlid',opos,cpos) = head wlidOpCps
|
||||
wlpos = _wlLine $ _walls w IM.! wlid'
|
||||
toOpen = _drTrigger dr w
|
||||
dstatus = _drStatus dr
|
||||
doOpen w' (wlid,opp, _) = moveWallIDToward wlid speed opp w'
|
||||
doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'
|
||||
|
||||
-- TODO cut pathing if not pathable, reset when opened
|
||||
placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
|
||||
-> (Int, World)
|
||||
placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ addDoor)
|
||||
where
|
||||
drid = IM.newKey $ _doors w
|
||||
addDoor = IM.insert drid $ Door
|
||||
{ _drID = drid
|
||||
, _drWallIDs = IS.fromList wlids
|
||||
, _drStatus = DoorClosed
|
||||
, _drTrigger = cond
|
||||
, _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
|
||||
}
|
||||
addWalls w' = foldl' addWall w' $ zip wlids pairs
|
||||
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
|
||||
{ _wlLine = wlps
|
||||
, _wlID = wlid
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _wlOpacity = Opaque
|
||||
, _wlPathable = isPathable
|
||||
}
|
||||
pairs = rectanglePairs 9 a b
|
||||
shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
|
||||
shiftLeft = (+.+ (a -.- b))
|
||||
wlids = take 4 [IM.newKey $ _walls w ..]
|
||||
-- old code that may help with pathing
|
||||
--import Dodge.LevelGen.Pathing
|
||||
--import Data.Graph.Inductive hiding ((&))
|
||||
--addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
|
||||
--addButtonDoor c btp btr a b speed w
|
||||
-- = (,) 0
|
||||
-- . over buttons (IM.insert bid bt)
|
||||
-- $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
-- $ set pathGraph newGraph
|
||||
-- $ set pathGraphP newGraphPairs
|
||||
-- $ snd (placeSlideDoor False c cond a b speed w)
|
||||
-- where
|
||||
-- bid = IM.newKey $ _buttons w
|
||||
-- cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
|
||||
-- bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
|
||||
-- (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
|
||||
-- $ _pathGraphP w
|
||||
-- newGraph = pairsToGraph dist newGraphPairs
|
||||
-- insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
-- eff w' = over pathGraphP (removedPairs ++)
|
||||
-- . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
-- f (x,y) = (x,y,dist x y)
|
||||
Reference in New Issue
Block a user