parabox/app/Main.hs

module Main (main) where

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

import BigFont (bigText)
import Model
import Parser (parse)
import Rendering (render, wrapBox)

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

data GameMode
  = MenuMode
  | PlayMode (NonEmpty World)

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

isLevelName :: FilePath -> Bool
isLevelName path = not ("." `isPrefixOf` path) && ".txt" == takeExtension path

defaultGame :: Game
defaultGame = Game {
  gameMode = MenuMode,
  gameFlat = True,
  gameSelect = 0,
  gameError = ""
}

main :: IO ()
main =
 do args <- getArgs
    worldList <- getWorldList
    bracket (mkVty =<< userConfig) shutdown \vty ->
      case args of
        x:_ | Just path <- Map.lookup x worldList ->
            loadLevelFile vty defaultGame path
        _ -> loop vty defaultGame

loop :: Vty -> Game -> IO ()
loop vty game = do
  bnds <- displayBounds (outputIface vty)
  case gameMode game of
    MenuMode ->
     do worldList <- getWorldList
        update vty (picForLayers $
                      [errorImage (gameError game) | not (null (gameError game))] ++
                      [renderMenu bnds (gameSelect game) worldList])
        ev <- nextEvent vty
        case ev of
          EvKey key _modifier ->
            case key of
              KEsc      -> escape vty game
              KUp       -> loop vty game{ gameSelect = max 0 (gameSelect game -  1) }
              KPageUp   -> loop vty game{ gameSelect = max 0 (gameSelect game - 10) }
              KDown     -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game +  1) }
              KPageDown -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game + 10) }
              KEnter
                | 0 <= gameSelect game, gameSelect game < Map.size worldList
                , (_, path) <- Map.elemAt (gameSelect game) worldList ->
                  loadLevelFile vty game path
              _ -> loop vty game
          _ -> loop vty game

    PlayMode worlds ->
     do let world = NonEmpty.head worlds
        update vty (render bnds (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 -> escape vty game
              KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) }
              _ -> loop vty game
          _ -> loop vty game

escape :: Vty -> Game -> IO ()
escape vty game
  | null (gameError game) = pure ()
  | otherwise = loop vty game{ gameError = "" }

loadLevelFile :: Vty -> Game -> FilePath -> IO ()
loadLevelFile vty game path =
 do file <- readFile path
    case parse file of
      Left errorMessage -> loop vty game{ gameError = errorMessage }
      Right world -> loop vty game{
                       gameMode = PlayMode (pure world),
                       gameError = ""
                     }

renderMenu :: DisplayRegion -> Int -> Map String a -> Image
renderMenu (w,h) sel list
  | 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)
      ]

errorImage :: String -> Image
errorImage str = wrapBox a (bigString a str)
  where
    a = defAttr `withForeColor` red

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