add some level selection

app/Main.hs

@@ -5,12 +5,16 @@ import Graphics.Vty
 import Control.Exception
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.List.NonEmpty qualified as NonEmpty
+import Data.Set qualified as Set
+import System.Environment
 
 import Model
 import Rendering
 
 world0 :: World
 world0 = World {
+  worldButtons = Set.empty,
+  worldHome = Location '2' 0 0,
   worldMe = 'b',
   worldBoxes = Map.fromList
     [('1', Box {
@@ -154,10 +158,12 @@ world0 = World {
 
 main :: IO ()
 main =
-  bracket (mkVty =<< userConfig) shutdown \vty ->
+ do args <- getArgs
-   do
+    let name = case args of x:_ -> x; [] -> ""
-      loop vty (pure clone11)
+    bracket (mkVty =<< userConfig) shutdown \vty ->
-      pure ()
+     do
+        loop vty (pure (pickWorld name))
+        pure ()
 
 loop :: Vty -> NonEmpty World -> IO ()
 loop vty (world :| history) =
@@ -170,6 +176,7 @@ loop vty (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)))
           KChar 'z'
             | Just worlds <- NonEmpty.nonEmpty history ->
               loop vty worlds
@@ -177,6 +184,14 @@ loop vty (world :| history) =
           _ -> loop vty (world :| history)
       _ -> loop vty (world :| history)
 
+pickWorld :: String -> World
+pickWorld "world0" = world0
+pickWorld "small" = smallWorld
+pickWorld "center8" = center8
+pickWorld "center13" = center13
+pickWorld "clone11" = clone11
+pickWorld _ = transfer14
+
 smallWorld :: World
 smallWorld =
   World
@@ -221,6 +236,8 @@ smallWorld =
           (Original (solid 9))
           (withForeColor defAttr red))
     ]) 'b'
+    Set.empty
+    (Location 'b' 0 0)
 
 center8 :: World
 center8 =
@@ -266,6 +283,8 @@ center8 =
           (Original (solid 9))
           (withForeColor defAttr red))
     ]) 'b'
+    Set.empty
+    (Location 'a' 3 2)
 
 center13 :: World
 center13 =
@@ -311,6 +330,8 @@ center13 =
           (Original (solid 9))
           (withForeColor defAttr red))
     ]) 'b'
+    Set.empty
+    (Location 'a' 2 0)
 
 
 clone11 :: World
@@ -341,4 +362,65 @@ clone11 =
           (Location 'a' 0 (-2))
           (Original (solid 9))
           (withForeColor defAttr red))
-    ]) 'b'
+    ])
+    'b'
+    (Set.fromList [Location 'a' (-1) (-3), Location 'a' (-2) (-3)])
+    (Location 'a' (-3) (-3))
+
+transfer14 :: World
+transfer14 =
+  World
+    (Map.fromList
+    [('a',
+      Box (Location 'a' 1 1)
+          (Original (makeWalls [
+            "         ",
+            "         ",
+            "         ",
+            "         ",
+            "    ▓    ",
+            "         ",
+            "         ",
+            "         ",
+            "         "
+           ]))
+          (withForeColor defAttr cyan)),
+      ('g',
+        Box
+          (Location 'a' (-1) (-1))
+          (Original (makeWalls [
+            "   ▓▓▓   ",
+            "   ▓ ▓   ",
+            "         ",
+            "    ▓    ",
+            "▓▓  ▓  ▓▓",
+            "    ▓    ",
+            "         ",
+            "         ",
+            "    ▓    "
+          ]))
+          (withForeColor defAttr green)),
+      ('x',
+        Box
+          (Location 'g' 3 (-3))
+          (Original (makeWalls [
+            "         ",
+            "         ",
+            "         ",
+            "         ",
+            "         ",
+            "         ",
+            "         ",
+            "         ",
+            "         "
+          ]))
+          (withForeColor defAttr magenta)),
+      ('b',
+        Box
+          (Location 'a' 1 (-1))
+          (Original (solid 9))
+          (withForeColor defAttr red))
+    ])
+    'b'
+    (Set.fromList [Location 'g' (-2) 0])
+    (Location 'g' (-3) 0)

app/Model.hs

@@ -7,7 +7,7 @@ import Graphics.Vty
 import Control.Monad
 import Data.Maybe
 import Data.Set qualified as Set
-import Debug.Trace
+import Data.Set (Set)
 
 type Coord = (Int, Int)
 
@@ -34,7 +34,9 @@ data Location = Location Char Int Int
 
 data World = World {
   worldBoxes :: Map Char Box,
-  worldMe :: Char
+  worldMe :: Char,
+  worldButtons :: Set Location,
+  worldHome :: Location
 }
   deriving (Show, Read, Eq)
 

app/Rendering.hs

@@ -12,25 +12,45 @@ unit :: Attr -> Int -> Char -> Image
 unit a scale x =
     vertCat (replicate scale (string a (replicate (2*scale) x)))
 
+button :: Attr -> Int -> Image
+button a 1 = string a "[]"
+button a n = vertCat $
+  string a ('┌' : replicate (2*n-2) '─' ++ "┐") :
+  replicate (n-2) (string a ('│' : replicate (2*n-2) '░' ++ "│")) ++
+  [string a ('└' : replicate (2*n-2) '─' ++ "┘")]
+
+home :: Attr -> Int -> Image
+home a 1 = string a "<>"
+home a n = vertCat $
+  string a ('╔' : replicate (2*n-2) '═' ++ "╗") :
+  replicate (n-2) (string a ('║' : replicate (2*n-2) '░' ++ "║")) ++
+  [string a ('╚' : replicate (2*n-2) '═' ++ "╝")]
+
+
+
 renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image
 renderCell world locMap name box y x scale =
     if boxWalls world box ! (y,x) then unit (boxColor box) scale wallChar
       else case Map.lookup (Location name' y x) locMap of
-        Nothing -> unit (boxColor box) scale '░'
         Just n ->
             if scale == 1
                 then unit (boxColor (worldBoxes world Map.! n)) scale n 
                 else renderBox world locMap (worldBoxes world Map.! n) n
                         (scale `div` boxSize world box)
+        Nothing
+          | Set.member loc (worldButtons world) -> button (boxColor box) scale
+          | loc == worldHome world -> home (boxColor box) scale
+          | otherwise -> unit (boxColor box) scale '░'
     where
-        name' =
+      loc = Location name' y x
-            case boxType box of
+      name' =
-                Original{} -> name
+          case boxType box of
-                Link c -> c
+              Original{} -> name
-        wallChar =
+              Link c -> c
-            case boxType box of
+      wallChar =
-                Original{} -> '▓'
+          case boxType box of
-                Link{} -> '▒'
+              Original{} -> '▓'
+              Link{} -> '▒'
 
 renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Image
 renderBox world locMap box name scale =