{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Imj.Game.Hamazed.Parameters(
GameParameters(..)
, getGameParameters
) where
import Imj.Prelude
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Reader.Class(MonadReader)
import Imj.Game.Hamazed.Color
import Imj.Game.Hamazed.World.Create
import Imj.Game.Hamazed.World.InTerminal
import Imj.Game.Hamazed.World.Render
import Imj.Game.Hamazed.World.Size
import Imj.Game.Hamazed.World.Space
import Imj.Game.Hamazed.World.Types
import Imj.Geo.Discrete
import Imj.Graphics.Text.Alignment
import Imj.Graphics.UI.Animation
import Imj.Graphics.UI.Colored
import Imj.Input.Blocking
import Imj.Input.Types
import Imj.Timing
data GameParameters = GameParameters {
_gameParamsWorldShape :: !WorldShape
, _gameParamsWallDistrib :: !WallDistribution
}
minRandomBlockSize :: Int
minRandomBlockSize = 6
initialParameters :: GameParameters
initialParameters = GameParameters Square None
{-# INLINABLE getGameParameters #-}
getGameParameters :: (Render e, MonadReader e m, MonadIO m)
=> m GameParameters
getGameParameters = update initialParameters
{-# INLINABLE update #-}
update :: (Render e, MonadReader e m, MonadIO m)
=> GameParameters
-> m GameParameters
update params = do
render' params
liftIO getKeyThenFlush >>= \case
AlphaNum c ->
if c == ' '
then
return params
else
update $ updateFromChar c params
_ -> return params
updateFromChar :: Char -> GameParameters -> GameParameters
updateFromChar c p@(GameParameters shape wallType) =
case c of
'1' -> GameParameters Square wallType
'2' -> GameParameters Rectangle2x1 wallType
'e' -> GameParameters shape None
'r' -> GameParameters shape Deterministic
't' -> GameParameters shape (Random $ RandomParameters minRandomBlockSize StrictlyOneComponent)
_ -> p
{-# INLINABLE dText #-}
dText :: (Draw e, MonadReader e m, MonadIO m)
=> Text
-> Coords Pos
-> m (Coords Pos)
dText txt pos =
drawTxt txt pos configColors >> return (translateInDir Down pos)
{-# INLINABLE dText_ #-}
dText_ :: (Draw e, MonadReader e m, MonadIO m)
=> Text
-> Coords Pos
-> m ()
dText_ txt pos =
void (dText txt pos)
{-# INLINABLE render' #-}
render' :: (Render e, MonadReader e m, MonadIO m)
=> GameParameters
-> m ()
render' (GameParameters shape wall) = do
let worldSize@(Size (Length rs) (Length cs)) = worldSizeFromLevel 1 shape
mkInTerminal worldSize >>= \case
Left err -> error err
Right rew@(InTerminal _ ul) -> do
world@(World _ _ space _ _) <- mkWorld rew worldSize wall [] 0
_ <- renderSpace space ul >>=
\worldCoords -> do
renderWorld world
let middle = move (quot cs 2) RIGHT worldCoords
middleCenter = move (quot (rs-1) 2 ) Down middle
middleLow = move (rs-1) Down middle
leftMargin = 3
left = move (quot (rs-1) 2 - leftMargin) LEFT middleCenter
drawAlignedTxt "Game configuration" configColors (mkCentered $ translateInDir Down middle)
>>= drawAlignedTxt_ "------------------" configColors
drawAlignedTxt_ "Hit 'Space' to start game" configColors (mkCentered $ translateInDir Up middleLow)
translateInDir Down <$> dText "- World shape" (move 5 Up left)
>>= dText "'1' -> width = height"
>>= dText_ "'2' -> width = 2 x height"
translateInDir Down <$> dText "- World walls" left
>>= dText "'e' -> no walls"
>>= dText "'r' -> deterministic walls"
>>= dText_ "'t' -> random walls"
t <- liftIO getSystemTime
let infos = (Colored worldFrameColors $ mkWorldContainer world, (([""],[""]),[[""],[""]]))
renderUIAnimation $ mkUIAnimation infos infos t
renderToScreen