Lab generation WIP. Refactoring.

app/labyrinth/src/Labyrinth/App.hs

@@ -183,14 +183,14 @@ handleNo st = do
     PlayerIsAboutLossLeavingConfirmation -> cancelPlayerLeaving st
     _ -> addMoveMessage st $ unknownCommand "no"
 
-printLabyrinth :: AppState -> LangL ()
-printLabyrinth st = do
+printLab :: AppState -> LangL ()
+printLab st = do
   lab               <- readVarIO $ st ^. labyrinth
   bounds            <- readVarIO $ st ^. labyrinthSize
   plPos             <- readVarIO $ st ^. playerPos
   let template = st ^. labRenderTemplate
 
-  printLabRender bounds $ renderLabyrinth template lab plPos
+  printLabRender' $ renderLabyrinth' template lab plPos
 
 onStep :: AppState -> () -> AppL D.CliAction
 onStep st _ = do
@@ -246,7 +246,7 @@ app st = do
     cmd "quit"     $ quit st
     cmd "q"        $ quit st
 
-    cmd "print"    $ printLabyrinth st
+    cmd "print"    $ printLab st
 
   atomically $ do
     finished <- readVar $ D.cliFinishedToken cliToken

app/labyrinth/src/Labyrinth/Domain.hs

@@ -6,12 +6,18 @@ import Labyrinth.Prelude as L
 
 type Pos = (Int, Int)
 type Bounds = (Int, Int)
+type Wormholes = Map Int Pos
 
+type LabRender = (Bounds, Map Pos String)
+type Skeleton = LabRender
 
-data Direction = DirUp | DirDown | DirLeft | DirRight
+data Direction
+  = DirUp
+  | DirDown
+  | DirLeft
+  | DirRight
   deriving (Show, Read, Eq)
 
-
 data Wall
   = NoWall
   | Wall
@@ -32,4 +38,14 @@ data Content
   | Wormhole Int
   deriving (Show, Read, Eq)
 
-type Labyrinth = Map.Map Pos (Cell, Content)
+type Labyrinth = Map Pos (Cell, Content)
+
+increaseBounds :: Bounds -> Pos -> Bounds
+increaseBounds (x', y') (x, y) = (max x' (x + 1), max y' (y + 1))
+
+analyzeLabyrinth :: Labyrinth -> (Bounds, Wormholes)
+analyzeLabyrinth lab = Map.foldrWithKey f ((0, 0), Map.empty) lab
+  where
+    f :: Pos -> (Cell, Content) -> (Bounds, Wormholes) -> (Bounds, Wormholes)
+    f pos (_, Wormhole n) (bounds, wormholes) = (increaseBounds bounds pos, Map.insert n pos wormholes)
+    f pos _ (bounds, wormholes) = (increaseBounds bounds pos, wormholes)

app/labyrinth/src/Labyrinth/Gen.hs

@@ -6,15 +6,36 @@ import Labyrinth.Prelude
 import Labyrinth.Domain
 import Labyrinth.Types
 
+generateGrid :: Int -> Int -> LangL Labyrinth
+generateGrid xSize ySize = pure $ Map.fromList $ do
+  x' <- [0..xSize-1]
+  y' <- [0..ySize-1]
+  let leftW  = if x' == 0       then (Monolith False) else Wall
+  let rightW = if x' == xSize-1 then (Monolith False) else Wall
+  let upW    = if y' == 0       then (Monolith False) else Wall
+  let downW  = if y' == ySize-1 then (Monolith False) else Wall
+  pure ((x', y'), (Cell leftW rightW upW downW, NoContent))
+
+generatePaths :: Int -> Int -> Labyrinth -> LangL Labyrinth
+generatePaths xSize ySize grid = do
+  cellsLeftVar <- evalIO $ newIORef [(x, y) | x <- [0..xSize], y <- [0..ySize]]
+  -- rndDirs      <- replicateM (xSize * ySize) (getRandomInt (0, 3))
+  -- rndDirsVar   <- evalIO $ newIORef
+
+  x <- getRandomInt (0, xSize - 1)
+  y <- getRandomInt (0, ySize - 1)
+
+  pure grid
+
+
 generateLabyrinth :: LangL Labyrinth
-generateLabyrinth = throwException $ NotImplemented "Generation"
-
-
-analyzeLabyrinth :: Labyrinth -> (Bounds, Wormholes)
-analyzeLabyrinth lab = Map.foldrWithKey f ((0, 0), Map.empty) lab
-  where
-    increaseBounds :: Bounds -> Pos -> Bounds
-    increaseBounds (x', y') (x, y) = (max x' (x + 1), max y' (y + 1))
-    f :: Pos -> (Cell, Content) -> (Bounds, Wormholes) -> (Bounds, Wormholes)
-    f pos (_, Wormhole n) (bounds, wormholes) = (increaseBounds bounds pos, Map.insert n pos wormholes)
-    f pos _ (bounds, wormholes) = (increaseBounds bounds pos, wormholes)
+generateLabyrinth = do
+  xSize <- getRandomInt (4, 10)
+  ySize <- getRandomInt (4, 10)
+  exits <- getRandomInt (1, 4)
+  wormholes <- getRandomInt (2, 5)
+  generateGrid xSize ySize
+    >>= generatePaths xSize ySize
+    -- >>= generateExits exits
+    -- >>= generateWormholes wormholes
+    -- >>= generateTreasure

app/labyrinth/src/Labyrinth/Render.hs

@@ -96,16 +96,16 @@ mergeCell dir w curW   = "!" <> show dir <> show w <> curW
 
 
 renderSkeleton :: Bounds -> LabRender
-renderSkeleton (maxX, maxY) = skeleton
+renderSkeleton (maxX, maxY) = ((rendMaxX, rendMaxY), skeleton)
   where
     p x y = (x, y)
     rendMaxX = maxX * 2
     rendMaxY = maxY * 2
 
-    genLeftMonolithCross   = [(p 0 y,        lCross) | y <- [0, 2..rendMaxY ], y > 1, y < rendMaxY - 1 ]
-    genRightMonolithCross  = [(p rendMaxX y, rCross) | y <- [0, 2..rendMaxY ], y > 1, y < rendMaxY - 1 ]
-    genTopMonolithCross    = [(p x 0,        uCross) | x <- [0, 2..rendMaxX ], x > 1, x < rendMaxX - 1 ]
-    genBottomMonolithCross = [(p x rendMaxY, dCross) | x <- [0, 2..rendMaxX ], x > 1, x < rendMaxX - 1 ]
+    genLeftMonolithCross   = [(p 0 y,        lCross) | y <- [0, 2..rendMaxY - 1], y > 1]
+    genRightMonolithCross  = [(p rendMaxX y, rCross) | y <- [0, 2..rendMaxY - 1], y > 1]
+    genTopMonolithCross    = [(p x 0,        uCross) | x <- [0, 2..rendMaxX - 1], x > 1]
+    genBottomMonolithCross = [(p x rendMaxY, dCross) | x <- [0, 2..rendMaxX - 1], x > 1]
     genInternalCross       = [(p x y,        cross)  | x <- [0, 2..rendMaxX - 1]
                                                      , y <- [0, 2..rendMaxY - 1]
                                                      , y > 1, y < rendMaxY - 1
@@ -129,7 +129,7 @@ renderSkeleton (maxX, maxY) = skeleton
 
 -- foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
 cellRender :: Pos -> (Cell, Content) -> LabRender -> LabRender
-cellRender (x0, y0) (cell, content) labRender = let
+cellRender (x0, y0) (cell, content) (bounds, labRender) = let
   (x, y) = (x0 * 2 + 1, y0 * 2 + 1)
   l = (x-1, y)
   r = (x+1, y)
@@ -138,7 +138,7 @@ cellRender (x0, y0) (cell, content) labRender = let
   g (a, b) = Map.lookup (a, b) labRender
   mbCellR = g (x, y)
   accessedRenderedCells = (g l, g r, g u, g d)
-  in case accessedRenderedCells of
+  labWithCell = case accessedRenderedCells of
       (Nothing, _, _, _) -> Map.insert l ("!l" <> show l) labRender
       (_, Nothing, _, _) -> Map.insert r ("!r" <> show r) labRender
       (_, _, Nothing, _) -> Map.insert u ("!u" <> show u) labRender
@@ -150,25 +150,29 @@ cellRender (x0, y0) (cell, content) labRender = let
           $ Map.insert d (mergeCell DirDown  (downWall  cell) dCr)
           $ Map.insert (x, y) (mergeCellContent content mbCellR)
           labRender
+  in (bounds, labWithCell)
 
 renderPlayer :: Pos -> LabRender -> LabRender
-renderPlayer (x0, y0) lab = let
-  (x, y) = (x0 * 2 + 1, y0 * 2 + 1)
-  in case Map.lookup (x, y) lab of
-    Nothing   -> Map.insert (0, 0) ("!Player:" <> show (x0, y0)) lab
-    Just curW -> Map.insert (x, y) (take 1 curW <> "@" <> (take 2 $ drop 2 curW)) lab
+renderPlayer (x0, y0) (bounds, lab) = (bounds, lab')
+  where
+    (x, y) = (x0 * 2 + 1, y0 * 2 + 1)
+    lab' = case Map.lookup (x, y) lab of
+              Nothing   -> Map.insert (0, 0) ("!Player:" <> show (x0, y0)) lab
+              Just curW -> Map.insert (x, y) (take 1 curW <> "@" <> (take 2 $ drop 2 curW)) lab
 
-
-renderLabyrinth :: LabRender -> Labyrinth -> Pos -> LabRender
-renderLabyrinth template lab plPos =
+renderLabyrinth' :: Skeleton -> Labyrinth -> Pos -> LabRender
+renderLabyrinth' skeleton lab plPos =
   renderPlayer plPos
-    $ Map.foldrWithKey cellRender template lab
+    $ Map.foldrWithKey cellRender skeleton lab
 
-printLabRender :: Bounds -> LabRender -> LangL ()
-printLabRender (maxX, maxY) labRender = do
+renderLabyrinth :: Labyrinth -> Pos -> LabRender
+renderLabyrinth lab plPos = renderLabyrinth' skeleton lab plPos
+  where
+    (bounds, _) = analyzeLabyrinth lab
+    skeleton = renderSkeleton bounds
 
-  let rendMaxX = maxX * 2
-  let rendMaxY = maxY * 2
+printLabRender' :: LabRender -> LangL ()
+printLabRender' ((rendMaxX, rendMaxY), labRender) = do
 
   let printAndMergeCells y row x = case Map.lookup (x, y) labRender of
         Nothing -> row <> "!" <> show (x, y)
@@ -182,3 +186,6 @@ printLabRender (maxX, maxY) labRender = do
 
   let outputRows row = putStrLn row
   mapM_ outputRows printedRows
+
+printLabyrinth :: Labyrinth -> LangL ()
+printLabyrinth lab = printLabRender' $ renderLabyrinth lab (0, 0)

app/labyrinth/src/Labyrinth/Types.hs

@@ -12,9 +12,6 @@ data Inventory = Inventory
   { _treasure :: StateVar Bool
   }
 
-type LabRender = Map Pos String
-type Wormholes = Map Int Pos
-
 data GameState
   = PlayerMove
   | PlayerIsAboutLeaving HasTreasure

app/labyrinth/src/Main.hs

@@ -49,5 +49,8 @@ initAppState lab = do
 startApp :: AppL ()
 startApp = initAppState testLabyrinth2 >>= app
 
+execApp :: Maybe D.LoggerConfig -> AppL a -> IO a
+execApp mbCfg act = R.withAppRuntime mbCfg $ \rt -> R.runAppL rt act
+
 main :: IO ()
-main = R.withAppRuntime (Just loggerCfg) (\rt -> R.runAppL rt startApp)
+main = execApp (Just loggerCfg) startApp

lib/Hydra/src/Hydra/Core/Lang/Language.hs

@@ -83,6 +83,10 @@ instance C.Lang L.LoggerL L.RandomL L.ControlFlowL L.StateL LangL where
   evalRandom          = evalRandom'
   evalControlFlow     = evalControlFlow'
 
+-- | State handling.
+-- Note: don't spawn variables uncontrollably.
+-- Variables cannot be deleted.
+
 instance L.StateIO LangL where
   newVarIO       = evalStateAtomically' . L.newVar
   readVarIO      = evalStateAtomically' . L.readVar

lib/Hydra/src/Hydra/Core/State/Language.hs

@@ -33,6 +33,10 @@ instance Functor StateF where
 
 type StateL = Free StateF
 
+-- | State handling.
+-- Note: don't spawn variables uncontrollably.
+-- Variables cannot be deleted.
+
 instance L.State' StateL where
   newVar   val     = liftF $ NewVar val id
   readVar  var     = liftF $ ReadVar var id

lib/Hydra/src/Hydra/Framework/App/Language.hs

@@ -103,6 +103,9 @@ process action = void $ fork action
 instance C.IOL AppL where
   evalIO = evalLang' . C.evalIO
 
+-- | State handling.
+-- Note: don't spawn variables uncontrollably.
+-- Variables cannot be deleted.
 instance L.StateIO AppL where
   newVarIO       = evalLang' . L.newVarIO
   readVarIO      = evalLang' . L.readVarIO