174 lines
6.3 KiB
Haskell
174 lines
6.3 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 :: [PlacementSpot] -> World -> World
|
|
placeSpots pss w = foldr placeSpot w basicPlacements
|
|
where (collectivePlacements,basicPlacements) = partition typeIsCollective pss
|
|
typeIsCollective (ps@PS {}) = case _psType ps of CollectivePS {} -> True
|
|
_ -> False
|
|
typeIsCollective _ = False
|
|
|
|
groupedPlacements = groupBy ((==) `on` _collectiveID . _psType)
|
|
$ sortBy (compare `on` _collectiveID . _psType) collectivePlacements
|
|
|
|
placeSpot :: PlacementSpot -> World -> World
|
|
placeSpot ps w = case ps of
|
|
PS {_psPos = p, _psRot = rot, _psType = PutButton bt}
|
|
-> placeBt bt p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutFlIt itm}
|
|
-> placeFlIt itm p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutCrit cr}
|
|
-> placeCr cr p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec}
|
|
-> placeLS ls dec p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp}
|
|
-> placePressPlate pp p rot w
|
|
PS {_psType = RandPS rgen}
|
|
-> placeSpot (set psType evaluatedType ps) (set randGen g w)
|
|
where (evaluatedType, g) = runState rgen (_randGen w)
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b}
|
|
-> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b}
|
|
-> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps}
|
|
-> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b}
|
|
-> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
|
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b}
|
|
-> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
|
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutLineBlock wl width depth a b}
|
|
-> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
|
|
-> rmCrossPaths $ over walls (addWindow (q:qs) c) w
|
|
where (q:qs) = map (shiftPointBy (p,rot)) ps
|
|
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
|
|
|
|
_ -> w
|
|
|
|
-- 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
|
|
|
|
addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall
|
|
addWindow qs c wls = foldr (addPane c) wls pairs
|
|
where (p:ps) = orderPolygon qs
|
|
pairs = zip (ps ++ [p]) (p:ps)
|
|
addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
|
|
addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1]
|
|
, _wlID = newKey wls
|
|
, _wlColor = c
|
|
, _wlSeen = False
|
|
, _wlIsSeeThrough = True
|
|
}
|
|
) 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
|
|
|
|
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
|
|
|
|
|