Cleanup: broken pathfinding
This commit is contained in:
+11
-199
@@ -2,205 +2,17 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
-- | deals with placement of objects within the world
|
||||
-- after they have had their coordinates set by the layout
|
||||
module Dodge.LevelGen
|
||||
( shiftPlacement
|
||||
, shiftPointBy
|
||||
, invShiftPointBy
|
||||
, placeSpot
|
||||
) where
|
||||
module Dodge.LevelGen where
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen.Block
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Dodge.LevelGen.TriggerDoor
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.Default.Wall
|
||||
--import Dodge.RandomHelp
|
||||
--import Dodge.Placements.Spot
|
||||
import Geometry
|
||||
import Geometry.Vector3D
|
||||
import Shape
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
import Dodge.Floor
|
||||
import Dodge.Layout
|
||||
import Dodge.Initialisation
|
||||
--import qualified IntMapHelp as IM
|
||||
|
||||
import System.Random
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.Bifunctor
|
||||
--import Control.Lens
|
||||
|
||||
-- when placing a placement, we update the world and the room and assign an id
|
||||
-- to the placement
|
||||
placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
|
||||
placeSpot (w,rm) plmnt = case plmnt of
|
||||
Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
|
||||
Placement{_plSpot = PSLnk extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
|
||||
Placement{} ->
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
newplmnt = plmnt & plMID ?~ i
|
||||
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
|
||||
where
|
||||
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
|
||||
in (wr,newplmnt:newplmnts)
|
||||
-- (placeSpot (w',rm)) (_plIDCont plmnt i)
|
||||
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
|
||||
RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt'
|
||||
where
|
||||
(plmnt', g) = runState rplmnt (_randGen w)
|
||||
where
|
||||
shift = _rmShift rm
|
||||
|
||||
-- this should be tidied up
|
||||
placeSpotUsingLink :: World -> Room -> Placement
|
||||
-> (RoomPos -> Maybe PlacementSpot)
|
||||
-> (RoomPos -> Room -> Room)
|
||||
-> Maybe Placement
|
||||
-> ((World, Room), [Placement])
|
||||
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
|
||||
Just (ps,pos,newrmpos) -> placeSpot (w, eff pos $ rm & rmPos .~ newrmpos) (plmnt & plSpot .~ ps)
|
||||
Nothing -> case fallback of
|
||||
Nothing -> ((w,rm),[plmnt])
|
||||
Just plmnt' -> placeSpot (w,rm) plmnt'
|
||||
where
|
||||
searchedPoss [] = error "no correct pos type for lnk placement"
|
||||
searchedPoss (pos:poss) = case extract pos of
|
||||
Nothing -> second (pos:) <$> searchedPoss poss
|
||||
Just ps -> Just ( ps,pos, poss)
|
||||
|
||||
placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
|
||||
placeSpotRoomRand rm i plmnt w =
|
||||
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
|
||||
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
|
||||
|
||||
shiftPlacement :: (Point2,Float) -> Placement -> Placement
|
||||
shiftPlacement shift plmnt = case plmnt of
|
||||
Placement {} -> plmnt & plSpot %~ shiftPSBy shift
|
||||
& plIDCont %~ fmap (fmap $ shiftPlacement shift)
|
||||
PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
|
||||
(fmap (shiftPlacement shift) f)
|
||||
RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
|
||||
|
||||
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
|
||||
shiftPSBy (pos,rot) ps = ps
|
||||
& psPos %~ shiftPointBy (pos,rot)
|
||||
& psRot %~ (+ rot)
|
||||
|
||||
-- the Int here allows for passing parameters down to other placements:
|
||||
-- button ids, etc
|
||||
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
|
||||
placeSpotID ps pt w = case pt of
|
||||
PutTrigger cond -> placeNewInto triggers cond w
|
||||
PutProp prop -> plNewUpID props pjID (mvProp p rot prop) w
|
||||
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
|
||||
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
|
||||
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
|
||||
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
|
||||
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
|
||||
PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
|
||||
RandPS rgen -> evaluateRandPS rgen ps w
|
||||
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
|
||||
PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
|
||||
PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
|
||||
PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
|
||||
PutBlock{} -> error "messed up block placement somehow"
|
||||
PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
|
||||
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
|
||||
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
|
||||
PutNothing -> (0,w)
|
||||
PutID i -> (i, w)
|
||||
PutWorldUpdate f -> (0,f ps w)
|
||||
where
|
||||
p@(V2 px py) = _psPos ps
|
||||
p' = V3 px py 0
|
||||
rot = _psRot ps
|
||||
doShift = shiftPointBy (p,rot)
|
||||
|
||||
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
|
||||
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
|
||||
where
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
|
||||
placeWallPoly :: [Point2] -> Wall -> World -> World
|
||||
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
|
||||
where
|
||||
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
|
||||
|
||||
shiftPointBy :: (Point2,Float) -> Point2 -> Point2
|
||||
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
|
||||
|
||||
invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
|
||||
invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
|
||||
|
||||
shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
|
||||
shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
|
||||
|
||||
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
addWalls qs wl wls = foldr (addPane wl) wls pairs
|
||||
where
|
||||
(p:ps) = orderPolygon qs
|
||||
pairs = zip (ps ++ [p]) (p:ps)
|
||||
|
||||
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
|
||||
where
|
||||
wlid = IM.newKey wls
|
||||
|
||||
-- | generalised way of putting a new item into a lensed intmap, returning the
|
||||
-- new index as well
|
||||
placeNewInto :: ALens' World (IM.IntMap a)
|
||||
-> a
|
||||
-> World
|
||||
-> (Int,World)
|
||||
placeNewInto l x w = (i,w & l #%~ IM.insert i x)
|
||||
where
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
-- | place an new object into an intmap and update its id
|
||||
plNewUpID :: ALens' World (IM.IntMap a)
|
||||
-> ALens' a Int
|
||||
-> a
|
||||
-> World
|
||||
-> (Int,World)
|
||||
plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
|
||||
where
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
mvButton :: Point2 -> Float -> Button -> Button
|
||||
mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
{- Creates a floor item at a given point.-}
|
||||
createFlIt :: Point2 -> Float -> Item -> FloorItem
|
||||
createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm }
|
||||
|
||||
mvPP :: Point2 -> Float -> PressPlate -> PressPlate
|
||||
mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
|
||||
|
||||
mvCr :: Point2 -> Float -> Creature -> Creature
|
||||
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
|
||||
|
||||
placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
|
||||
placeMachine color wallpoly mc p rot w = (mcid
|
||||
, w & machines %~ addMc
|
||||
& walls %~ placeMachineWalls color wallpoly mcid wlid
|
||||
)
|
||||
where
|
||||
mcid = IM.newKey $ _machines w
|
||||
wlid = IM.newKey $ _walls w
|
||||
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
|
||||
addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
|
||||
|
||||
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
|
||||
placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
|
||||
where
|
||||
f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
|
||||
baseWall = defaultMachineWall
|
||||
& wlColor .~ col
|
||||
& wlStructure . wlStMachine .~ mcid
|
||||
|
||||
mvLS :: Point3 -> Float -> LightSource -> LightSource
|
||||
mvLS (V3 x y z) rot ls = ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot}
|
||||
where
|
||||
startPos = onXY (rotateV rot) $ _lsPos ls
|
||||
generateWorldFromSeed :: Int -> IO World
|
||||
generateWorldFromSeed i = do
|
||||
roomList <- layoutLevelFromSeed 0 i
|
||||
return $ generateLevelFromRoomList roomList
|
||||
initialWorld -- note this uses a random generator defined elsewhere
|
||||
|
||||
Reference in New Issue
Block a user