224 lines
8.1 KiB
Haskell
224 lines
8.1 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 Control.Monad.State
|
|
import Data.Bifunctor
|
|
import Data.Foldable
|
|
import qualified Data.IntSet as IS
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Base.NewID
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Wall
|
|
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 ^. plSpot of
|
|
PSRoomRand i f -> placeSpotRoomRand rid i f plmnt w
|
|
PSPos extract eff fallback -> placeSpotUsingLink w rid plmnt extract eff fallback
|
|
_ -> 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 ->
|
|
(0, w & gwWorld . cWorld . lWorld . foreShapes .:~ mvFS p rot fs)
|
|
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 dr wl -> plDoor (dr & drZeroPos %~ pashift & drOnePos %~ pashift) wl w
|
|
PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) 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) = obstructPathsCrossing (S.singleton ChasmObstacle) x y w
|
|
|
|
placeWallPoly :: [Point2] -> Wall -> World -> World
|
|
placeWallPoly qs wl w
|
|
| (p : ps) <- orderPolygon qs = foldl' (addPane wl) w $ zip (ps ++ [p]) (p : ps)
|
|
| otherwise = error "tried to place wall poly with too few points"
|
|
|
|
addPane :: Wall -> World -> (Point2, Point2) -> World
|
|
addPane wl w l = insertWall (wl & wlLine .~ l & wlID .~ i) w
|
|
where
|
|
i = IM.newKey $ w ^. cWorld . lWorld . walls
|
|
|
|
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 =
|
|
(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 ->
|
|
Maybe Item ->
|
|
Point2 ->
|
|
Float ->
|
|
GenWorld ->
|
|
(Int, GenWorld)
|
|
plMachine wallpoly mc mitm p rot gw =
|
|
( mcid
|
|
, gw & tolw . machines . at mcid ?~ themc
|
|
& gwWorld %~ placeMachineWalls wallpoly mcid wlid
|
|
& tolw %~ maybe id placeturretitm mitm
|
|
)
|
|
where
|
|
tolw = gwWorld . cWorld . lWorld
|
|
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
|
|
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
|
|
wlids = IS.fromList $ take (length wallpoly) [wlid ..]
|
|
themc = mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
|
|
placeturretitm itm =
|
|
(items . at itid ?~ itm')
|
|
. (machines . ix mcid . mcType . mctTurret . tuWeapon .~ itid)
|
|
where
|
|
itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
|
|
itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid
|
|
|
|
placeMachineWalls :: [Point2] -> Int -> Int -> World -> World
|
|
placeMachineWalls poly mcid = insertStructureWalls MachinePart baseWall poly mcid
|
|
where
|
|
baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid
|
|
|
|
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)
|