From faebb0f37f3d87fad54e1a80d4be456193544834 Mon Sep 17 00:00:00 2001 From: Alexander Granin Date: Sun, 26 Apr 2020 18:25:23 +0700 Subject: [PATCH] New way of pre-rendering the labyrinth --- app/labyrinth/Labyrinth/App.hs | 94 ++++++++++++++++++++---- app/labyrinth/Labyrinth/Types.hs | 7 +- app/labyrinth/Main.hs | 120 ++++++++++++++++++++++++++----- 3 files changed, 188 insertions(+), 33 deletions(-) diff --git a/app/labyrinth/Labyrinth/App.hs b/app/labyrinth/Labyrinth/App.hs index ffd182b..902510e 100644 --- a/app/labyrinth/Labyrinth/App.hs +++ b/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 diff --git a/app/labyrinth/Labyrinth/Types.hs b/app/labyrinth/Labyrinth/Types.hs index b4e4231..edfa77a 100644 --- a/app/labyrinth/Labyrinth/Types.hs +++ b/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) diff --git a/app/labyrinth/Main.hs b/app/labyrinth/Main.hs index 9ada40a..c345d64 100644 --- a/app/labyrinth/Main.hs +++ b/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 ()