diff --git a/app/Main.hs b/app/Main.hs index 75fbc22..3aecb9d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,150 +11,10 @@ import System.Environment ( getArgs ) import Model import Rendering ( render ) -world0 :: World -world0 = World { - worldButtons = Set.empty, - worldHome = Location '2' 0 0, - worldMe = 'b', - worldBoxes = Map.fromList - [('1', Box { - boxColor = withForeColor defAttr green, - boxLocation = Location '1' (-1) 0, - boxType = Original $ makeWalls [ - "▓▓ ▓▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - " ▓", - "▓ ▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓▓▓▓▓ ▓" - ] - }), - ('2', Box { - boxColor = withForeColor defAttr cyan, - boxLocation = Location '1' 1 1, - boxType = Original $ makeWalls [ - "▓ ▓▓ ▓▓ ▓", - " ", - " ▓", - " ▓", - " ", - "▓ ▓", - "▓ ▓", - " ", - "▓ ▓▓ ▓▓ ▓" - ] - }), - ('₂', Box { - boxColor = withForeColor defAttr cyan, - boxLocation = Location '1' 2 (-1), - boxType = Link '2' - }), - ('3', Box { - boxColor = withForeColor defAttr blue, - boxLocation = Location '2' 1 1, - boxType = Original $ makeWalls [ - "▓▓▓▓▓▓▓▓▓", - " ", - "▓▓▓▓▓▓▓▓ ", - "▓▓ ▓▓▓ ", - "▓▓ ▓▓▓ ", - "▓▓▓▓ ▓▓▓ ", - "▓▓ ▓▓▓▓", - "▓▓ ▓▓▓▓", - "▓▓▓▓ ▓▓▓▓" - ] - }), - ('4', Box { - boxColor = withForeColor defAttr black, - boxLocation = Location 'b' (-3) 0, - boxType = Original $ makeWalls [ - "▓▓▓ ▓▓▓", - "▓ ▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓▓▓▓ ▓▓▓▓" - ] - }), - ('b', Box { - boxColor = withForeColor defAttr red, - boxLocation = Location '1' 0 1, - boxType = Original $ makeWalls [ - "▓▓▓▓▓▓▓▓▓", - "▓ ▓", - "▓ ▓", - "▓ ▓ ▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓▓▓▓▓▓▓▓▓" - ] - }), - ('x', Box { - boxColor = withForeColor defAttr yellow, - boxLocation = Location '1' 0 (-1), - boxType = Original $ - makeWalls [ - "▓▓ ▓ ", - " ", - " ▓ ▓▓▓ ", - " ▓ ", - "▓ ▓▓▓▓", - " ▓▓▓ ", - " ▓ ▓▓▓ ", - " ", - "▓ ▓ ▓" - ] - }), - ('y', Box { - boxColor = withForeColor defAttr magenta, - boxLocation = Location '1' 0 (-2), - boxType = Original $ makeWalls [ - "▓▓ ▓ ", - " ", - "▓▓ ▓▓▓ ", - "▓▓ ", - " ▓▓▓▓", - "▓▓▓▓ ", - "▓▓ ▓▓▓ ", - " ", - "▓ ▓ ▓" - ] - }), - ('i', Box { - boxColor = withForeColor defAttr black, - boxLocation = Location 'b' 0 (-2), - boxType = Original $ solid 9 - }), - ('j', Box { - boxColor = withForeColor defAttr black, - boxLocation = Location 'b' 0 (-1), - boxType = Original $ solid 9 - }), - ('k', Box { - boxColor = withForeColor defAttr black, - boxLocation = Location 'b' 0 0, - boxType = Original $ solid 9 - }), - ('l', Box { - boxColor = withForeColor defAttr black, - boxLocation = Location 'b' 0 1, - boxType = Original $ solid 9 - }), - ('₁', Box { - boxColor = withForeColor defAttr green, - boxLocation = Location '1' 2 1, - boxType = Link '1' - }) - ] - } +data Game = Game { + gameWorlds :: NonEmpty World, + gameFlat :: Bool +} main :: IO () main = @@ -162,31 +22,36 @@ main = case args of x:_ | Just w <- Map.lookup x worldList -> bracket (mkVty =<< userConfig) shutdown \vty -> - loop vty (pure w) + loop vty Game { + gameWorlds = pure w, + gameFlat = True + } _ -> do putStrLn "Usage: parabox " putStrLn "" putStrLn "Available worlds:" mapM_ putStrLn (Map.keys worldList) -loop :: Vty -> NonEmpty World -> IO () -loop vty (world :| history) = - do update vty (render world) +loop :: Vty -> Game -> IO () +loop vty game = + do let world = NonEmpty.head (gameWorlds game) + update vty (render (gameFlat game) (NonEmpty.head (gameWorlds game))) ev <- nextEvent vty case ev of EvKey key _modifier -> case key of - KUp -> loop vty (move world (-1,0) :| world : history) - KDown -> loop vty (move world (1,0) :| world : history) - KLeft -> loop vty (move world (0,-1) :| world : history) - KRight -> loop vty (move world (0,1) :| world : history) - KChar 'r' -> loop vty (pure (NonEmpty.last (world :| history))) + KUp -> loop vty game{ gameWorlds = NonEmpty.cons (move world (-1,0)) (gameWorlds game) } + KDown -> loop vty game{ gameWorlds = NonEmpty.cons (move world (1,0) ) (gameWorlds game) } + KLeft -> loop vty game{ gameWorlds = NonEmpty.cons (move world (0,-1)) (gameWorlds game) } + KRight -> loop vty game{ gameWorlds = NonEmpty.cons (move world (0,1) ) (gameWorlds game) } + KChar 'r' -> loop vty game{ gameWorlds = pure (NonEmpty.last (gameWorlds game)) } KChar 'z' - | Just worlds <- NonEmpty.nonEmpty history -> - loop vty worlds + | Just worlds <- NonEmpty.nonEmpty (NonEmpty.tail (gameWorlds game)) -> + loop vty game{ gameWorlds = worlds } KEsc -> pure () - _ -> loop vty (world :| history) - _ -> loop vty (world :| history) + KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) } + _ -> loop vty game + _ -> loop vty game worldList :: Map.Map String World @@ -197,6 +62,7 @@ worldList = Map.fromList , ("center13", center13) , ("clone11", clone11) , ("transfer14", transfer14) + , ("open4", open4) ] smallWorld :: World @@ -431,3 +297,207 @@ transfer14 = 'b' (Set.fromList [Location 'g' (-2) 0]) (Location 'g' (-3) 0) + +open4 :: World +open4 = + World + (Map.fromList + [('a', + Box (Location 'a' 0 (-1)) + (Original (makeWalls [ + "▓▓▓▓▓▓▓▓▓", + "▓▓ ▓▓▓▓", + "▓▓ ▓", + "▓ ▓", + "▓▓ ▓", + "▓▓ ▓", + "▓▓ ▓", + "▓▓ ▓", + "▓▓ ▓" + ])) + (withForeColor defAttr cyan)), + ('g', + Box + (Location 'a' 2 (-1)) + (Original (makeWalls [ + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓" + ])) + (withForeColor defAttr green)), + ('y', + Box + (Location 'a' 2 1) + (Original (makeWalls [ + "▓▓▓▓▓▓ ▓▓", + "▓▓▓▓▓▓ ▓▓", + "▓▓▓▓▓▓▓▓▓", + "▓▓▓▓▓▓▓▓▓", + "▓▓▓▓▓▓▓▓▓", + "▓▓▓▓▓▓▓▓▓", + "▓▓▓▓▓▓▓▓▓", + "▓▓▓▓▓▓▓▓▓", + "▓▓▓▓▓▓▓▓▓" + ])) + (withForeColor defAttr yellow)), + ('b', + Box + (Location 'a' 0 1) + (Original (solid 9)) + (withForeColor defAttr red)) + ]) + 'b' + Set.empty + (Location 'y' (-3) 2) + + +world0 :: World +world0 = World { + worldButtons = Set.empty, + worldHome = Location '2' 0 0, + worldMe = 'b', + worldBoxes = Map.fromList + [('1', Box { + boxColor = withForeColor defAttr green, + boxLocation = Location '1' (-1) 0, + boxType = Original $ makeWalls [ + "▓▓ ▓▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + " ▓", + "▓ ▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓▓▓▓▓ ▓" + ] + }), + ('2', Box { + boxColor = withForeColor defAttr cyan, + boxLocation = Location '1' 1 1, + boxType = Original $ makeWalls [ + "▓ ▓▓ ▓▓ ▓", + " ", + " ▓", + " ▓", + " ", + "▓ ▓", + "▓ ▓", + " ", + "▓ ▓▓ ▓▓ ▓" + ] + }), + ('₂', Box { + boxColor = withForeColor defAttr cyan, + boxLocation = Location '1' 2 (-1), + boxType = Link '2' + }), + ('3', Box { + boxColor = withForeColor defAttr blue, + boxLocation = Location '2' 1 1, + boxType = Original $ makeWalls [ + "▓▓▓▓▓▓▓▓▓", + " ", + "▓▓▓▓▓▓▓▓ ", + "▓▓ ▓▓▓ ", + "▓▓ ▓▓▓ ", + "▓▓▓▓ ▓▓▓ ", + "▓▓ ▓▓▓▓", + "▓▓ ▓▓▓▓", + "▓▓▓▓ ▓▓▓▓" + ] + }), + ('4', Box { + boxColor = withForeColor defAttr black, + boxLocation = Location 'b' (-3) 0, + boxType = Original $ makeWalls [ + "▓▓▓ ▓▓▓", + "▓ ▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓▓▓▓ ▓▓▓▓" + ] + }), + ('b', Box { + boxColor = withForeColor defAttr red, + boxLocation = Location '1' 0 1, + boxType = Original $ makeWalls [ + "▓▓▓▓▓▓▓▓▓", + "▓ ▓", + "▓ ▓", + "▓ ▓ ▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓▓▓▓▓▓▓▓▓" + ] + }), + ('x', Box { + boxColor = withForeColor defAttr yellow, + boxLocation = Location '1' 0 (-1), + boxType = Original $ + makeWalls [ + "▓▓ ▓ ", + " ", + " ▓ ▓▓▓ ", + " ▓ ", + "▓ ▓▓▓▓", + " ▓▓▓ ", + " ▓ ▓▓▓ ", + " ", + "▓ ▓ ▓" + ] + }), + ('y', Box { + boxColor = withForeColor defAttr magenta, + boxLocation = Location '1' 0 (-2), + boxType = Original $ makeWalls [ + "▓▓ ▓ ", + " ", + "▓▓ ▓▓▓ ", + "▓▓ ", + " ▓▓▓▓", + "▓▓▓▓ ", + "▓▓ ▓▓▓ ", + " ", + "▓ ▓ ▓" + ] + }), + ('i', Box { + boxColor = withForeColor defAttr black, + boxLocation = Location 'b' 0 (-2), + boxType = Original $ solid 9 + }), + ('j', Box { + boxColor = withForeColor defAttr black, + boxLocation = Location 'b' 0 (-1), + boxType = Original $ solid 9 + }), + ('k', Box { + boxColor = withForeColor defAttr black, + boxLocation = Location 'b' 0 0, + boxType = Original $ solid 9 + }), + ('l', Box { + boxColor = withForeColor defAttr black, + boxLocation = Location 'b' 0 1, + boxType = Original $ solid 9 + }), + ('₁', Box { + boxColor = withForeColor defAttr green, + boxLocation = Location '1' 2 1, + boxType = Link '1' + }) + ] + } \ No newline at end of file diff --git a/app/Model.hs b/app/Model.hs index 00b3793..6078270 100644 --- a/app/Model.hs +++ b/app/Model.hs @@ -67,13 +67,6 @@ boxSize world box = yhi-ylo+1 solid :: Int -> Array Coord Bool solid n = makeWalls (replicate n (replicate n 'x')) --- Move an object --- 1. remove it from the world --- 2. compute where it would move to --- 3. a. that spot is empty --- b. try to move that object forward --- c. try to move that object backward into me - move :: World -> (Int,Int) -> World move world dir = case moveBlock world Map.empty (myLocation world) dir 0 of diff --git a/app/Rendering.hs b/app/Rendering.hs index cafc961..029e666 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -9,10 +9,20 @@ import Graphics.Vty import Model +border :: Int +border = 20 + unit :: Attr -> Int -> Char -> Image unit a scale x = vertCat (replicate scale (string a (replicate (2*scale) x))) +drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image +drawBox a _ 1 = string a "[]" +drawBox a w h = vertCat $ + string a ('┌' : replicate (w-2) '─' ++ "┐") : + replicate (h-2) (string a ('│' : replicate (w-2) ' ' ++ "│")) ++ + [string a ('└' : replicate (w-2) '─' ++ "┘")] + button :: Attr -> Int -> Image button a 1 = string a "[]" button a n = vertCat $ @@ -62,9 +72,12 @@ renderBox world locMap box name scale = , y <- [ylo .. yhi] ] -render :: World -> Picture -render world = picForLayers $ - [ pad 98 6 0 0 $ +render :: + Bool {- ^ show flat overlay -} -> + World -> + Picture +render flat world = picForLayers $ + [ pad 98 12 0 0 $ string defAttr "██╗ ██╗██╗███╗ ██╗███╗ ██╗███████╗██████╗ " <-> string defAttr "██║ ██║██║████╗ ██║████╗ ██║██╔════╝██╔══██╗" <-> string defAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗ ██████╔╝" <-> @@ -72,10 +85,29 @@ render world = picForLayers $ string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║ ██║" <-> string defAttr " ╚══╝╚══╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═══╝╚══════╝╚═╝ ╚═╝" | winCondition world ] ++ - [drawNestedWorld world] + (if flat then renderFlat locMap world else []) ++ + [drawNestedWorld locMap world] + where + locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)] -drawNestedWorld :: World -> Image -drawNestedWorld world = +renderFlat :: Map Location Char -> World -> [Image] +renderFlat locMap world = + [ pad offset 0 0 0 baseImage + , pad offset 0 0 0 $ drawBox borderAttr (imageWidth baseImage) (imageHeight baseImage) + ] + where + borderAttr = defAttr `withForeColor` white `withBackColor` black + offset = max 0 ( (2*(81+2*border)+2 - imageWidth baseImage) `div` 2) + baseImage = + pad 2 1 2 1 $ + horizCat $ + intersperse (char borderAttr ' ') + [renderBox world locMap b n 1 + | (n,b) <- Map.assocs (worldBoxes world) + , Original{} <- [boxType b]] + +drawNestedWorld :: Map Location Char -> World -> Image +drawNestedWorld locMap world = -- (3*81) + 81 + (3*81) cropTop (81 + 2*border) $ cropLeft (2*(81 + 2*border)) $ @@ -97,12 +129,8 @@ drawNestedWorld world = | y_ <- [y1-1 .. y1+1] ] where - border = 20 - locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)] - -- name1 is the box the player is standing in - Location name0 _ _ = boxLocation (worldBoxes world Map.! worldMe world) - + Location name0 _ _ = myLocation world Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0)