211 lines
8.4 KiB
Haskell
211 lines
8.4 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
-- | deals with placement of objects within the world
|
|
-- after they have had their coordinates set by the layout
|
|
module Dodge.Placement.PlaceSpot
|
|
( placeSpot
|
|
) where
|
|
--import Dodge.LevelGen.LevelStructure
|
|
import Dodge.Placement.Shift
|
|
import Dodge.Data
|
|
import Dodge.Path
|
|
import Dodge.Placement.PlaceSpot.Block
|
|
import Dodge.Placement.PlaceSpot.TriggerDoor
|
|
--import Dodge.LevelGen.Data
|
|
import Dodge.Default.Wall
|
|
import Dodge.ShiftPoint
|
|
--import Dodge.RandomHelp
|
|
--import Dodge.Placements.Spot
|
|
import Geometry
|
|
--import Geometry.ConvexPoly
|
|
import Shape
|
|
import qualified IntMapHelp as IM
|
|
import Color
|
|
|
|
import Data.Maybe
|
|
import System.Random
|
|
import Control.Monad.State
|
|
import Control.Lens
|
|
import qualified Data.IntSet as IS
|
|
import Data.Bifunctor
|
|
|
|
-- 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
|
|
pl@Placement{_plGenUpdate = Just f} -> let (gp,pl') = f (_genParams w) pl
|
|
in placeSpot (w & genParams .~ gp,rm) pl'
|
|
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
|
|
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
|
|
Placement{} -> placePlainPSSpot w rm plmnt shift
|
|
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
|
|
RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
|
|
PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
|
|
where
|
|
shift = _rmShift rm
|
|
|
|
placePickOne :: Int -> Placement -> Room -> World -> World
|
|
placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
|
|
|
|
placeRandomPlacement :: State StdGen Placement -> World -> Room -> ((World,Room),[Placement])
|
|
placeRandomPlacement rplmnt w rm = placeSpot (w & randGen .~ g,rm) plmnt'
|
|
where
|
|
(plmnt', g) = runState rplmnt (_randGen w)
|
|
|
|
placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,Room),[Placement])
|
|
placePlainPSSpot w rm plmnt shift =
|
|
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)
|
|
|
|
-- this should be tidied up
|
|
placeSpotUsingLink :: World
|
|
-> Room
|
|
-> Placement
|
|
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
|
-> (RoomPos -> Room -> Room)
|
|
-> Maybe Placement
|
|
-> ((World, Room), [Placement])
|
|
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
|
|
Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
|
|
Nothing -> case fallback of
|
|
Nothing -> ((w,rm),[plmnt])
|
|
Just plmnt' -> placeSpot (w,rm) plmnt'
|
|
where
|
|
searchedPoss [] = Nothing
|
|
searchedPoss (pos:poss) = case extract pos rm of
|
|
Nothing -> second (pos:) <$> searchedPoss poss
|
|
Just (ps,rmpos) -> Just ( ps,rmpos:poss)
|
|
|
|
placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot)
|
|
-> Placement -> World -> ((World,Room),[Placement])
|
|
placeSpotRoomRand rm i f plmnt w =
|
|
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
|
|
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps)
|
|
|
|
-- the Int here is some id that is assigned when the placement is placed
|
|
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
|
|
placeSpotID ps pt w = case pt of
|
|
PutTrigger cnd -> plNewID triggers cnd w
|
|
PutMod mdi -> plNewUpID modifications mdID mdi w
|
|
PutProp prp -> plNewUpID props pjID (mvProp p rot prp) 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 pps mc -> plMachine col (map doShift pps) mc p rot w
|
|
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
|
|
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
|
|
RandPS rgn -> evaluateRandPS rgn ps w
|
|
PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w
|
|
PutCoord cp -> plNewID coordinates (doShift cp) w
|
|
PutSlideDr pth col f off a b spd
|
|
-> plSlideDoor pth col f off (doShift a) (doShift b) spd w
|
|
PutBlock bm hp hps wl ps'
|
|
-> placeBlock (map doShift ps') hp wl hps bm w
|
|
PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
|
|
PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w)
|
|
PutShape sh -> placeShape sh p rot w
|
|
PutNothing -> (0,w)
|
|
PutID i -> (i, w)
|
|
PutWorldUpdate f -> (0,w & f ps)
|
|
PutUsingGenParams f -> let (w',pt') = f w
|
|
in placeSpotID ps pt' w'
|
|
where
|
|
p@(V2 px py) = _psPos ps
|
|
p' = V3 px py 0
|
|
rot = _psRot ps
|
|
doShift = shiftPointBy (p,rot)
|
|
|
|
placeShape :: Shape -> Point2 -> Float -> World -> (Int, World)
|
|
placeShape sh p rot w =
|
|
(0, w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
|
|
|
|
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
|
|
|
|
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
|
|
plNewID :: ALens' World (IM.IntMap a)
|
|
-> a
|
|
-> World
|
|
-> (Int,World)
|
|
plNewID 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}
|
|
|
|
plMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
|
|
plMachine color wallpoly mc p rot gw = (mcid
|
|
, gw & machines %~ addMc
|
|
& walls %~ placeMachineWalls color wallpoly mcid wlid
|
|
)
|
|
where
|
|
w' = gw
|
|
mcid = IM.newKey $ _machines w'
|
|
wlid = IM.newKey $ _walls w'
|
|
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
|
|
--addMc = IM.insert mcid (mc {_mcPos = centroid wallpoly,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
|
|
addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
|
|
|
|
-- 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
|
|
& wlTouchThrough .~ True
|
|
|
|
mvLS :: Point3 -> Float -> LightSource -> LightSource
|
|
mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
|
|
& lsDir .~ rot
|
|
where
|
|
startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)
|