185 lines
6.4 KiB
Haskell
185 lines
6.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 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
|
|
| PutPressPlate PressPlate
|
|
| PutBlock BlockMaterial [Int] Wall [Point2]
|
|
| PutCoordinate Point2
|
|
| PutMod Modification
|
|
| PutTrigger (World -> Bool)
|
|
| PutLineBlock Wall BlockMaterial Float Float Point2 Point2
|
|
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
|
|
| PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
|
|
| PutDoor Color (World -> Bool) [(Point2,Point2)]
|
|
| RandPS (State StdGen PSType)
|
|
| PutForeground Shape
|
|
| PutWorldUpdate (PlacementSpot -> World -> World)
|
|
| PutNothing
|
|
| PutID { _putID :: Int}
|
|
-- maybe there is a monadic implementation of this?
|
|
data PlacementSpot
|
|
= PS { _psPos :: Point2 , _psRot :: Float }
|
|
| PSPos
|
|
{ _psLnkShift :: RoomPos -> Maybe (PlacementSpot, RoomPos)
|
|
, _psLnkRoomEff :: RoomPos -> Room -> Room
|
|
, _psLnkFallback :: Maybe Placement
|
|
}
|
|
| PSRoomRand { _psRoomRandPointNum :: Int }
|
|
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}
|
|
|
|
|
|
{-
|
|
The '_rmPolys' list states 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] ]
|
|
, _rmOutLinks :: [(Point2,Float)]
|
|
, _rmInLinks :: [(Point2,Float)]
|
|
-- 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 :: [Tile]
|
|
, _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
|
|
}
|
|
data RoomLink = RoomLink
|
|
{ _rlType :: RoomLinkType
|
|
, _rlPos :: Point2
|
|
, _rlDir :: Float
|
|
} deriving (Eq,Ord)
|
|
data RoomLinkType
|
|
= OutLink
|
|
| InLink
|
|
| AnyLink
|
|
| LabLink Int
|
|
deriving (Eq,Ord)
|
|
data RoomWire
|
|
= --RoomWire Point2 Float
|
|
WallWire Point2 Float Float
|
|
data RoomPos
|
|
= UsedOutLink Int Point2 Float
|
|
| UsedInLink Point2 Float
|
|
| UnusedLink Point2 Float
|
|
| PosPl Point2 Float
|
|
| LabPos Int RoomPos
|
|
deriving (Eq,Ord,Show)
|
|
|
|
makeLenses ''Room
|
|
makeLenses ''PSType
|
|
makeLenses ''PlacementSpot
|
|
makeLenses ''Placement
|
|
|
|
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) 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)
|
|
where
|
|
g Nothing = Just pl
|
|
g (Just pl') = Just $ addPlmnt pl pl'
|