loop/src/Dodge/Data/GenWorld.hs

{-# 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 ShortShow
import Control.Lens
--import Control.Monad.State
import Control.Monad.Trans.State.Lazy
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 System.Random

data GenWorld = GenWorld
    { _gwWorld :: World
    , _genRooms :: IM.IntMap Room
    , _genPmnt :: IM.IntMap Placement  -- stored generated placements
    , _genInts :: IM.IntMap Int
    }

---- ROOM DATATYPES
data PSType
    = PutCrit {_unPutCrit :: Creature}
    | PutMachine
        { _putMachineMachine :: Machine
        , _putMachineMaybeItem :: Maybe Item
        }
    | PutLS {_putLS :: LightSource}
    | PutButton {_putButton :: Button}
    | PutProp Prop
    | PutTerminal {_unputTerminal :: Terminal}
    | PutFlIt {_putItem :: Item}
    | 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}
    | PutDoor {_putDoorDoor :: Door, _putDoorWall :: Wall}
    | RandPS (State StdGen PSType)
    | PutForeground ForegroundShape
    | PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld) -- the Int is the roomid
    | PutNothing
    | PutID {_putID :: Int}
    | PutChasm {_putChasmChasms :: [[Point2]], _putChasmCliffs :: [[Point2]]}
        -- the chasms should be a convex partition of the cliffs.
        -- Chasm and cliff polygons are orientated anticlockwise, so platforms 
        -- within a chasm will appear as a clockwise oriented list of points
        -- in _putChasmCliffs.
    | PutLabel {_putLabel :: String} -- currently not actually put anywhere
        -- just used for later inspection as top level 
        -- of a continuing placement in a room placement list

putConvexChasm :: [Point2] -> PSType
putConvexChasm ps = PutChasm [ps] [ps]

instance ShortShow PSType where
    shortShow PutCrit {} = "PutCrit"
    shortShow PutMachine {} = "PutMachine"
    shortShow PutLS {} = "PutLS"
    shortShow PutButton {} = "PutButton"
    shortShow PutProp {} = "PutProp"
    shortShow PutTerminal {} = "PutTerminal"
    shortShow PutFlIt {} = "PutFlIt"
    shortShow PutBlock {} = "PutBlock"
    shortShow PutCoord {} = "PutCoord"
    shortShow PutMod {} = "PutMod"
    shortShow PutTrigger {} = "PutTrigger"
    shortShow PutLineBlock {} = "PutLineBlock"
    shortShow PutWall {} = "PutWall"
    shortShow PutDoor {} = "PutDoor"
    shortShow RandPS {} = "RandPS"
    shortShow PutForeground {} = "PutForeground"
    shortShow PutWorldUpdate {} = "PutWorldUpdate"
    shortShow PutNothing = "PutNothing"
    shortShow PutID {} = "PutID"
    shortShow PutChasm {} = "PutChasm"
    shortShow PutLabel {} = "PutLabel"

-- 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)
        -- looks for the first rp for which a rp rm returns Just (ps,rp'),
        -- replaces the rp with rp'
        , _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
    , _plExternalID :: Maybe Int
    , _plIDCont :: GenWorld -> Placement -> Maybe 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 :: [(Int,GenWorld -> State StdGen Placement)]  -- so far as I can tell,
        -- the first Int only determines the order in which these are applied
    , _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
    }

makeLenses ''GenWorld
makeLenses ''Room
makeLenses ''RoomType
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Placement

-- I may regret this. I believe it satisfies associativity, but haven't thought
-- about it too much.
instance Semigroup Placement where
    p <> q = p & plIDCont %~ f
      where
        f g gw pl = case g gw pl of
            Nothing -> Just q
            Just r -> Just $ r & plIDCont %~ f