More work on the city

yaifl-city/src/Building.hs

@@ -17,54 +17,37 @@ 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)
   , makeComponents :: Text -> buildingInputs -> buildingBase -> NonEmpty buildingComponent -> Int -> m buildingComponent
   , 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
--}
+    }

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

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

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