264 lines
9.0 KiB
Haskell
264 lines
9.0 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE StrictData #-}
|
|
module Dodge.LevelGen.Data where
|
|
import Dodge.Data
|
|
import Picture
|
|
import Geometry
|
|
--import Color
|
|
import Shape.Data
|
|
import Data.Tile
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.Map.Strict as M
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
import System.Random
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
--import Data.Bifunctor
|
|
|
|
data PSType = PutCrit {_unPutCrit :: Creature}
|
|
| PutMachine { _putMachineColor :: Color, _putMachinePoly :: [Point2], _unPutMachine :: Machine }
|
|
| PutLS LightSource
|
|
| PutButton {_pstPutButton :: Button}
|
|
| PutProp Prop
|
|
| PutFlIt Item
|
|
| PutPPlate PressPlate
|
|
| PutBlock BlockMaterial Int [Int] Wall [Point2]
|
|
| PutCoord Point2
|
|
| PutMod Modification
|
|
| PutTrigger (World -> Bool)
|
|
| PutLineBlock Wall BlockMaterial Float Float Point2 Point2
|
|
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
|
|
| PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
|
|
| PutDoor Color (World -> Bool) [(Point2,Point2)]
|
|
| RandPS (State StdGen PSType)
|
|
| PutShape Shape
|
|
| PutWorldUpdate (PlacementSpot -> World -> World)
|
|
| PutNothing
|
|
| PutUsingGenParams (GenWorld -> (GenWorld,PSType))
|
|
| PutID { _putID :: Int}
|
|
-- maybe there is a monadic implementation of this?
|
|
-- add room effect for any placement spot?
|
|
data PlacementSpot
|
|
= PS { _psPos :: Point2 , _psRot :: Float }
|
|
| PSNoShiftCont { _psPos :: Point2 , _psRot :: Float }
|
|
| PSPos
|
|
{ _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
|
|
, _psRoomEff :: RoomPos -> Room -> Room
|
|
, _psFallback :: Maybe Placement
|
|
}
|
|
| PSRoomRand
|
|
{ _psRoomRandPointNum :: Int
|
|
, _psRandShift :: (Point2,Float) -> PlacementSpot
|
|
}
|
|
-- TODO attempt to unify/simplify this union type
|
|
data Placement
|
|
= Placement
|
|
{ _plSpot :: PlacementSpot
|
|
, _plType :: PSType
|
|
, _plMID :: Maybe Int
|
|
, _plGenUpdate :: Maybe (GenParams -> Placement -> (GenParams, Placement) )
|
|
, _plIDCont :: Placement -> Maybe Placement
|
|
}
|
|
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
|
|
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
|
|
| PickOnePlacement Int Placement
|
|
|
|
{- The '_rmPolys' lists which polygons should be cut out to form the indestructible walls of the room.
|
|
Link pairs contain a position and rotation to attach to another room;
|
|
0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc.
|
|
TODO : Explain path, does it need both directions?
|
|
Placement spots allow things to be put in the room during level generation.
|
|
Room bounds between a new room and previously placed rooms are checked during level generation,
|
|
assigning no bounds will allow rooms to overlap. -}
|
|
data Room = Room
|
|
{ _rmPolys :: [ [Point2] ]
|
|
, _rmLinks :: [RoomLink]
|
|
--, _rmOutLinks :: [RoomLink]
|
|
--, _rmInLinks :: [RoomLink]
|
|
-- update the room when assigning the next link to an adjacent room with the head of of this list, return the tail
|
|
, _rmLinkEff :: [(Point2,Float) -> Room -> Room]
|
|
, _rmPos :: [RoomPos]
|
|
, _rmPath :: [(Point2, Point2)]
|
|
, _rmPmnts :: [Placement]
|
|
, _rmInPmnt :: [InPlacement]
|
|
, _rmOutPmnt :: [OutPlacement]
|
|
, _rmBound :: [ [Point2] ]
|
|
, _rmFloor :: Floor
|
|
, _rmName :: String
|
|
, _rmShift :: (Point2, Float)
|
|
, _rmViewpoints :: [Point2]
|
|
, _rmRandPSs :: [State StdGen (Point2,Float)]
|
|
, _rmStartWires :: IM.IntMap RoomWire
|
|
, _rmEndWires :: IM.IntMap RoomWire
|
|
, _rmConnectsTo :: S.Set RoomLinkType -> Bool
|
|
, _rmMID :: Maybe Int
|
|
, _rmMParent :: Maybe Int
|
|
, _rmChildren :: [Int]
|
|
}
|
|
data RoomLink = RoomLink
|
|
{ _rlType :: S.Set RoomLinkType
|
|
, _rlPos :: Point2
|
|
, _rlDir :: Float
|
|
} deriving (Eq,Ord)
|
|
data RoomLinkType
|
|
= OutLink
|
|
| InLink
|
|
| LabLink Int
|
|
| OnEdge CardinalPoint
|
|
| FromSouth Int
|
|
| FromNorth Int
|
|
| FromWest Int
|
|
| FromEast Int
|
|
deriving (Eq,Ord,Show)
|
|
data CardinalPoint
|
|
= North
|
|
| East
|
|
| South
|
|
| West
|
|
deriving (Eq,Ord,Show)
|
|
data RoomWire
|
|
= --RoomWire Point2 Float
|
|
WallWire Point2 Float Float
|
|
|
|
data RPLinkStatus
|
|
= UsedOutLink
|
|
{ _rplsType :: S.Set RoomLinkType
|
|
, _rplsChildNum :: Int
|
|
, _rplsOutRoomID :: Int
|
|
}
|
|
| UsedInLink
|
|
{ _rplsType :: S.Set RoomLinkType
|
|
, _rplsInRoomID :: Int
|
|
}
|
|
| UnusedLink { _rplsType :: S.Set RoomLinkType }
|
|
| NotLink
|
|
deriving (Eq,Ord,Show)
|
|
data OutPlacement = OutPlacement
|
|
{ _opPlacement :: Placement
|
|
, _opPlacementID :: Int
|
|
}
|
|
data InPlacement = InPlacement
|
|
{ _ipPlacement :: [Placement] -> Placement
|
|
, _ipPlacementID :: Int
|
|
}
|
|
data RoomPos = RoomPos
|
|
{ _rpPos :: Point2
|
|
, _rpDir :: Float
|
|
, _rpType :: S.Set RoomPosType
|
|
, _rpLinkStatus :: RPLinkStatus
|
|
, _rpPlacementUse :: Int
|
|
}
|
|
deriving (Eq,Ord,Show)
|
|
|
|
data RoomPosType
|
|
= RoomPosOnPath
|
|
| RoomPosOffPath
|
|
| RoomPosExLink
|
|
| RoomPosLab Int
|
|
deriving (Eq,Ord,Show)
|
|
data DecorationShape = PlusDecoration | SquareDecoration | CircleDecoration
|
|
| ThreeLineDecoration
|
|
deriving (Eq,Ord,Enum,Show)
|
|
|
|
newtype GenParams = GenParams
|
|
{ _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape)
|
|
}
|
|
|
|
data GenWorld = GenWorld
|
|
{ _gWorld :: World
|
|
, _gPlacements :: IM.IntMap [(Placement,Int)]
|
|
, _gRooms :: IM.IntMap Room
|
|
, _gParams :: GenParams
|
|
}
|
|
|
|
makeLenses ''Room
|
|
makeLenses ''PSType
|
|
makeLenses ''PlacementSpot
|
|
makeLenses ''Placement
|
|
makeLenses ''RoomLink
|
|
makeLenses ''RoomPos
|
|
makeLenses ''RoomPosType
|
|
makeLenses ''RPLinkStatus
|
|
makeLenses ''GenWorld
|
|
makeLenses ''GenParams
|
|
|
|
spNoID :: PlacementSpot -> PSType -> Placement
|
|
spNoID ps pst = Placement ps pst Nothing Nothing (const Nothing)
|
|
|
|
pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
|
|
pContID ps pt = Placement ps pt Nothing Nothing . contToIDCont
|
|
|
|
psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
|
|
psPtCont ps pt = Placement ps pt Nothing Nothing
|
|
|
|
psPt :: PlacementSpot -> PSType -> Placement
|
|
psPt ps pt = Placement ps pt Nothing Nothing (const Nothing)
|
|
|
|
sPS :: Point2 -> Float -> PSType -> Placement
|
|
sPS p a pt = Placement (PS p a) pt Nothing Nothing (const Nothing)
|
|
|
|
sps :: PlacementSpot -> PSType -> Placement
|
|
sps ps pt = Placement ps pt Nothing Nothing (const Nothing)
|
|
|
|
plRRpt :: Int -> PSType -> Placement
|
|
plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing Nothing (const Nothing)
|
|
|
|
jsps :: Point2 -> Float -> PSType -> Maybe Placement
|
|
jsps p a pst = Just $ Placement (PS p a) pst Nothing Nothing $ const Nothing
|
|
|
|
jsps0 :: PSType -> Maybe Placement
|
|
jsps0 = Just . sPS (V2 0 0) 0
|
|
|
|
sps0 :: PSType -> Placement
|
|
sps0 = sPS (V2 0 0) 0
|
|
|
|
jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
|
|
jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing Nothing $ \_ -> Just plm
|
|
|
|
jsps0J :: PSType -> Placement -> Maybe Placement
|
|
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing Nothing $ \_ -> Just plm
|
|
|
|
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
|
|
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing Nothing . contToIDCont
|
|
|
|
pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement
|
|
pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing Nothing
|
|
|
|
contToIDCont :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
|
|
contToIDCont f = f . fromJust . _plMID
|
|
|
|
jps0' :: PSType -> (Placement -> Maybe Placement) -> Maybe Placement
|
|
jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing Nothing
|
|
|
|
jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
|
jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing
|
|
$ \plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
|
|
|
|
ps0j :: PSType -> Placement -> Placement
|
|
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing Nothing (const $ Just plmnt)
|
|
|
|
psj :: PlacementSpot -> PSType -> Placement -> Placement
|
|
psj ps pst plmnt = Placement ps pst Nothing Nothing (const $ Just plmnt)
|
|
|
|
-- the NoShiftCont is necessary when shifting then combining rooms
|
|
ps0jPushPS :: PSType -> Placement -> Placement
|
|
ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing
|
|
$ \p -> Just $ plmnt & plSpot .~ _plSpot p
|
|
|
|
-- the NoShiftCont is necessary when shifting then combining rooms
|
|
ps0PushPS :: PSType -> (Placement -> Maybe Placement) -> Placement
|
|
ps0PushPS pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing
|
|
$ \pl -> f pl & _Just . plSpot %~ const (_plSpot pl)
|
|
|
|
addPlmnt :: Placement -> Placement -> Placement
|
|
addPlmnt pl pl2 = case pl2 of
|
|
(PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
|
|
(RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
|
|
(Placement ps pt mi up f) -> Placement ps pt mi up (fmap g f)
|
|
PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet"
|
|
where
|
|
g Nothing = Just pl
|
|
g (Just pl') = Just $ addPlmnt pl pl'
|