277 lines
9.9 KiB
Haskell
277 lines
9.9 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
|
|
|
|
{- | 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.Default.Wall
|
|
import qualified Data.Set as S
|
|
import Control.Monad.State
|
|
import Data.Bifunctor
|
|
import Data.Foldable
|
|
import qualified Data.IntSet as IS
|
|
import Data.Maybe
|
|
import Dodge.Base.NewID
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Path
|
|
import Dodge.Placement.PlaceSpot.Block
|
|
import Dodge.Placement.PlaceSpot.TriggerDoor
|
|
import Dodge.Placement.Shift
|
|
import Dodge.ShiftPoint
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import Linear
|
|
import NewInt
|
|
|
|
--import System.Random
|
|
|
|
-- when placing a placement, we update the world and the room and assign an id
|
|
-- to the placement. This id should be associated with the type of placement and
|
|
-- match up with the created id for the object (creature id, flitid id, etc)
|
|
placeSpot :: Int -> GenWorld -> Placement -> GenWorld
|
|
placeSpot rid w plmnt = case plmnt of
|
|
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rid i f plmnt w
|
|
Placement{_plSpot = PSPos extract eff fallback} ->
|
|
placeSpotUsingLink w rid plmnt extract eff fallback
|
|
Placement{} -> placePlainPSSpot w rid plmnt shift
|
|
where
|
|
shift = _rmShift $ w ^?! genRooms . ix rid
|
|
|
|
placePlainPSSpot :: GenWorld -> Int -> Placement -> Point2A -> GenWorld
|
|
placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
|
|
RandPS rgn ->
|
|
let (x, g) = runState rgn (w ^. gwWorld . randGen)
|
|
in placePlainPSSpot (w & gwWorld . randGen .~ g) rid (plmnt & plType .~ x) shift
|
|
_ ->
|
|
let (i, w') = placeSpotID rid (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
|
newplmnt = plmnt & plMID ?~ i
|
|
gw =
|
|
maybe
|
|
(w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
|
|
(recrPlace newplmnt w')
|
|
(_plIDCont plmnt w' newplmnt)
|
|
in f newplmnt gw
|
|
where
|
|
f x gw = fromMaybe gw $ do
|
|
j <- x ^. plExternalID
|
|
return $ gw & genPmnt . at j ?~ x
|
|
recrPlace newplmnt w' pl =
|
|
placeSpot
|
|
rid
|
|
(w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
|
|
pl
|
|
|
|
-- this should be tidied up
|
|
placeSpotUsingLink ::
|
|
GenWorld ->
|
|
Int ->
|
|
Placement ->
|
|
(RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) ->
|
|
(RoomPos -> Room -> Room) ->
|
|
Maybe Placement ->
|
|
GenWorld
|
|
placeSpotUsingLink w rid plmnt extract eff fallback =
|
|
case searchedPoss (w ^?! genRooms . ix rid . rmPos) of
|
|
Just (ps, rmposs) ->
|
|
placeSpot
|
|
rid
|
|
(w & genRooms . ix rid %~ eff (head rmposs) . (rmPos .~ rmposs))
|
|
(plmnt & plSpot .~ ps)
|
|
Nothing -> maybe w (placeSpot rid w) fallback
|
|
where
|
|
searchedPoss [] = Nothing
|
|
searchedPoss (pos : poss) = case extract pos (w ^?! genRooms . ix rid) of
|
|
Nothing -> second (pos :) <$> searchedPoss poss
|
|
Just (ps, rmpos) -> Just (ps, rmpos : poss)
|
|
|
|
placeSpotRoomRand ::
|
|
Int ->
|
|
Int ->
|
|
(Point2A -> PlacementSpot) ->
|
|
Placement ->
|
|
GenWorld ->
|
|
GenWorld
|
|
placeSpotRoomRand rid i f plmnt w =
|
|
let (ps, g) =
|
|
runState
|
|
(_rmRandPSs (w ^?! genRooms . ix rid) !! i)
|
|
$ w ^. gwWorld . randGen
|
|
in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps)
|
|
|
|
-- the Int here is some id that is assigned when the placement is placed
|
|
placeSpotID :: Int -> PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
|
|
placeSpotID rid ps pt w = case pt of
|
|
PutTrigger cnd -> plNewID (gwWorld . cWorld . lWorld . triggers) cnd w
|
|
PutMod mdi -> plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w
|
|
PutProp prp -> plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w
|
|
PutButton bt ->
|
|
plNewUpID
|
|
(gwWorld . cWorld . lWorld . buttons)
|
|
btID
|
|
(mvButton p rot bt)
|
|
w
|
|
PutTerminal tm -> plNewUpID (gwWorld . cWorld . lWorld . terminals) tmID tm w
|
|
PutFlIt itm ->
|
|
let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
|
|
in ( i
|
|
, w
|
|
& gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot
|
|
& gwWorld . cWorld . lWorld . items . at i
|
|
?~ ( itm & itID .~ NInt i
|
|
& itLocation .~ OnFloor
|
|
)
|
|
)
|
|
PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
|
|
PutForeground fs ->
|
|
plNewUpID
|
|
(gwWorld . cWorld . lWorld . foreShapes)
|
|
fsID
|
|
(mvFS p rot fs)
|
|
w
|
|
--PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
|
|
PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
|
|
PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
|
|
RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
|
|
--PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
|
|
PutDoor eo f l p1 p2 -> plDoor eo f l (pashift p1) (pashift p2) w
|
|
PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
|
|
PutSlideDr wl dr eo off a b ->
|
|
plSlideDoor wl dr eo off (doShift a) (doShift b) w
|
|
PutBlock bl wl ps' ->
|
|
plBlock
|
|
(map doShift ps')
|
|
(bl & blPos %~ doShift & blDir .~ rot)
|
|
wl
|
|
w
|
|
PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w
|
|
PutWall qs wl -> (0, over gwWorld (placeWallPoly (map doShift qs) wl) w)
|
|
PutNothing -> (0, w)
|
|
PutID i -> (i, w)
|
|
PutWorldUpdate f -> (0, w & f rid ps)
|
|
PutChasm ps' -> (0, placeChasm w rid ps' $ map doShift ps')
|
|
PutLabel{} -> (0, w)
|
|
where
|
|
p@(V2 px py) = _psPos ps
|
|
p' = V3 px py 0
|
|
rot = _psRot ps
|
|
doShift = shiftPointBy (p, rot)
|
|
pashift = compP2A (p, rot)
|
|
|
|
placeChasm :: GenWorld -> Int -> [Point2] -> [Point2] -> GenWorld
|
|
placeChasm gw rid ps shiftps =
|
|
gw & gwWorld . cWorld . chasms .:~ shiftps
|
|
& genRooms . ix rid . rmPos %~ filter (\rp -> not $ pointInPoly (_rpPos rp) ps)
|
|
& gwWorld %~ f
|
|
where
|
|
f w = foldl' g w (loopPairs shiftps)
|
|
g w (x,y) = fst $ obstructPathsCrossing (S.singleton ChasmObstacle) x y w
|
|
|
|
--evaluateRandPS
|
|
-- :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
|
|
--evaluateRandPS rid rgen ps w = placeSpotID rid ps evaluatedType
|
|
-- $ set (gwWorld . randGen) g w
|
|
-- where
|
|
-- (evaluatedType, g) = runState rgen (_randGen $ _gwWorld w)
|
|
|
|
-- this function is the reason for the warning suppression
|
|
-- remove the warning suppression if it changes
|
|
placeWallPoly :: [Point2] -> Wall -> World -> World
|
|
placeWallPoly qs wl w = foldl' (addPane wl) w pairs
|
|
where
|
|
(p : ps) = orderPolygon qs
|
|
pairs = zip (ps ++ [p]) (p : ps)
|
|
|
|
addPane :: Wall -> World -> (Point2, Point2) -> World
|
|
addPane wl w l =
|
|
w & plNew (cWorld . lWorld . walls) wlID (wl & wlLine .~ l)
|
|
& fst . uncurry (obstructPathsCrossing (S.fromList [WallObstacle WallNotAutoOpen])) l
|
|
|
|
mvProp :: Point2 -> Float -> Prop -> Prop
|
|
mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
|
|
|
|
mvButton :: Point2 -> Float -> Button -> Button
|
|
mvButton p a = (btRot +~ a) . (btPos %~ ((p +.+) . rotateV a))
|
|
|
|
mvCr :: Point2 -> Float -> Creature -> Creature
|
|
mvCr p rot cr =
|
|
cr
|
|
& crPos . _xy .~ p
|
|
& crOldPos . _xy .~ p
|
|
& crDir .~ rot
|
|
|
|
mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
|
|
mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
|
|
|
|
plMachine ::
|
|
[Point2] ->
|
|
Machine ->
|
|
-- Wall ->
|
|
Maybe Item ->
|
|
Point2 ->
|
|
Float ->
|
|
GenWorld ->
|
|
(Int, GenWorld)
|
|
plMachine wallpoly mc = \case
|
|
Nothing -> plMachine' wallpoly mc
|
|
Just itm -> plTurret wallpoly mc itm
|
|
|
|
plTurret ::
|
|
[Point2] ->
|
|
Machine ->
|
|
-- Wall ->
|
|
Item ->
|
|
Point2 ->
|
|
Float ->
|
|
GenWorld ->
|
|
(Int, GenWorld)
|
|
plTurret wallpoly mc itm p rot gw =
|
|
( mcid
|
|
, gw & gwWorld . cWorld . lWorld . machines %~ addMc
|
|
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid
|
|
& gwWorld . cWorld . lWorld . items . at itid ?~ itm'
|
|
)
|
|
where
|
|
itm' =
|
|
itm & itID .~ NInt itid
|
|
& itLocation .~ OnTurret mcid
|
|
itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
|
|
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
|
|
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
|
|
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
|
|
addMc =
|
|
IM.insert
|
|
mcid
|
|
( mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
|
|
& mcType . mctTurret . tuWeapon .~ itid
|
|
)
|
|
|
|
plMachine' :: [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
|
|
plMachine' wallpoly mc p rot gw =
|
|
( mcid
|
|
, gw & gwWorld . cWorld . lWorld . machines %~ addMc
|
|
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid
|
|
)
|
|
where
|
|
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
|
|
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
|
|
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
|
|
addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids})
|
|
|
|
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
|
|
placeMachineWalls :: [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
|
|
placeMachineWalls poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
|
|
where
|
|
f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
|
|
baseWall =
|
|
defaultMachineWall
|
|
& wlStructure . wsMachine .~ mcid
|
|
& wlTouchThrough .~ True
|
|
|
|
mvLS :: Point3 -> Float -> LightSource -> LightSource
|
|
mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
|
|
where
|
|
startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)
|