217 lines
8.0 KiB
Haskell
217 lines
8.0 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 Control.Monad.Trans.State.Lazy
|
|
import Data.Bifunctor
|
|
import Data.Foldable
|
|
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
|
|
|
|
-- 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 -> placeSpotUsingRoomPos 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' =
|
|
placeSpot rid (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
|
|
|
|
-- this should be tidied up
|
|
placeSpotUsingRoomPos ::
|
|
GenWorld ->
|
|
Int ->
|
|
Placement ->
|
|
(RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) ->
|
|
(RoomPos -> Room -> Room) ->
|
|
Maybe Placement ->
|
|
GenWorld
|
|
placeSpotUsingRoomPos 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
|
|
(w ^?! genRooms . ix rid . rmRandPSs . ix 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 mc mitm -> plMachine (mc & mcPos .~ p & mcDir .~ rot) mitm 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' qs ->
|
|
( 0
|
|
, placeChasm
|
|
rid
|
|
ps'
|
|
(map (map doShift) ps')
|
|
(foldMap (loopPairs . map doShift) qs)
|
|
w
|
|
)
|
|
PutLabel{} -> (0, w)
|
|
where
|
|
p = _psPos ps
|
|
rot = _psRot ps
|
|
doShift = shiftPointBy (p, rot)
|
|
pashift = compP2A (p, rot)
|
|
|
|
placeChasm :: Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld -> GenWorld
|
|
placeChasm rid ps shiftps cfs =
|
|
(gwWorld . cWorld . chasms <>~ shiftps)
|
|
. (gwWorld . cWorld . cliffs <>~ cfs)
|
|
. (genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps))
|
|
. (gwWorld %~ f)
|
|
where
|
|
f w = foldl' g w cfs
|
|
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 :: Machine -> Maybe Item -> GenWorld -> (Int, GenWorld)
|
|
plMachine mc mitm gw =
|
|
( mcid
|
|
, gw
|
|
& tolw . machines . at mcid ?~ themc
|
|
& tolw %~ maybe id placeturretitm mitm
|
|
& gwWorld %~ addwalls
|
|
)
|
|
where
|
|
p = mc ^. mcPos
|
|
rot = mc ^. mcDir
|
|
addwalls =
|
|
insertStructureWalls
|
|
MachinePart
|
|
wl
|
|
(map fst pps & each %~ shiftPointBy (p,rot))
|
|
mcid
|
|
wlid
|
|
pps = IM.elems $ mc ^. mcFootPrint
|
|
wl =
|
|
defaultMachineWall
|
|
& wlStructure . wsMachine .~ mcid
|
|
& wlMaterial .~ (mc ^. mcSkin)
|
|
tolw = gwWorld . cWorld . lWorld
|
|
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
|
|
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
|
|
themc = mc
|
|
& mcID .~ mcid
|
|
& mcFootPrint .~ IM.fromDistinctAscList (zip [wlid..] pps)
|
|
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
|
|
|
|
mvLS :: Point2 -> Float -> LightSource -> LightSource
|
|
mvLS x rot = lsParam . lsPos . _xy %~ ((+ x) . rotateV rot)
|