Refactor, try to limit dependencies

2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
@@ -0,0 +1,143 @@
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Dodge.Data.GenWorld (
+    module Dodge.Data.GenWorld,
+    module Dodge.Data.Room,
+    module Dodge.Data.RoomCluster,
+    module Dodge.Data.World,
+) where
+
+import Color
+import Control.Lens
+import Control.Monad.State
+import qualified Data.Set as S
+import Data.Tile
+import Dodge.Data.Room
+import Dodge.Data.RoomCluster
+import Dodge.Data.World
+import Geometry.Data
+import qualified IntMapHelp as IM
+import Picture.Data
+import System.Random
+
+data GenWorld = GenWorld
+    { _gwWorld :: World
+    , _genPlacements :: IM.IntMap [(Placement, Int)]
+    , _genRooms :: IM.IntMap Room
+    }
+
+---- ROOM DATATYPES
+data PSType
+    = PutCrit {_unPutCrit :: Creature}
+    | PutMachine {_putMachinePoly :: [Point2], _putMachineMachine :: Machine, _putMachineWall :: Wall}
+    | PutLS LightSource
+    | PutButton {_putButton :: Button}
+    | PutProp Prop
+    | PutTerminal {_unputTerminal :: Terminal}
+    | PutFlIt {_putItem :: Item}
+    | PutPPlate PressPlate
+    | PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2]}
+    | PutCoord Point2
+    | PutMod Modification
+    | PutTrigger Bool
+    | PutLineBlock
+        { _putWall :: Wall
+        , _putWidth :: Float
+        , _putStartPoint :: Point2
+        , _putEndPoint :: Point2
+        }
+    | PutWall {_pwPoly :: [Point2], _pwWall :: Wall}
+    | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2
+    | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)]
+    | RandPS (State StdGen PSType)
+    | PutForeground ForegroundShape
+    | PutDecoration Picture
+    | PutWorldUpdate (PlacementSpot -> World -> World)
+    | PutNothing
+    | PutUsingGenParams (World -> (World, 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
+        { _plOrder :: Int
+        , _plSpot :: PlacementSpot
+        , _plType :: PSType
+        , _plMID :: Maybe Int
+        , _plIDCont :: World -> 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]
+    , --  the Int is the number of previous outlinks that have been assigned
+      _rmLinkEff ::
+        RoomLink -> -- child link
+        Room -> -- child room
+        Int -> -- child number
+        RoomLink -> -- parent link
+        Room -> -- parent room
+        Room
+    , _rmPos :: [RoomPos]
+    , _rmPath :: S.Set (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]
+    , _rmType :: RoomType
+    , _rmClusterStatus :: ClusterStatus
+    }
+
+data OutPlacement = OutPlacement
+    { _opPlacement :: Placement
+    , _opPlacementID :: Int
+    }
+
+data InPlacement = InPlacement
+    { _ipPlacement :: [Placement] -> Placement
+    , _ipPlacementID :: Int
+    }
+
+makeLenses ''GenWorld
+makeLenses ''Room
+makeLenses ''RoomType
+makeLenses ''PSType
+makeLenses ''PlacementSpot
+makeLenses ''Placement