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
    let name = case args of x:_ -> x; [] -> ""
    bracket (mkVty =<< userConfig) shutdown \vty ->
     do
        loop vty (pure (pickWorld name))
        pure ()

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)

pickWorld :: String -> World
pickWorld "world0" = world0
pickWorld "small" = smallWorld
pickWorld "center8" = center8
pickWorld "center13" = center13
pickWorld "clone11" = clone11
pickWorld _ = 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)