parabox/app/Main.hs

module Main where

import Data.Map qualified as Map
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 {
      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'
    })
    ]
  }

main :: IO ()
main =
 do args <- getArgs
    case args of 
      x:_ | Just w <- Map.lookup x worldList ->  
        bracket (mkVty =<< userConfig) shutdown \vty ->
          loop vty (pure w)
      _ ->
       do putStrLn "Usage: parabox <worldname>"
          putStrLn "" 
          putStrLn "Available worlds:" 
          mapM_ putStrLn (Map.keys worldList)

loop :: Vty -> NonEmpty World -> IO ()
loop vty (world :| history) =
 do update vty (picForImage (drawNestedWorld world))
    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)))
          KChar 'z'
            | Just worlds <- NonEmpty.nonEmpty history ->
              loop vty worlds
          KEsc -> pure ()
          _ -> loop vty (world :| history)
      _ -> loop vty (world :| history)


worldList :: Map.Map String World
worldList = Map.fromList
  [ ("world0", world0)
  , ("small", smallWorld)
  , ("center8", center8)
  , ("center13", center13)
  , ("clone11", clone11)
  , ("transfer14", transfer14)
  ]

smallWorld :: World
smallWorld =
  World
    (Map.fromList
    [('a',
      Box (Location 'a' 0 0)
          (Original (makeWalls [
            "▓▓▓▓▓▓▓▓▓",
            "▓  ▓    ▓",
            "▓  ▓    ▓",
            "▓▓▓▓    ▓",
            "▓       ▓",
            "▓       ▓",
            "▓       ▓",
            "▓       ▓",
            "▓▓▓▓▓▓▓▓▓"
           ]))
          (withForeColor defAttr black)),
      ('1',
        Box
          (Location 'a' (-3) (-3))
          (Original (makeWalls (replicate 9 (replicate 9 ' '))))
          (withForeColor defAttr yellow)),
      ('2',
        Box
          (Location 'a' (-3) (-2))
          (Original (makeWalls (replicate 9 (replicate 9 ' '))))
          (withForeColor defAttr magenta)),
      ('3',
        Box
          (Location 'a' (-2) (-3))
          (Original (makeWalls (replicate 9 (replicate 9 ' '))))
          (withForeColor defAttr blue)),
      ('4',
        Box
          (Location 'a' (-2) (-2))
          (Original (makeWalls (replicate 9 (replicate 9 ' '))))
          (withForeColor defAttr green)),
      ('b',
        Box
          (Location '1' 0 0)
          (Original (solid 9))
          (withForeColor defAttr red))
    ]) 'b'
    Set.empty
    (Location 'b' 0 0)

center8 :: World
center8 =
  World
    (Map.fromList
    [('a',
      Box (Location 'a' 3 (-3))
          (Original (makeWalls [
            "▓▓▓▓▓▓▓▓▓",
            "▓▓▓▓▓▓▓▓▓",
            "▓▓     ▓▓",
            "▓▓     ▓▓",
            "▓      ▓▓",
            "▓      ▓▓",
            "▓▓▓▓ ▓▓▓▓",
            "▓ ▓▓   ▓▓",
            "▓▓▓▓▓▓▓▓▓"
           ]))
          (withForeColor defAttr black)),
      ('1',
        Box
          (Location 'a' 0 0)
          (Original (makeWalls [
            "       ▓▓",
            "    ▓▓▓▓▓",
            "         ",
            "         ",
            "         ",
            "         ",
            "         ",
            "         ",
            "         "
           ]))
          (withForeColor defAttr green)),
      ('2',
        Box
          (Location '1' (-4) 0)
          (Original (solid 9))
          (withForeColor defAttr yellow)),
      ('b',
        Box
          (Location 'a' (-1) 0)
          (Original (solid 9))
          (withForeColor defAttr red))
    ]) 'b'
    Set.empty
    (Location 'a' 3 2)

center13 :: World
center13 =
  World
    (Map.fromList
    [('a',
      Box (Location 'a' 3 (-3))
          (Original (makeWalls [
            "▓▓▓▓▓▓▓▓▓",
            "▓       ▓",
            "▓       ▓",
            "▓       ▓",
            "▓       ▓",
            "▓  ▓▓▓ ▓▓",
            "▓  ▓ ▓ ▓▓",
            "▓ ▓▓    ▓",
            "▓▓▓▓▓▓▓▓▓"
           ]))
          (withForeColor defAttr cyan)),
      ('1',
        Box
          (Location 'a' (-1) 1)
          (Original (makeWalls [
            "         ",
            " ▓▓▓▓▓▓▓ ",
            " ▓▓▓▓▓▓▓ ",
            " ▓▓▓▓▓▓▓ ",
            " ▓▓▓▓▓▓▓ ",
            " ▓▓▓▓▓▓▓ ",
            " ▓▓▓▓▓▓▓ ",
            " ▓▓▓▓▓▓▓ ",
            "         "
           ]))
          (withForeColor defAttr green)),
      ('2',
        Box
          (Location 'a' (-1) (-1))
          (Original (solid 9))
          (withForeColor defAttr yellow)),
      ('b',
        Box
          (Location 'a' (-3) 0)
          (Original (solid 9))
          (withForeColor defAttr red))
    ]) 'b'
    Set.empty
    (Location 'a' 2 0)


clone11 :: World
clone11 =
  World
    (Map.fromList
    [('a',
      Box (Location 'a' (-2) 2)
          (Original (makeWalls [
            "▓▓▓▓▓▓▓▓▓",
            "▓   ▓   ▓",
            "▓   ▓   ▓",
            "▓   ▓   ▓",
            "    ▓    ",
            "▓   ▓   ▓",
            "▓   ▓   ▓",
            "▓▓▓   ▓▓▓",
            "▓▓▓▓▓▓▓▓▓"
           ]))
          (withForeColor defAttr green)),
      ('A',
        Box
          (Location 'a' 0 2)
          (Link 'a')
          (withForeColor defAttr green)),
      ('b',
        Box
          (Location 'a' 0 (-2))
          (Original (solid 9))
          (withForeColor defAttr red))
    ])
    '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)