224 lines
8.6 KiB
Haskell
224 lines
8.6 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 Color
|
|
import Control.Monad.State
|
|
import Data.Bifunctor
|
|
import Data.Foldable
|
|
import qualified Data.IntSet as IS
|
|
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 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 :: (GenWorld, Room) -> Placement -> ((GenWorld, Room), [Placement])
|
|
placeSpot (w, rm) plmnt = case plmnt of
|
|
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
|
|
where
|
|
shift = _rmShift rm
|
|
|
|
placePlainPSSpot
|
|
:: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld, 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 (_gwWorld w') newplmnt)
|
|
where
|
|
recrPlace newplmnt w' pl =
|
|
let (wr, newplmnts) = placeSpot (w', rm) pl
|
|
in (wr, newplmnt : newplmnts)
|
|
|
|
-- this should be tidied up
|
|
placeSpotUsingLink ::
|
|
GenWorld ->
|
|
Room ->
|
|
Placement ->
|
|
(RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) ->
|
|
(RoomPos -> Room -> Room) ->
|
|
Maybe Placement ->
|
|
((GenWorld, 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 ->
|
|
GenWorld ->
|
|
((GenWorld, Room), [Placement])
|
|
placeSpotRoomRand rm i f plmnt w =
|
|
let (ps, g) = runState (_rmRandPSs rm !! i) $ w ^. gwWorld . randGen
|
|
in placeSpot (w & gwWorld . randGen .~ g, rm) (plmnt & plSpot .~ f ps)
|
|
|
|
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
|
|
placeSpotID ps pt gw =
|
|
let (i, w) = placeSpotID' ps pt (_gwWorld gw)
|
|
in (i, gw & gwWorld .~ w)
|
|
|
|
-- 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 (cWorld . lWorld . triggers) cnd w
|
|
PutMod mdi -> plNewUpID (cWorld . lWorld . modifications) mdID mdi w
|
|
PutProp prp -> plNewUpID (cWorld . lWorld . props) prID (mvProp p rot prp) w
|
|
PutButton bt -> plNewUpID (cWorld . lWorld . buttons) btID (mvButton p rot bt) w
|
|
PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w
|
|
PutFlIt itm ->
|
|
let i = IM.newKey (w ^. cWorld . lWorld . items)
|
|
in ( i
|
|
, w
|
|
& cWorld . lWorld . floorItems . at i ?~ FlIt p rot
|
|
& cWorld . lWorld . items . at i
|
|
?~ ( itm & itID .~ NInt i
|
|
& itLocation .~ OnFloor
|
|
)
|
|
)
|
|
PutCrit cr -> plNewUpID (cWorld . lWorld . creatures) crID (mvCr p rot cr) w
|
|
PutForeground fs -> plNewUpID (cWorld . lWorld . foregroundShapes) fsID
|
|
(mvFS p rot fs) w
|
|
PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
|
|
PutLS ls -> plNewUpID (cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
|
|
PutPPlate pp -> plNewUpID (cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
|
|
RandPS rgn -> evaluateRandPS rgn ps w
|
|
PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
|
|
PutCoord cp -> plNewID 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, placeWallPoly (map doShift qs) wl w)
|
|
PutNothing -> (0, w)
|
|
PutID i -> (i, w)
|
|
PutWorldUpdate f -> (0, w & f ps)
|
|
PutChasm ps' -> (0, w & cWorld . chasms .:~ map doShift ps')
|
|
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)
|
|
|
|
-- 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 WallObstacle) 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))
|
|
|
|
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}
|
|
|
|
mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
|
|
mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
|
|
|
|
plMachine ::
|
|
[Point2] -> Machine -> Wall -> Maybe Item -> Point2 -> Float -> World -> (Int, World)
|
|
plMachine wallpoly mc wl = \case
|
|
Nothing -> plMachine' wallpoly mc wl
|
|
Just itm -> plTurret wallpoly mc wl itm
|
|
|
|
plTurret :: [Point2] -> Machine -> Wall -> Item -> Point2 -> Float -> World -> (Int, World)
|
|
plTurret wallpoly mc wl itm p rot gw =
|
|
( mcid
|
|
, gw & cWorld . lWorld . machines %~ addMc
|
|
& cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
|
|
& cWorld . lWorld . items . at itid ?~ itm'
|
|
)
|
|
where
|
|
itm' =
|
|
itm & itID .~ NInt itid
|
|
& itLocation .~ OnTurret mcid
|
|
itid = IM.newKey $ gw ^. cWorld . lWorld . items
|
|
col = _mcColor mc
|
|
mcid = IM.newKey $ gw ^. cWorld . lWorld . machines
|
|
wlid = IM.newKey $ gw ^. 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 -> Wall -> Point2 -> Float -> World -> (Int, World)
|
|
plMachine' wallpoly mc wl p rot gw =
|
|
( mcid
|
|
, gw & cWorld . lWorld . machines %~ addMc
|
|
& cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid
|
|
)
|
|
where
|
|
col = _mcColor mc
|
|
mcid = IM.newKey $ gw ^. cWorld . lWorld . machines
|
|
wlid = IM.newKey $ gw ^. 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
|
|
:: Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
|
|
placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
|
|
where
|
|
f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
|
|
baseWall =
|
|
wl
|
|
& wlColor .~ col
|
|
& 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)
|