From 00f6a53f658883911169f2c92e9245d21470ab90 Mon Sep 17 00:00:00 2001 From: PPKFS Date: Tue, 30 Apr 2024 22:30:58 +0200 Subject: [PATCH] Start on doing actual room generation --- yaifl-city/src/Yaifl/Gen/City/Apartment.hs | 86 +++++++++++++++++++ .../src/Yaifl/Gen/City/ApartmentTower.hs | 39 +++------ yaifl-city/src/Yaifl/Gen/City/Building.hs | 23 ++++- yaifl-city/src/Yaifl/Gen/Plan.hs | 12 ++- yaifl-city/yaifl-city.cabal | 1 + 5 files changed, 131 insertions(+), 30 deletions(-) create mode 100644 yaifl-city/src/Yaifl/Gen/City/Apartment.hs diff --git a/yaifl-city/src/Yaifl/Gen/City/Apartment.hs b/yaifl-city/src/Yaifl/Gen/City/Apartment.hs new file mode 100644 index 0000000..f7f0f5f --- /dev/null +++ b/yaifl-city/src/Yaifl/Gen/City/Apartment.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE RecordWildCards #-} +module Yaifl.Gen.City.Apartment + ( apartmentPlan + + ) where + +import Yaifl.Prelude +import Yaifl.Gen.Plan +import Control.Placeholder +import Yaifl.Model.WorldModel +import Yaifl.Model.Kinds.Region +import Yaifl.Game.Create +import Yaifl.Model.Entity +import Yaifl.Model.Rules +import Yaifl.Gen.City.Building + +data RoomType = LivingRoom | Kitchen | Bathroom | Bedroom | Study + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + +data ApartmentPlan es inputs base room (apartment :: Type) = ApartmentPlan + { baseOptions :: Options es inputs base + , hallwayOptions :: Options es base room + , roomOptions :: RoomType -> Options es base room + , build :: base -> NonEmpty room -> Eff es apartment + } + +type ApartmentFoyerPlan es b f = PlanOption es (RegionEntity, b) f +type ApartmentFloorPlan es b f = PlanOption es (RegionEntity, (Int, (b, f), [f])) f +type ApartmentPlan' es wm = ApartmentPlan es (WMDirection wm, Int, Int) (ApartmentBase wm) (ApartmentRoom wm) (Apartment wm) + +data ApartmentBase (wm :: WorldModel) = ApartmentBase + { name :: Text + , number :: Int + } +data ApartmentRoom wm +data Apartment wm + +apartmentPlan :: BuildingGeneration wm es => ApartmentPlan' es wm +apartmentPlan = ApartmentPlan + { baseOptions = oneOption makeApartmentBase + , hallwayOptions = oneOption makeLongHallway + , roomOptions = \rt -> beforePlanWith (\v -> makeApartmentRoom rt v) $ equalWeights $ case rt of + LivingRoom -> one makeLivingRoom + Kitchen -> one makeKitchen + Bathroom -> one makeBathroom + Bedroom -> one makeLivingRoom + Study -> one makeStudy + , build = \base rooms -> do + error "" + } + +makeStudy :: (RoomEntity, ApartmentBase wms) -> Eff es (ApartmentRoom wms) +makeStudy = todo + +makeBathroom :: (RoomEntity, ApartmentBase wms) -> Eff es (ApartmentRoom wms) +makeBathroom = todo + +makeKitchen :: (RoomEntity, ApartmentBase wms) -> Eff es (ApartmentRoom wms) +makeKitchen = todo + +makeLivingRoom :: (RoomEntity, ApartmentBase wms) -> Eff es (ApartmentRoom wms) +makeLivingRoom = todo + +makeApartmentRoom :: BuildingGeneration wm es => RoomType -> ApartmentBase wm -> Eff es RoomEntity +makeApartmentRoom rt base = do + let name = makeApartmentRoomName rt base + addRoom name ! done + +makeApartmentRoomName :: IsString (WMSayable wm) => RoomType -> ApartmentBase wm -> WMSayable wm +makeApartmentRoomName rt (ApartmentBase{name}) = fromString $ toString $ name <> " " <> show rt + +makeLongHallway :: PlanOption es (ApartmentBase wms) (ApartmentRoom wms) +makeLongHallway = todo + +makeApartmentBase :: PlanOption es (WMDirection wms, Int, Int) (ApartmentBase wms) +makeApartmentBase = todo + +instance Plannable (ApartmentPlan es i b r a) where + type PlanM (ApartmentPlan es i b r a) = Eff es + type PlanInput (ApartmentPlan es i b r a) = i + type PlanOutput (ApartmentPlan es i b r a) = a + runPlan ApartmentPlan{..} i = do + b <- pickOne baseOptions i + h <- pickOne hallwayOptions b + rs <- pickOne (roomOptions LivingRoom) b + build b (h:|[rs]) \ No newline at end of file diff --git a/yaifl-city/src/Yaifl/Gen/City/ApartmentTower.hs b/yaifl-city/src/Yaifl/Gen/City/ApartmentTower.hs index 28772b4..2ed2cf4 100644 --- a/yaifl-city/src/Yaifl/Gen/City/ApartmentTower.hs +++ b/yaifl-city/src/Yaifl/Gen/City/ApartmentTower.hs @@ -9,21 +9,16 @@ import Yaifl.Gen.Plan 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) import Yaifl.Model.Kinds.Direction -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 Yaifl.Game.ObjectSpecifics (addDoor) +import Yaifl.Gen.City.Apartment import Yaifl.Gen.City.Building import Control.Placeholder (todo) import Control.Placeholder (pattern TODO) import GHC.TypeLits import Yaifl.Text.DynamicText -import Yaifl.Model.Rules (RuleEffects) data TowerBuildingPlan es inputs base floor (building :: Type) = TowerBuildingPlan { baseOptions :: Options es inputs base @@ -32,7 +27,7 @@ data TowerBuildingPlan es inputs base floor (building :: Type) = TowerBuildingPl , build :: base -> NonEmpty floor -> Eff es building } -instance LabelOptic' "numberOfFloors" A_Lens ba Int => Plannable (TowerBuildingPlan es i ba f b) where +instance LabelOptic' "numberOfFloors" A_Lens ba Int => Plannable (TowerBuildingPlan es i ba f b) where type PlanM (TowerBuildingPlan es i ba f b) = Eff es type PlanInput (TowerBuildingPlan es i ba f b) = i type PlanOutput (TowerBuildingPlan es i ba f b) = b @@ -42,30 +37,18 @@ instance LabelOptic' "numberOfFloors" A_Lens ba Int => Plannable (TowerBuilding fs <- pickSequential (b ^. #numberOfFloors) (b, f) floorOptions build b (f:|fs) - type ApartmentFoyerPlan es b f = PlanOption es (RegionEntity, b) f type ApartmentFloorPlan es b f = PlanOption es (RegionEntity, (Int, (b, f), [f])) f type ApartmentTowerPlan es wm = TowerBuildingPlan es (WMDirection wm, Int) (ApartmentTowerBase wm) (BuildingFloor wm) (Building wm) -type ApartmentFloorGenerator wm es = - ( Pointed (WMRegionData wm) - , ObjectUpdate wm :> es - , NoMissingObjects wm es - , WMStdDirections wm - , WMWithProperty wm MultiLocated - , WMWithProperty wm Enclosing - , WMHasObjSpecifics wm - , RuleEffects wm es - , AddObjects wm es - , Semigroup (WMSayable wm) - ) + data FloorBase wm = FloorBase { floorNumber :: Int , towerBase :: ApartmentTowerBase wm } deriving stock (Generic) -apartmentTowerPlan :: ApartmentFloorGenerator wm es => ApartmentTowerPlan es wm +apartmentTowerPlan :: BuildingGeneration wm es => ApartmentTowerPlan es wm apartmentTowerPlan = TowerBuildingPlan { baseOptions = equalWeights $ one makeBuildingBase , foyerOptions = beforePlanWith (\v -> makeFloor (FloorBase 0 v )) $ equalWeights $ fromList @@ -84,17 +67,17 @@ apartmentTowerPlan = TowerBuildingPlan singleApartmentFloor :: ApartmentFloorPlan es (ApartmentTowerBase wm) (BuildingFloor wm) singleApartmentFloor = todo -landing2Apartment :: ApartmentFloorGenerator wm es => ApartmentFloorPlan es (ApartmentTowerBase wm) (BuildingFloor wm) +landing2Apartment :: BuildingGeneration wm es => ApartmentFloorPlan es (ApartmentTowerBase wm) (BuildingFloor wm) landing2Apartment (floorRegion, (floorNum, (building, foyer), prevFloors)) = do r1 <- addRoom (fromString $ toString $ (building ^. #name) <> ", Floor " <> show floorNum <> "; Hallway") ! #description "The hallway landing is threadbare, with a clearly worn trail across the carpet towards the two apartment doors." ! done let belowFloor = ((fromMaybe foyer $ viaNonEmpty head prevFloors) ^. #exits % _1) - --r1 `isAbove` belowFloor - _d <- addDoor "staircase" + addDoor "staircase" ! #front (belowFloor, injectDirection $ Up) ! #back (r1, injectDirection $ Down) ! done + ap1 <- runPlan apartmentPlan (todo, 1, 1) pure $ BuildingFloor { level = 0 , entrances = 1 @@ -118,7 +101,7 @@ foyerDescription :: -> DynamicText wm foyerDescription (argF #size -> s) (argF #wayOut -> wo) (argF #stairsUp -> su) = todo -smallFoyer1Staircase :: forall wm es. ApartmentFloorGenerator wm es => ApartmentFoyerPlan es (ApartmentTowerBase wm) (BuildingFloor wm) +smallFoyer1Staircase :: forall wm es. BuildingGeneration wm es => ApartmentFoyerPlan es (ApartmentTowerBase wm) (BuildingFloor wm) smallFoyer1Staircase (floorRegion, building) = do -- if the entrance of the building is on the WEST of the building, then going EAST from outside should go into the building -- and going WEST out of the building @@ -153,14 +136,14 @@ type With (n :: Symbol) i o = LabelOptic' n A_Lens i o makeFloor :: With "floorNumber" i Int => With "towerBase" i (ApartmentTowerBase wm) - => ApartmentFloorGenerator wm es + => BuildingGeneration wm es => i -> Eff es RegionEntity makeFloor f = do r <- addRegion (f ^. #towerBase % #name <> ", Floor " <> show (f ^. #floorNumber)) r `isSubregionOf` (f ^. #towerBase % #region) pure $ r -makeBuildingBase :: ApartmentFloorGenerator wm es => PlanOption es (WMDirection wm, Int) (ApartmentTowerBase wm) +makeBuildingBase :: BuildingGeneration wm es => PlanOption es (WMDirection wm, Int) (ApartmentTowerBase wm) makeBuildingBase (entranceIsOnFace, numberOfFloors) = do let name = "Apartment Building" region <- addRegion "Apartment Building" diff --git a/yaifl-city/src/Yaifl/Gen/City/Building.hs b/yaifl-city/src/Yaifl/Gen/City/Building.hs index 6167e7a..591cfa1 100644 --- a/yaifl-city/src/Yaifl/Gen/City/Building.hs +++ b/yaifl-city/src/Yaifl/Gen/City/Building.hs @@ -2,12 +2,20 @@ module Yaifl.Gen.City.Building ( Building(..) , BuildingFloor(..) , ApartmentTowerBase(..) +, BuildingGeneration ) where import Yaifl.Prelude import Yaifl.Model.Entity import Yaifl.Model.Kinds.Region import Yaifl.Model.WorldModel +import Yaifl.Model.Kinds +import Yaifl.Model.Effects +import Yaifl.Model.Rules.RuleEffects +import Yaifl.Model.HasProperty +import Yaifl.Game.Create +import Yaifl.Model.MultiLocated +import Yaifl.Model.Kinds.Enclosing data Building wm = Building { name :: Text @@ -37,4 +45,17 @@ deriving stock instance Show (WMDirection wm) => Show (ApartmentTowerBase wm) deriving stock instance Eq (WMDirection wm) => Eq (ApartmentTowerBase wm) makeFieldLabelsNoPrefix ''ApartmentTowerBase -makeFieldLabelsNoPrefix ''BuildingFloor \ No newline at end of file +makeFieldLabelsNoPrefix ''BuildingFloor + +type BuildingGeneration wm es = + ( Pointed (WMRegionData wm) + , ObjectUpdate wm :> es + , RuleEffects wm es + , NoMissingObjects wm es + , WMStdDirections wm + , WMWithProperty wm MultiLocated + , WMWithProperty wm Enclosing + , WMHasObjSpecifics wm + , AddObjects wm es + , Semigroup (WMSayable wm) + ) \ No newline at end of file diff --git a/yaifl-city/src/Yaifl/Gen/Plan.hs b/yaifl-city/src/Yaifl/Gen/Plan.hs index 93db5b3..c4aece2 100644 --- a/yaifl-city/src/Yaifl/Gen/Plan.hs +++ b/yaifl-city/src/Yaifl/Gen/Plan.hs @@ -6,6 +6,9 @@ module Yaifl.Gen.Plan , Options2 , Options3 , Options4 + , PlanOption2 + , PlanOption3 + , PlanOption4 , SequentialOptions , SequentialOptions2 , SequentialOptions3 @@ -15,6 +18,7 @@ module Yaifl.Gen.Plan , beforePlanWith , equalWeights + , oneOption ) where @@ -32,6 +36,9 @@ type Options es a b = NonEmpty (Weight, PlanOption es a b) type Options2 es a b c = Options es (a, b) c type Options3 es a b c d = Options es (a, b, c) d type Options4 es a b c d e = Options es (a, b, c, d) e +type PlanOption2 es a b c = PlanOption es (a, b) c +type PlanOption3 es a b c d = PlanOption es (a, b, c) d +type PlanOption4 es a b c d e = PlanOption es (a, b, c, d) e type SequentialOptions es a b = Options es (Int, a, [b]) b type SequentialOptions2 es a b c = SequentialOptions es (a, b) c type SequentialOptions3 es a b c d = SequentialOptions es (a, b, c) d @@ -46,4 +53,7 @@ beforePlanWith :: (a -> Eff es c) -> NonEmpty (Weight, PlanOption es (c, a) b) - beforePlanWith bef = fmap (second (\f -> \a -> bef a >>= \b -> f (b, a))) equalWeights :: NonEmpty (PlanOption es a b) -> NonEmpty (Weight, PlanOption es a b) -equalWeights = fmap (Weight 1,) \ No newline at end of file +equalWeights = fmap (Weight 1,) + +oneOption :: PlanOption es a b -> NonEmpty (Weight, PlanOption es a b) +oneOption = equalWeights . one \ No newline at end of file diff --git a/yaifl-city/yaifl-city.cabal b/yaifl-city/yaifl-city.cabal index 42d0883..d97caf4 100644 --- a/yaifl-city/yaifl-city.cabal +++ b/yaifl-city/yaifl-city.cabal @@ -76,6 +76,7 @@ executable yaifl-city Yaifl.Gen.Plan Yaifl.Gen.City.Building Yaifl.Gen.City.ApartmentTower + Yaifl.Gen.City.Apartment build-depends: , effectful-th