205 lines
7.0 KiB
Haskell
205 lines
7.0 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.Room.Data
|
|
import Dodge.LevelGen.Block
|
|
import Dodge.LevelGen.LineBlock
|
|
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 Geometry
|
|
import Geometry.Data
|
|
import Picture
|
|
import Polyhedra
|
|
import qualified IntMapHelp as IM
|
|
|
|
--import System.Random
|
|
import Control.Monad.State
|
|
--import Control.Applicative
|
|
import Control.Lens
|
|
import Data.List.Extra
|
|
--import Data.Function
|
|
--import Data.Maybe
|
|
--import qualified Data.Set as S
|
|
--import qualified Data.Map as M
|
|
|
|
placeSpots :: [Placement] -> World -> World
|
|
placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements
|
|
where
|
|
(singlePlacements, groupedPlacements) = partition isSPS pss
|
|
isSPS SinglePlacement{} = True
|
|
isSPS _ = False
|
|
gplmnts :: [[Placement]]
|
|
gplmnts = groupOn _groupPlacementID $ sortOn _groupPlacementID groupedPlacements
|
|
w' = foldr putGroup w gplmnts
|
|
putGroup :: [Placement] -> World -> World
|
|
putGroup gps w'' = (_groupUpdate $ head gps) w'' gps
|
|
|
|
{- | OK, this is perhaps slightly impenetrable.
|
|
- The idea is that for a list of collected group placements, we first update
|
|
- the world for each placement and update the placements into PSTypes.
|
|
- This is the mapAccumR step.
|
|
- After this, for each placement we apply the group placement function to
|
|
- the psType using a zipWith, and taking all the pstypes as a paramenter,
|
|
- then successively update the world using a foldr. -}
|
|
--updateGroup :: [Placement] -> World -> World
|
|
--updateGroup ps w =
|
|
-- let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps
|
|
-- fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes
|
|
-- in foldr ($) w' fs
|
|
--{- | -}
|
|
--updateSpot :: World -> PlacementSpot -> (World, PSType)
|
|
--updateSpot w ps = case _psType ps of
|
|
-- PutButton bt -> undefined
|
|
-- PutCrit cr -> placeUpdateCr cr p rot w
|
|
-- where
|
|
-- p = _psPos ps
|
|
-- rot = _psRot ps
|
|
{- | -}
|
|
placeSpot :: PlacementSpot -> World -> World
|
|
placeSpot ps w = case _psType ps of
|
|
PutButton bt -> placeBt bt p rot w
|
|
PutFlIt itm -> placeFlIt itm p rot w
|
|
PutCrit cr -> placeCr cr p rot w
|
|
PutLS ls dec -> placeLS ls dec p' rot w
|
|
PutPressPlate pp -> placePressPlate pp p rot w
|
|
RandPS rgen -> placeSpot (set psType evaluatedType ps) (set randGen g w)
|
|
where
|
|
(evaluatedType, g) = runState rgen (_randGen w)
|
|
PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
|
|
where
|
|
mapBoth fn (x,y) = (fn x, fn y)
|
|
PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
|
|
PutBlock{} -> error "messed up block placement somehow"
|
|
PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
|
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
|
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
PutLineBlock wl width depth a b
|
|
-> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
|
|
where
|
|
(q:qs) = map (shiftPointBy (p,rot)) ps'
|
|
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
|
|
PutForeground poly -> w & foregroundDecorations %~ (map (uncurryV translateXY p . rotateXY rot) poly ++)
|
|
PutNothing -> w
|
|
PutID _ -> w
|
|
--_ -> w
|
|
where
|
|
p@(V2 px py) = _psPos ps
|
|
p' = (V3 px py 0)
|
|
rot = _psRot ps
|
|
|
|
-- 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
|
|
|
|
placeBt
|
|
:: Button
|
|
-> Point2
|
|
-> Float -- ^ Rotation
|
|
-> World
|
|
-> World
|
|
placeBt bt p rot = over buttons addBT
|
|
where
|
|
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
|
|
-> World
|
|
placeFlIt itm p rot = floorItems %~
|
|
\ fis -> IM.insert (IM.newKey fis)
|
|
(FlIt
|
|
{ _flItPos = p
|
|
, _flItRot = rot
|
|
, _flItID = IM.newKey fis
|
|
, _flIt = itm
|
|
}
|
|
) fis
|
|
|
|
placePressPlate
|
|
:: PressPlate
|
|
-> Point2
|
|
-> Float -- ^ Rotation
|
|
-> World
|
|
-> World
|
|
placePressPlate pp p rot = over pressPlates addPP
|
|
where
|
|
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 -> World
|
|
placeCr crF p rot = over creatures addCr
|
|
where
|
|
addCr crs = IM.insert
|
|
(IM.newKey crs)
|
|
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs})
|
|
crs
|
|
|
|
placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World
|
|
placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations addDec w
|
|
where
|
|
addLS lss = IM.insert
|
|
(IM.newKey lss)
|
|
(ls {_lsPos = (V3 x y z),_lsDir = rot,_lsID = IM.newKey lss})
|
|
lss
|
|
addDec decs = IM.insert
|
|
(IM.newKey decs)
|
|
(translate x y $ rotate (negate rot) dec)
|
|
decs
|