Start on doing actual room generation

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])

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"

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
+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)
+  )

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,)
+equalWeights = fmap (Weight 1,)
+
+oneOption :: PlanOption es a b -> NonEmpty (Weight, PlanOption es a b)
+oneOption = equalWeights . one

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