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.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)

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

data GameMode
  = MenuMode
  | PlayMode (NonEmpty World)

getWorldList :: IO (Map String FilePath)
getWorldList =
 do paths <- 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
        let (a,b) = Map.splitAt (gameSelect game) worldList
        bnds <- displayBounds (outputIface vty)
        update vty (picForImage (renderMenu bnds a b))
        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 | Just (path,_) <- Map.minView b ->
                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 ->
            case key of
              KUp    -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (-1,0)) worlds) }
              KDown  -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (1,0) ) worlds) }
              KLeft  -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,-1)) worlds) }
              KRight -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,1) ) worlds) }
              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 :: DisplayRegion -> Map String a -> Map String a -> Image
renderMenu (w,h) before after =
  pad ((w - imageWidth menu) `div` 2) 0 0 0 menu
  where
    menu =
      case Map.minViewWithKey after of
        Nothing -> string defAttr "empty menu"
        Just ((k,_),after') ->
          let len1 = (h-1)`div`2 in
          pad 0 (len1 - Map.size before) 0 0 (vertCat
            [ string defAttr x
              | x <- drop (Map.size before - len1) (Map.keys before)
            ]) <->
            string (defAttr `withBackColor` cyan `withForeColor` white) k
            <->
            vertCat
            [ string defAttr x
              | x <- drop (Map.size after' - h`div`2) (Map.keys after')
            ]