parabox/app/Main.hs

module Main (main) where

import Control.Exception ( bracket )
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Char (toUpper)
import Data.List (intersperse, sort)
import Data.Map (Map)
import Data.Map qualified as Map
import Graphics.Vty
import System.Environment ( getArgs )
import System.Directory ( listDirectory )
import System.FilePath ( (</>), takeBaseName )

import Model
import Rendering ( render )
import Parser (parse)
import BigFont

data Game = Game {
  gameFlat :: Bool,
  gameMode :: GameMode,
  gameSelect :: Int
}

data GameMode
  = MenuMode
  | PlayMode (NonEmpty World)

getWorldList :: IO (Map String FilePath)
getWorldList =
 do paths <- sort <$> listDirectory "levels"
    pure (Map.fromList [(takeBaseName path, "levels" </> path) | path <- paths])

main :: IO ()
main =
 do args <- getArgs
    worldList <- getWorldList
    bracket (mkVty =<< userConfig) shutdown \vty ->
      case args of
        x:_ | Just path <- Map.lookup x worldList ->
         do w <- parse <$> readFile path 
            loop vty Game {
              gameMode = PlayMode (pure w),
              gameFlat = True,
              gameSelect = Map.findIndex x worldList
              }
        _ ->
          loop vty Game {
            gameMode = MenuMode,
            gameFlat = True,
            gameSelect = 0
          }

loop :: Vty -> Game -> IO ()
loop vty game =
  case gameMode game of
    MenuMode ->
     do worldList <- getWorldList
        bnds <- displayBounds (outputIface vty)
        update vty (picForImage (renderMenu (gameSelect game) worldList bnds))
        ev <- nextEvent vty
        case ev of
          EvKey key _modifier ->
            case key of
              KEsc -> pure ()
              KUp | gameSelect game > 0 ->
                loop vty game{ gameSelect = gameSelect game - 1 }
              KDown | gameSelect game + 1 < Map.size worldList ->
                loop vty game{ gameSelect = gameSelect game + 1 }
              KEnter | (_, path) <- Map.elemAt (gameSelect game) worldList ->
                do world <- parse <$> readFile path
                   loop vty game{ gameMode = PlayMode (pure world) }
              _ -> loop vty game
          _ -> loop vty game

    PlayMode worlds ->
     do let world = NonEmpty.head worlds
        update vty (render (gameFlat game) (NonEmpty.head worlds))
        ev <- nextEvent vty
        case ev of
          EvKey key _modifier ->
            let doMove m = game{ gameMode = PlayMode (move world m <| worlds) } in
            case key of
              KUp    -> loop vty (doMove (-1, 0))
              KDown  -> loop vty (doMove ( 1, 0))
              KLeft  -> loop vty (doMove ( 0,-1))
              KRight -> loop vty (doMove ( 0, 1))
              KChar 'm' -> loop vty game { gameMode = MenuMode }
              KChar 'r' -> loop vty game{ gameMode = PlayMode (pure (NonEmpty.last worlds)) }
              KChar 'z'
                | Just worlds' <- NonEmpty.nonEmpty (NonEmpty.tail worlds) ->
                  loop vty game{ gameMode = PlayMode worlds' }
              KEsc -> pure ()
              KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) }
              _ -> loop vty game
          _ -> loop vty game


renderMenu :: Int -> Map String a -> DisplayRegion -> Image
renderMenu sel list (w,h)
  | hpad >= 0 = pad wpad hpad 0 0 menu
  | otherwise = pad wpad 0 0 0 (cropTop (imageHeight menu + hpad) menu)
  where
    hpad = h`div`2 - sel*6
    wpad = max 0 (w - imageWidth menu) `div` 2
    menu =
      vertCat $
      intersperse (char defAttr ' ') $
      [ bigString (if sel == i then defAttr `withBackColor` cyan `withForeColor` white
                   else defAttr) k
        | (i,k) <- zip [0..] (Map.keys list)
      ]

bigString :: Attr -> String -> Image
bigString a = vertCat . map (string a) . bigText . map toUpper