diff --git a/yaifl-city/src/Building.hs b/yaifl-city/src/Building.hs index b362210..33589fc 100644 --- a/yaifl-city/src/Building.hs +++ b/yaifl-city/src/Building.hs @@ -17,24 +17,9 @@ import Yaifl.Model.Kinds.Enclosing import Yaifl.Game.Create.RoomConnection import Yaifl.Game.ObjectSpecifics (addDoor, WMHasObjSpecifics) import Yaifl.Model.MultiLocated +import BuildingDefs -data Building wm = Building - { name :: Text - , floors :: NonEmpty (BuildingFloor wm) - , buildingRegion :: RegionEntity - } - -data BuildingFloor wm = BuildingFloor - { level :: Int - , entrances :: Int - , exits :: (RoomEntity, WMDirection wm) - , floorRooms :: [RoomEntity] - , floorRegion :: RegionEntity - } -deriving stock instance Show (WMDirection wm) => Show (Building wm) -deriving stock instance Show (WMDirection wm) => Show (BuildingFloor wm) - -data BuildingPlan (m :: Type -> Type) buildingInputs buildingBase buildingComponent building = BP +data BuildingPlan (m :: Type -> Type) buildingInputs buildingBase buildingComponent building = BuildingPlan { makeName :: m Text , makeNumberOfComponents :: buildingInputs -> m Int , makeBase :: Text -> buildingInputs -> m (buildingBase, buildingComponent) @@ -42,29 +27,27 @@ data BuildingPlan (m :: Type -> Type) buildingInputs buildingBase buildingCompon , makeBuilding :: Text -> buildingInputs -> buildingBase -> NonEmpty buildingComponent -> m building } -runPlan :: - Monad m - => BuildingPlan m i ba c b - -> i - -> m b -runPlan BP{..} i = do - n <- makeName - c <- makeNumberOfComponents i - (b, bc) <- makeBase n i - comps <- foldlM (\prev lvl -> flip NE.cons prev <$> makeComponents n i b prev lvl) (bc:|[]) [0..c-1] - makeBuilding n i b comps +class Plannable plan where + type PlanM plan :: Type -> Type + type PlanInput plan + type PlanOutput plan + runPlan :: Monad (PlanM plan) => plan -> PlanInput plan -> (PlanM plan) (PlanOutput plan) + +instance Plannable (BuildingPlan m i ba c b) where + type PlanM (BuildingPlan m i ba c b) = m + type PlanInput (BuildingPlan m i ba c b) = i + type PlanOutput (BuildingPlan m i ba c b) = b + runPlan BuildingPlan{..} i = do + n <- makeName + c <- makeNumberOfComponents i + (b, bc) <- makeBase n i + comps <- foldlM (\prev lvl -> flip NE.cons prev <$> makeComponents n i b prev lvl) (bc:|[]) [0..c-1] + makeBuilding n i b comps apartmentBuildingPlan :: - Pointed (WMRegionData wm) - => ObjectUpdate wm :> es - => NoMissingObjects wm es - => WMStdDirections wm - => WMWithProperty wm MultiLocated - => WMWithProperty wm Enclosing - => WMHasObjSpecifics wm - => AddObjects wm es + ApartmentFloorGenerator wm es => BuildingPlan (Eff es) (Int, Int) RegionEntity (BuildingFloor wm) (Building wm) -apartmentBuildingPlan = BP +apartmentBuildingPlan = BuildingPlan { makeName = pure "Apartment Building" , makeBase = \name _i -> do r <- addRegion name @@ -75,14 +58,23 @@ apartmentBuildingPlan = BP , makeBuilding = \name _i buildingRegion floors -> return $ Building { name, floors, buildingRegion } } -apartmentFloorGen :: Pointed (WMRegionData wm) - => NoMissingObjects wm es - => WMStdDirections wm - => WMWithProperty wm MultiLocated - => WMWithProperty wm Enclosing - => WMHasObjSpecifics wm - => AddObjects wm es - => Text -> Int -> Maybe (RoomEntity, WMDirection wm) -> Eff es (BuildingFloor wm) +type ApartmentFloorGenerator wm es = + ( Pointed (WMRegionData wm) + , ObjectUpdate wm :> es + , NoMissingObjects wm es + , WMStdDirections wm + , WMWithProperty wm MultiLocated + , WMWithProperty wm Enclosing + , WMHasObjSpecifics wm + , AddObjects wm es + ) + +apartmentFloorGen :: + ApartmentFloorGenerator wm es + => Text + -> Int + -> Maybe (RoomEntity, WMDirection wm) + -> Eff es (BuildingFloor wm) apartmentFloorGen buildingName lvl mbInputs = do -- make the region r <- addRegion (buildingName <> ", Floor " <> show lvl) @@ -104,35 +96,4 @@ apartmentFloorGen buildingName lvl mbInputs = do , exits = (r1, injectDirection $ Up) , floorRooms = [r1] , floorRegion = r - } - -{- -a recursive generator is: -- you have some generic construction. --- you have some amount of the sub-thing to generate, or an end. --- the sub thing gets a long chain of everything that was passed in - - -a sub thing can either be: sequential, or independent - --} -{- -a building: -- has a name and other various properties -- these are actually a property of the building REGION -- then some amount of floors - -a floor: -inherits its name *probably* from the building -- again, a region property -- each floor should have some connection up (possibly) and some connection down (possibly) -or rather, some amounts of entries (inputs) and some amount of exits outputs -where the i/o model is defined by (->). well, it's annoying to have it be in haskell land -but the floor generator should produce something with N exits and feed that N to the -required number of inputs for the next floor (where "exits" are staircases) -and entries are doors for the ground floor and staircases elsewhere - -a floor should be constructed of a number of entry rooms. - -I think we need to have a generic way to build a *building* and then pass in whether it's an apartment or whatever --} \ No newline at end of file + } \ No newline at end of file diff --git a/yaifl-city/src/BuildingDefs.hs b/yaifl-city/src/BuildingDefs.hs new file mode 100644 index 0000000..70a6931 --- /dev/null +++ b/yaifl-city/src/BuildingDefs.hs @@ -0,0 +1,85 @@ +module BuildingDefs where + + +import Solitude hiding (Type) +import Yaifl.Model.Entity +import Yaifl.Model.Kinds.Region +import Yaifl.Game.Create.Object +import Yaifl.Model.WorldModel +import Yaifl.Model.Effects +import Yaifl.Model.Kinds.Object +import Yaifl.Model.Query (isSubregionOf, areInRegion) +import qualified Data.List.NonEmpty as NE +import Yaifl.Model.Kinds.Direction +import Named hiding (Name) +import Yaifl.Model.HasProperty +import Yaifl.Model.Kinds.Enclosing +import Yaifl.Game.Create.RoomConnection +import Yaifl.Game.ObjectSpecifics (addDoor, WMHasObjSpecifics) +import Yaifl.Model.MultiLocated +import Language.Haskell.TH +import Data.Char (toUpper) + +data Building wm = Building + { name :: Text + , floors :: NonEmpty (BuildingFloor wm) + , buildingRegion :: RegionEntity + } + +data BuildingFloor wm = BuildingFloor + { level :: Int + , entrances :: Int + , exits :: (RoomEntity, WMDirection wm) + , floorRooms :: [RoomEntity] + , floorRegion :: RegionEntity + } +deriving stock instance Show (WMDirection wm) => Show (Building wm) +deriving stock instance Show (WMDirection wm) => Show (BuildingFloor wm) + +{- +makePlan "Building" + [ (ParallelSteps [(Step "name"), (Step "numberOfComponents")]) + , (Step "entryRoom") + , (Step "base") + , (IterateStep (BaseCase "entryRoom") "component") + , (Step "building") + ] + +type BuildingPlan m i ba c b = BuildingPlan' m Int Text c ba c b + +defBang :: Bang +defBang = Bang NoSourceUnpackedness NoSourceStrictness + +data Step = Step String | ParallelSteps [Step] | IterateStep BaseCase String +data BaseCase = BaseCase String + +makePlan :: String -> [Step] -> DecsQ +makePlan n steps = pure $ [DataD [] (mkName (n <> "Plan'")) ((PlainTV (mkName "m") BndrReq) : (map (\x -> PlainTV x BndrReq) $ getNamesFromSteps (reverse $ snd mkVars))) Nothing [recCon] []] + where + mkVars = foldl' (\(fields, steps') step -> ((mkStep steps' step) <> fields , step:steps')) ([], []) steps + recCon = RecC (mkName (n <> "Plan")) $ reverse $ fst mkVars + +mkStep :: [Step] -> Step -> [VarBangType] +mkStep prior (Step n) = [(mkName $ "make" <> (over _head toUpper n), defBang, + foldl' (\t f -> AppT (AppT ArrowT f) t) (AppT ((VarT $ mkName "m")) $ VarT (mkName n)) (getTypesFromSteps prior)) ] +mkStep prior (ParallelSteps s) = reverse $ mconcat $ map (mkStep prior) s +mkStep prior (IterateStep (BaseCase b) n) = [(mkName $ "make" <> (over _head toUpper n), defBang, + foldl' (\t f -> AppT (AppT ArrowT (if (mkName b) == f then AppT (ConT (mkName "NonEmpty")) (VarT f) else VarT f)) t) (AppT ((VarT $ mkName "m")) $ VarT (mkName n)) (getNamesFromSteps prior)) ] + +getTypesFromSteps :: [Step] -> [Type] +getTypesFromSteps s = mconcat $ map go s + where + go :: Step -> [Type] + go (Step n) = [VarT (mkName n)] + go (IterateStep _ n) = [VarT (mkName n)] + go (ParallelSteps n) = reverse $ mconcat $ map go n + +getNamesFromSteps :: [Step] -> [Name] +getNamesFromSteps s = mconcat $ map go s + where + go :: Step -> [Name] + go (Step n) = [(mkName n)] + go (IterateStep _ n) = [(mkName n)] + go (ParallelSteps n) = reverse $ mconcat $ map go n + +-} \ No newline at end of file diff --git a/yaifl-city/src/Main.hs b/yaifl-city/src/Main.hs index fc067a7..b9ece5d 100644 --- a/yaifl-city/src/Main.hs +++ b/yaifl-city/src/Main.hs @@ -29,7 +29,7 @@ defaultOptions = ConstructionOptions ActivityCollector ResponseCollector game :: Game PlainWorldModel () game = do setTitle fullTitle - a <- runPlan apartmentBuildingPlan (1, 10000) + -- a <- runPlan apartmentBuildingPlan (1, 10000) --print a before (ActionRule #going) [] "before climbing rule" $ \_ -> do [saying|You climb up the stairs to the next floor.|] diff --git a/yaifl-city/yaifl-city.cabal b/yaifl-city/yaifl-city.cabal index b1d4221..d6abc3b 100644 --- a/yaifl-city/yaifl-city.cabal +++ b/yaifl-city/yaifl-city.cabal @@ -72,6 +72,7 @@ executable yaifl-city hs-source-dirs: src main-is: Main.hs other-modules: Building + BuildingDefs build-depends: , effectful-th