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 Model
import Rendering

world0 :: World
world0 = World {
  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 =
  bracket (mkVty =<< userConfig) shutdown \vty ->
   do
      loop vty (pure world0)
      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 'z'
            | Just worlds <- NonEmpty.nonEmpty history ->
              loop vty worlds
          KEsc -> pure ()
          _ -> loop vty (world :| history)
      _ -> loop vty (world :| history)

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'