New way of pre-rendering the labyrinth

app/labyrinth/Labyrinth/App.hs

@@ -147,16 +147,71 @@ printLabyrinth st = do
   let outputRows (t, m, b) = putStrLn $ T.pack $ t <> "\n" <> m <> "\n" <> b
   mapM_ outputRows printedRows
 
+-- printLabyrinth2 :: GameState -> LangL ()
+-- printLabyrinth2 st = do
+--   lab          <- readVarIO $ st ^. labyrinth
+--   (maxX, maxY) <- readVarIO $ st ^. labyrinthSize
+--
+--   let labRenderVar = st ^. labRenderVar
+--
+--   writeVarIO labRenderVar $ Map.fromList $ do
+--     x <- [0..maxX*2]
+--     y <- [0..maxY*2]
+--     pure ((x, y), "")
+--
+--   let renderCell ((x, y), cell) = do
+--         r1 <- readVarIO labRenderVar
+--         case Map.lookup (x, y) r1 of
+--           Nothing -> throwException $ InvalidOperation $ show (x, y) <> " (1)"
+--           Just rCell -> renderLLPart (x, y) cell rCell
+--
+--   mapM_ renderCell $ Map.toList lab
+
+-- renderLLPart (x, y) (Cell ) "" =
+
+--           X11  X1  x12  X2 X X3 X
+--  y1-1     ┏━━━━┯━━━━┓
+--  y1-2     ┃           │    ┃
+--  y1
+--  y2-1     ┠    ┼    ┨
+--  y2-2     ┃    │    ┃
+--  y2
+--  y3-1     ┠────┼────┨
+--  y3-2     ┃    │    ┃
+--  y3
+--  y4-1     ┠────┼────┨
+--  y4-2     ┃         ┃
+--  y4
+--  y5-1     ┗━━━━┷    ┛
+--  y5-2
+-- ┏━━━┯━━━┓
+-- ┃       ┃
+-- ┠───┼   ┨
+-- ┃       ┃
+-- ┗━━━┷   ┛
+-- ┏━━━━┯━━━━┓
+-- ┃         ┃
+-- ┠────┼    ┨
+-- ┃         ┃
+-- ┗━━━━┷    ┛
 
 
---
--- -   ------
--- |W1 ||W2P|
--- ------   -
--- ----------
--- |  T||   |
--- ----------
---
+-- ╔════╤════╗
+-- ║         ║
+-- ╟────┼    ╢
+-- ║         ║
+-- ╟────┼    ╢
+-- ║         ║
+-- ╚════╧════╝
+
+
+
+-- ▁▁▁▁▁▁▁
+-- ▔▔▔▔▔▔▔
+-- ▁▁▁▁▁▁▁
+-- ▔▔▔▔▔▔▔
+-- ▁▁▁▁▁▁▁
+
 
 printCell (Cell l r u d) content
   = ( printHorizontalWall u
@@ -164,15 +219,25 @@ printCell (Cell l r u d) content
     , printHorizontalWall d
     )
 
-printHorizontalWall NoWall            = "-   -"
-printHorizontalWall Wall              = "-----"
-printHorizontalWall (Monolith True)   = "#   #"
-printHorizontalWall (Monolith False)  = "#---#"
+vMonolithSymbol :: IsString s => s
+vMonolithSymbol = "║"
+
+hMonolithSymbol :: IsString s => s
+hMonolithSymbol = "═"
+
+vWallSymbol, hWallSymbol :: IsString s => s
+vWallSymbol = "┃"
+hWallSymbol = "━"
+
+printHorizontalWall NoWall            = hWallSymbol <> "   " <> hWallSymbol
+printHorizontalWall Wall              = join $ replicate 5 hWallSymbol
+printHorizontalWall (Monolith True)   = hMonolithSymbol <> "   " <> hMonolithSymbol
+printHorizontalWall (Monolith False)  = join $ replicate 5 hMonolithSymbol
 
 printVerticalWall NoWall           = " "
-printVerticalWall Wall             = "|"
+printVerticalWall Wall             = vWallSymbol
 printVerticalWall (Monolith True)  = " "
-printVerticalWall (Monolith False) = "#"
+printVerticalWall (Monolith False) = vMonolithSymbol
 
 printContent NoContent    = "   "
 printContent Treasure     = "  T"
@@ -212,6 +277,7 @@ app st = do
     cmd "right"    $ makeMove st DirRight
 
     cmd "quit"     $ quit st
+    cmd "q"        $ quit st
 
     cmd "print"    $ printLabyrinth st
 

app/labyrinth/Labyrinth/Types.hs

@@ -14,10 +14,13 @@ data Inventory = Inventory
   { _treasure :: StateVar Bool
   }
 
+type LabRender = Map Pos Text
+
 data GameState = GameState
   { _labyrinth            :: StateVar Labyrinth
-  , _labyrinthSize        :: StateVar (Int, Int)
-  , _wormholes            :: Map Int (Int, Int)
+  , _labyrinthSize        :: StateVar Pos
+  , _labRenderVar         :: StateVar LabRender
+  , _wormholes            :: Map Int Pos
   , _playerPos            :: StateVar Pos
   , _playerInventory      :: Inventory
   , _playerIsAboutLeaving :: StateVar (Maybe HasTreasure)

app/labyrinth/Main.hs

@@ -1,6 +1,6 @@
 module Main where
 
-import           Hydra.Prelude
+import           Labyrinth.Prelude
 
 import           System.Environment         (getArgs)
 import qualified Data.Text                  as T
@@ -25,34 +25,120 @@ loggerCfg = D.LoggerConfig
   }
 
 -- l r u d
-testLabyrinth = Map.fromList
-  [ ((0, 0), (Cell Wall Wall Wall Wall, NoContent))
-  , ((1, 0), (Cell Wall Wall NoWall Wall, Treasure))
-  , ((2, 0), (Cell Wall Wall Wall Wall, NoContent))
+testLabyrinth2 = Map.fromList
+  [ ((0, 0), (Cell (Monolith False) Wall Wall Wall, NoContent))
+  , ((1, 0), (Cell (Monolith False) Wall NoWall Wall, Treasure))
+  , ((2, 0), (Cell (Monolith False) Wall Wall Wall, NoContent))
 
   , ((0, 1), (Cell NoWall Wall Wall Wall, NoContent))
   , ((1, 1), (Cell NoWall NoWall NoWall NoWall, NoContent))
   , ((2, 1), (Cell Wall NoWall Wall Wall, NoContent))
 
-  , ((0, 2), (Cell Wall Wall Wall Wall, NoContent))
-  , ((1, 2), (Cell Wall Wall Wall NoWall, NoContent))
-  , ((2, 2), (Cell Wall Wall Wall Wall, NoContent))
+  , ((0, 2), (Cell Wall (Monolith False) Wall Wall, NoContent))
+  , ((1, 2), (Cell Wall (Monolith False) Wall NoWall, NoContent))
+  , ((2, 2), (Cell Wall (Monolith False) Wall Wall, NoContent))
+  ]
+
+testLabyrinth1 :: Labyrinth
+testLabyrinth1 = Map.fromList
+  [ ((0, 0), (Cell (Monolith False) (Monolith False) (Monolith False) (Monolith True), Treasure))
   ]
 
 
-initGameState :: L.AppL GameState
+renderLabyrinthSkeleton :: Int -> Int -> LabRender
+renderLabyrinthSkeleton maxX maxY = skeleton
+  where
+    p x y = (x, y)
+    rendMaxX = maxX * 2
+    rendMaxY = maxY * 2
+
+    genLeftMonolithCross   = [(p 0 y,        "┠") | y <- [0, 2..rendMaxY ], y > 1, y < rendMaxY - 1 ]
+    genRightMonolithCross  = [(p rendMaxX y, "┨") | y <- [0, 2..rendMaxY ], y > 1, y < rendMaxY - 1 ]
+    genTopMonolithCross    = [(p x 0,        "┯") | x <- [0, 2..rendMaxX ], x > 1, x < rendMaxX - 1 ]
+    genBottomMonolithCross = [(p x rendMaxY, "┷") | x <- [0, 2..rendMaxX ], x > 1, x < rendMaxX - 1 ]
+    genInternalCross       = [(p x y, "┼") | x <- [0, 2..rendMaxX - 1]
+                                           , y <- [0, 2..rendMaxY - 1]
+                                           , y > 1, y < rendMaxY - 1
+                                           , x > 1, x < rendMaxX - 1
+                                           ]
+    fullTemplate           = [(p x y, " ") | x <- [0..rendMaxX], y <- [0..rendMaxY]]
+
+    intersections =
+      [ (p 0 0,               "┏")
+      , (p rendMaxX 0,        "┓")
+      , (p 0 rendMaxY,        "┗")
+      , (p rendMaxX rendMaxY, "┛")
+      ]
+      ++ genLeftMonolithCross
+      ++ genRightMonolithCross
+      ++ genTopMonolithCross
+      ++ genBottomMonolithCross
+      ++ genInternalCross
+
+    skeleton = Map.union (Map.fromList intersections) (Map.fromList fullTemplate)
+
+printSkeleton :: Int -> Int -> LabRender -> AppL ()
+printSkeleton mx my skeleton = do
+  scenario $ putStrLn $ show skeleton
+
+  let rendMaxX = mx * 2
+  let rendMaxY = my * 2
+
+  let printAndMergeCells y row x = case Map.lookup (x, y) skeleton of
+        Nothing -> row <> "!"
+        Just c  -> row <> c
+
+  let printAndMergeRows y rows =
+        let row = foldl' (printAndMergeCells y) "" [0..rendMaxX]
+        in row : rows
+
+  let printedRows = foldr printAndMergeRows [] [0..rendMaxY]
+
+  let outputRows row = putStrLn row
+  scenario $ mapM_ outputRows printedRows
+
+
+-- ┓ ┯ ┯ ┯ ┏
+--
+-- ┨ ┼ ┼ ┼ ┠
+--
+-- ┨ ┼ ┼ ┼ ┠
+--
+-- ┨ ┼ ┼ ┼ ┠
+--
+-- ┛ ┷ ┷ ┷ ┗
+
+
+
+initGameState :: AppL GameState
 initGameState = do
-  lab       <- L.newVarIO testLabyrinth
-  labSize   <- L.newVarIO (3, 3)
-  pos       <- L.newVarIO (0, 0)
-  inv       <- Inventory <$> L.newVarIO False
-  treasure  <- L.newVarIO Nothing
-  fiinished <- L.newVarIO False
-  pure $ GameState lab labSize Map.empty pos inv treasure fiinished
+  printSkeleton 1 1 $ renderLabyrinthSkeleton 1 1
+  printSkeleton 2 2 $ renderLabyrinthSkeleton 2 2
+  printSkeleton 3 3 $ renderLabyrinthSkeleton 3 3
+  printSkeleton 4 4 $ renderLabyrinthSkeleton 4 4
+
+  let maxX = 1
+  let maxY = 1
+
+  labRenderVar <- newVarIO $ Map.fromList $ do
+    x <- [0..maxX*2]
+    y <- [0..maxY*2]
+    pure ((x, y), T.pack "")
+
+  let wormholes = Map.empty
+
+  labVar           <- newVarIO testLabyrinth1
+  labSizeVar       <- newVarIO (maxX, maxY)
+  posVar           <- newVarIO (0, 0)
+  inv              <- Inventory <$> newVarIO False
+  aboutLeaving     <- newVarIO Nothing
+  finished         <- newVarIO False
+
+  pure $ GameState labVar labSizeVar labRenderVar wormholes posVar inv aboutLeaving finished
 
 
 
-startApp :: L.AppL ()
+startApp :: AppL ()
 startApp = initGameState >>= app
 
 main :: IO ()