219 lines
7.4 KiB
Haskell
219 lines
7.4 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
-- | deals with placement of objects within the world
|
|
-- after they have had their coordinates set by the layout
|
|
module Dodge.LevelGen
|
|
( module Dodge.LevelGen
|
|
, cutWalls
|
|
, pairsToGraph
|
|
, makeButton
|
|
, makeSwitch
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.LevelGen.Block
|
|
import Dodge.LevelGen.Pathing
|
|
import Dodge.LevelGen.StaticWalls
|
|
import Dodge.LevelGen.AutoDoor
|
|
import Dodge.LevelGen.TriggerDoor
|
|
import Dodge.LevelGen.Switch
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.Default.Wall
|
|
import Geometry
|
|
import Geometry.Vector3D
|
|
import Shape
|
|
import qualified IntMapHelp as IM
|
|
import Color
|
|
|
|
import Control.Monad.State
|
|
import Control.Lens
|
|
import qualified Data.IntSet as IS
|
|
|
|
placeSpot :: World -> ((Point2,Float) , Placement) -> World
|
|
placeSpot w (shift, plmnt) =
|
|
let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w
|
|
in maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
|
|
|
|
shiftPlacement :: (Point2,Float) -> Placement -> Placement
|
|
shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps)
|
|
(fmap (fmap $ shiftPlacement shift) f)
|
|
|
|
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
|
|
shiftPSBy (pos,rot) ps = ps
|
|
& psPos %~ shiftPointBy (pos,rot)
|
|
& psRot %~ (+ rot)
|
|
|
|
-- the Int here allows for passing parameters down to other placements:
|
|
-- button ids, etc
|
|
placeSpotID :: PlacementSpot -> World -> (Int, World)
|
|
placeSpotID ps w = case _psType ps of
|
|
PutProp prop -> placeProp prop p rot w
|
|
PutButton bt -> placeBt bt p rot w
|
|
PutFlIt itm -> placeFlIt itm p rot w
|
|
PutCrit cr -> placeCr cr p rot w
|
|
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
|
|
PutLS ls -> placeLS ls p' rot w
|
|
PutPressPlate pp -> placePressPlate pp p rot w
|
|
RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
|
|
where
|
|
(evaluatedType, g) = runState rgen (_randGen w)
|
|
PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w
|
|
where
|
|
mapBoth fn (x,y) = (fn x, fn y)
|
|
PutSingleDoor col f a b speed
|
|
-> putSingleDoor False col f (doShift a) (doShift b) speed w
|
|
PutDoubleDoor col f a b speed
|
|
-> (,) 0 $ insertDoubleDoor False col f (doShift a) (doShift b) speed w
|
|
PutAutoDoor a b -> (,) 0 $ addAutoDoor (doShift a) (doShift b) w
|
|
PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
|
|
PutBlock{} -> error "messed up block placement somehow"
|
|
PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot)
|
|
(doShift a) (doShift b) speed w
|
|
PutLineBlock wl width depth a b
|
|
-> placeLineBlock wl width depth (doShift a) (doShift b) w
|
|
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
|
|
where
|
|
qs = map doShift ps'
|
|
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
|
|
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
|
|
PutNothing -> (0,w)
|
|
PutID i -> (i, w)
|
|
--_ -> w
|
|
where
|
|
p@(V2 px py) = _psPos ps
|
|
p' = V3 px py 0
|
|
rot = _psRot ps
|
|
doShift = shiftPointBy (p,rot)
|
|
|
|
-- TODO: remove this typeclass
|
|
class Shiftable a where
|
|
translateS :: Point2 -> a -> a
|
|
rotateS :: Float -> a -> a
|
|
|
|
instance {-# OVERLAPPING #-} Shiftable Point2 where
|
|
translateS = (+.+)
|
|
rotateS = rotateV
|
|
|
|
instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
|
|
translateS p (x,y) = (translateS p x,translateS p y)
|
|
rotateS r (x,y) = ( rotateS r x, rotateS r y)
|
|
|
|
instance (Shiftable a) => Shiftable [a] where
|
|
translateS p x = map (translateS p) x
|
|
rotateS r x = map (rotateS r) x
|
|
|
|
instance Shiftable PlacementSpot where
|
|
translateS p' (PS p r x) = PS (p +.+ p') r x
|
|
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
|
|
|
|
shiftPointBy :: (Point2,Float) -> Point2 -> Point2
|
|
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
|
|
|
|
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 (p0,p1) wls = IM.insert (IM.newKey wls) (wl
|
|
{ _wlLine = (p0,p1)
|
|
, _wlID = IM.newKey wls
|
|
})
|
|
wls
|
|
|
|
placeProp
|
|
:: Prop
|
|
-> Point2
|
|
-> Float -- ^ Rotation
|
|
-> World
|
|
-> (Int, World)
|
|
placeProp pr p a w = (i, w & props %~ addProp)
|
|
where
|
|
i = IM.newKey $ _props w
|
|
addProp prs = IM.insert i (f pr) prs
|
|
f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) . (pjID .~ i)
|
|
|
|
placeBt
|
|
:: Button
|
|
-> Point2
|
|
-> Float -- ^ Rotation
|
|
-> World
|
|
-> (Int, World)
|
|
placeBt bt p a w = (i , over buttons addBT w)
|
|
where
|
|
i = IM.newKey $ _buttons w
|
|
addBT xs = IM.insert i (f bt) xs
|
|
f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i)
|
|
--addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
|
|
{- Creates a floor item at a given point.
|
|
Assigns an id correctly. -}
|
|
placeFlIt
|
|
:: Item
|
|
-> Point2 -- ^ Position
|
|
-> Float -- ^ Rotation
|
|
-> World
|
|
-> (Int, World)
|
|
placeFlIt itm p rot w = (i, w & floorItems %~
|
|
\ fis -> IM.insert i
|
|
(FlIt
|
|
{ _flItPos = p
|
|
, _flItRot = rot
|
|
, _flItID = i
|
|
, _flIt = itm
|
|
}
|
|
) fis
|
|
)
|
|
where
|
|
i = IM.newKey $ _floorItems w
|
|
|
|
placePressPlate
|
|
:: PressPlate
|
|
-> Point2
|
|
-> Float -- ^ Rotation
|
|
-> World
|
|
-> (Int, World)
|
|
placePressPlate pp p rot w = (i , over pressPlates addPP w)
|
|
where
|
|
i = IM.newKey $ _pressPlates w
|
|
addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
|
|
|
|
placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
|
|
placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
|
|
where
|
|
cid = IM.newKey (_creatures w)
|
|
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
|
|
|
|
placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
|
|
placeCr crF p rot w = (cid, over creatures addCr w)
|
|
where
|
|
cid = IM.newKey $ _creatures w
|
|
addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs
|
|
|
|
placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
|
|
placeMachine color wallpoly mc p rot w = (mcid
|
|
, w & machines %~ addMc
|
|
& walls %~ placeMachineWalls color wallpoly mcid wlid
|
|
)
|
|
where
|
|
mcid = IM.newKey $ _machines w
|
|
wlid = IM.newKey $ _walls w
|
|
wlids = IS.fromList [wlid .. wlid + length wallpoly]
|
|
addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
|
|
-- 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
|
|
|
|
placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World)
|
|
placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
|
|
where
|
|
i = IM.newKey $ _lightSources w
|
|
startPos = onXY (rotateV rot) $ _lsPos ls
|
|
addLS lss = IM.insert
|
|
(IM.newKey lss)
|
|
(ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss})
|
|
lss
|