186 lines
6.5 KiB
Haskell
186 lines
6.5 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# 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.Base
|
|
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 Picture
|
|
|
|
import System.Random
|
|
import Control.Monad.State
|
|
import Control.Applicative
|
|
import Control.Lens
|
|
import Data.List
|
|
import Data.Function
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Set as S
|
|
import qualified Data.Map as M
|
|
|
|
|
|
placeSpots :: [Placement] -> World -> World
|
|
placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements
|
|
where
|
|
(singlePlacements, groupedPlacements) = partition isSPS pss
|
|
isSPS (SinglePlacement {}) = True
|
|
isSPS _ = False
|
|
gplmnts = groupBy ((==) `on` _groupPlacementID) $ sortOn _groupPlacementID groupedPlacements
|
|
w' = foldr updateGroup w gplmnts
|
|
|
|
{- | 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
|
|
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])
|
|
_ -> w
|
|
where
|
|
p = _psPos ps
|
|
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 (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 (newKey wls) (wl
|
|
{ _wlLine = (p0,p1)
|
|
, _wlID = newKey wls
|
|
})
|
|
wls
|
|
|
|
placeBt bt p rot w = over buttons addBT w
|
|
where
|
|
addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = 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 (newKey fis)
|
|
(FlIt
|
|
{ _flItPos = p
|
|
, _flItRot = rot
|
|
, _flItID = newKey fis
|
|
, _flIt = itm
|
|
}
|
|
) fis
|
|
|
|
placePressPlate pp p rot w = over pressPlates addPP w
|
|
where
|
|
addPP pps = IM.insert (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 = newKey (_creatures w)
|
|
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
|
|
|
|
placeCr :: Creature -> Point2 -> Float -> World -> World
|
|
placeCr crF p rot w = over creatures addCr w
|
|
where
|
|
addCr crs = IM.insert (newKey crs)
|
|
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
|
|
crs
|
|
|
|
placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World
|
|
placeLS ls dec p rot w = over lightSources addLS
|
|
$ over decorations addDec w
|
|
where addLS lss = IM.insert (newKey lss)
|
|
(ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss})
|
|
lss
|
|
addDec decs = IM.insert (newKey decs)
|
|
(uncurry translate p $ rotate (0 - rot) dec)
|
|
decs
|
|
|
|
|