222 lines
7.4 KiB
Haskell
222 lines
7.4 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE StrictData #-}
|
|
module Dodge.LevelGen.Data where
|
|
import Dodge.Data
|
|
import Picture
|
|
import Geometry
|
|
import Shape.Data
|
|
import Data.Tile
|
|
|
|
import qualified Data.Set as S
|
|
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 Color [Point2] Machine
|
|
| PutLS LightSource
|
|
| PutButton 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) Point2 Point2 Float
|
|
| PutDoor Color (World -> Bool) [(Point2,Point2)]
|
|
| RandPS (State StdGen PSType)
|
|
| PutShape Shape
|
|
| PutWorldUpdate (PlacementSpot -> World -> World)
|
|
| PutNothing
|
|
| 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 }
|
|
| PSPos
|
|
{ _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
|
|
, _psRoomEff :: RoomPos -> Room -> Room
|
|
, _psFallback :: Maybe Placement
|
|
}
|
|
| PSRoomRand
|
|
{ _psRoomRandPointNum :: Int
|
|
, _psRandShift :: (Point2,Float) -> PlacementSpot
|
|
}
|
|
data Placement
|
|
= Placement
|
|
{ _plSpot :: PlacementSpot
|
|
, _plType :: PSType
|
|
, _plMID :: Maybe Int
|
|
, _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]
|
|
, _rmPartPmnt :: Maybe ([Placement] -> Placement)
|
|
, _rmExtPmnt :: Maybe Placement
|
|
, _rmBound :: [ [Point2] ]
|
|
, _rmFloor :: Floor
|
|
, _rmName :: String
|
|
, _rmShift :: (Point2, Float)
|
|
, _rmViewpoints :: [Point2]
|
|
, _rmRandPSs :: [State StdGen (Point2,Float)]
|
|
, _rmLabel :: Maybe Int
|
|
, _rmTakeFrom :: Maybe Int
|
|
, _rmStartWires :: IM.IntMap RoomWire
|
|
, _rmEndWires :: IM.IntMap RoomWire
|
|
, _rmConnectsTo :: S.Set RoomLinkType
|
|
, _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
|
|
deriving (Eq,Ord)
|
|
data CardinalPoint
|
|
= North
|
|
| East
|
|
| South
|
|
| West
|
|
deriving (Eq,Ord)
|
|
data RoomWire
|
|
= --RoomWire Point2 Float
|
|
WallWire Point2 Float Float
|
|
data RoomPos
|
|
= UsedOutLink
|
|
{_rpChildNum :: Int
|
|
,_rpOutRoomID :: Int
|
|
,_rpPos :: Point2
|
|
,_rpDir :: Float
|
|
}
|
|
| UsedInLink
|
|
{_rpInRoomID :: Int
|
|
,_rpPos :: Point2
|
|
,_rpDir ::Float
|
|
}
|
|
| UnusedLink
|
|
{_rpPos :: Point2
|
|
,_rpDir ::Float
|
|
}
|
|
| UsedSpot
|
|
{_rpPos :: Point2
|
|
,_rpDir :: Float
|
|
}
|
|
| UnusedSpot
|
|
{_rpPos :: Point2
|
|
,_rpDir :: Float
|
|
}
|
|
deriving (Eq,Ord,Show)
|
|
|
|
makeLenses ''Room
|
|
makeLenses ''PSType
|
|
makeLenses ''PlacementSpot
|
|
makeLenses ''Placement
|
|
makeLenses ''RoomLink
|
|
makeLenses ''RoomPos
|
|
|
|
spNoID :: PlacementSpot -> PSType -> Placement
|
|
spNoID ps pst = Placement ps pst Nothing (const Nothing)
|
|
|
|
pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
|
|
pContID ps pt = Placement ps pt Nothing . intPlPlPl
|
|
|
|
psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
|
|
psPtCont ps pt = Placement ps pt Nothing
|
|
|
|
psPt :: PlacementSpot -> PSType -> Placement
|
|
psPt ps pt = Placement ps pt Nothing (const Nothing)
|
|
|
|
sPS :: Point2 -> Float -> PSType -> Placement
|
|
sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)
|
|
|
|
sps :: PlacementSpot -> PSType -> Placement
|
|
sps ps pt = Placement ps pt Nothing (const Nothing)
|
|
|
|
plRRpt :: Int -> PSType -> Placement
|
|
plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing (const Nothing)
|
|
|
|
jsps :: Point2 -> Float -> PSType -> Maybe Placement
|
|
jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const Nothing
|
|
|
|
jsps0 :: PSType -> Maybe Placement
|
|
jsps0 pst = Just $ sPS (V2 0 0) 0 pst
|
|
|
|
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 $ \_ -> Just plm
|
|
|
|
jsps0J :: PSType -> Placement -> Maybe Placement
|
|
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ -> Just plm
|
|
|
|
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
|
|
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
|
|
|
|
pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement
|
|
pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing
|
|
|
|
contToIDCont :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
|
|
contToIDCont f plmnt = f $ fromJust (_plMID plmnt)
|
|
|
|
intPlPlPl :: (Int -> Maybe Placement) -> Placement -> Maybe Placement
|
|
intPlPlPl f = f . fromJust . _plMID
|
|
|
|
jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
|
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
|
|
|
|
jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
|
jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing
|
|
$ \plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
|
|
|
|
ps0j :: PSType -> Placement -> Placement
|
|
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt)
|
|
|
|
psj :: PlacementSpot -> PSType -> Placement -> Placement
|
|
psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt)
|
|
|
|
ps0jPushPS :: PSType -> Placement -> Placement
|
|
ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p)
|
|
|
|
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 f) -> Placement ps pt mi (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'
|