aadit/tetris-cli
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implemented toggling functionality for Level Acceleration Mode

Browse source
This commit is contained in:
hello 2024-12-06 15:32:32 +05:30
parent b0c7f6c557
commit f074add7a3
7 changed files with 222 additions and 75 deletions
Download patch file Download diff file Expand all files Collapse all files

12
app/Main.hs
View file

@ -9,7 +9,7 @@ import qualified System.Directory as D
import System.FilePath ((</>))
import Tetris (Game(..))
import UI.PickLevel (pickLevel)
import UI.PickLevel (pickLevel, LevelConfig(..))
import UI.Game (playGame)
data Opts = Opts
@ -70,11 +70,11 @@ hdOptStr (CustomChars s) = Just s
main :: IO ()
main = do
(Opts hd ml hs) <- execParser fullopts -- get CLI opts/args
when hs (getHighScore >>= printM >> exitSuccess) -- show high score and exit
l <- maybe pickLevel return ml -- pick level prompt if necessary
g <- playGame l (hdOptStr hd) -- play game
handleEndGame (_score g) -- save & print score
(Opts hd ml hs) <- execParser fullopts
when hs (getHighScore >>= printM >> exitSuccess)
levelConfig <- maybe pickLevel (\l -> return $ LevelConfig l False) ml
g <- playGame (levelNumber levelConfig) (hdOptStr hd) (progression levelConfig)
handleEndGame (_score g)
handleEndGame :: Int -> IO ()
handleEndGame s = do

27
src/Tetris.hs
View file

@ -25,7 +25,7 @@ module Tetris
, Tetrimino(..)
, Tetris
-- Lenses
, block, board, level, nextShape, score, shape, linesCleared
, block, board, level, nextShape, score, shape, linesCleared, progression
-- Constants
, boardHeight, boardWidth, relCells
) where
@ -82,6 +82,7 @@ data Game = Game
, _linesCleared :: Int
, _score :: Int
, _board :: Board
, _progression :: Bool
} deriving (Eq)
makeLenses ''Game
@ -161,8 +162,8 @@ bagFourTetriminoEach Empty =
bagFourTetriminoEach <=< shuffle . Seq.fromList . take 28 $ cycle [I ..]
-- | Initialize a game with a given level
initGame :: Int -> IO Game
initGame lvl = do
initGame :: Int -> Bool -> IO Game -- Updated signature
initGame lvl prog = do
(s1, bag1) <- bagFourTetriminoEach mempty
(s2, bag2) <- bagFourTetriminoEach bag1
pure $ Game
@ -173,6 +174,7 @@ initGame lvl = do
, _score = 0
, _linesCleared = 0
, _board = mempty
, _progression = prog -- Added prog parameter
}
-- | Increment level
@ -191,9 +193,12 @@ timeStep = do
True -> do
freezeBlock
clearFullRows >>= updateScore
levelFinished >>= \case
True -> nextLevel
False -> nextBlock
prog <- use progression
when prog $ do
levelFinished >>= \case
True -> nextLevel
False -> pure ()
nextBlock
-- | Gravitate current block, i.e. shift down
gravitate :: MonadState Game m => m ()
@ -235,9 +240,13 @@ updateScore lines = do
-- | Using the fixed-goal system described here: https://tetris.wiki/Marathon
levelFinished :: (MonadState Game m, MonadIO m) => m Bool
levelFinished = do
lvl <- use level
lc <- use linesCleared
pure $ lvl < 15 && lc >= 10 * (lvl + 1)
prog <- use progression
if not prog
then pure False
else do
lvl <- use level
lc <- use linesCleared
pure $ lvl < 15 && lc >= 10 * (lvl + 1)
-- | Handle counterclockwise block rotation (if possible)
-- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation

80
src/UI/Game.hs
View file

@ -30,12 +30,12 @@ import Linear.V2 (V2(..))
import Tetris
data UI = UI
{ _game :: Game -- ^ tetris game
, _initLevel :: Int -- ^ initial level chosen
, _currLevel :: TVar Int -- ^ current level
, _preview :: Maybe String -- ^ hard drop preview cell
, _locked :: Bool -- ^ lock after hard drop before time step
, _paused :: Bool -- ^ game paused
{ _game :: Game
, _initLevel :: Int
, _currLevel :: TVar Int
, _preview :: Maybe String
, _locked :: Bool
, _paused :: Bool
}
makeLenses ''UI
@ -61,28 +61,24 @@ app = App
, appAttrMap = const theMap
}
playGame
:: Int -- ^ Starting level
-> Maybe String -- ^ Preview cell (Nothing == no preview)
-> IO Game
playGame lvl mp = do
playGame :: Int -> Maybe String -> Bool -> IO Game
playGame lvl mp prog = do
chan <- newBChan 10
-- share the current level with the thread so it can adjust speed
tv <- newTVarIO lvl
void . forkIO $ forever $ do
writeBChan chan Tick
lvl <- readTVarIO tv
threadDelay $ levelToDelay lvl
initialGame <- initGame lvl
initialGame <- initGame lvl prog -- Pass the progression parameter
let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig
initialVty <- buildVty
ui <- customMain initialVty buildVty (Just chan) app $ UI
{ _game = initialGame
{ _game = initialGame
, _initLevel = lvl
, _currLevel = tv
, _preview = mp
, _locked = False
, _paused = False
, _preview = mp
, _locked = False
, _paused = False
}
return $ ui ^. game
@ -129,8 +125,9 @@ exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom
-- | Restart game at the initially chosen level
restart :: EventM Name UI ()
restart = do
lvl <- use $ initLevel
g <- liftIO $ initGame lvl
lvl <- use initLevel
prog <- use (game . progression) -- Get current progression setting
g <- liftIO $ initGame lvl prog -- Use it when restarting
assign game g
assign locked False
@ -214,9 +211,18 @@ drawStats g =
[ drawStat "Score" $ g ^. score
, padTop (Pad 1) $ drawStat "Lines" $ g ^. linesCleared
, padTop (Pad 1) $ drawStat "Level" $ g ^. level
, padTop (Pad 1) $ drawProgression (g ^. progression)
, drawLeaderBoard g
]
drawProgression :: Bool -> Widget Name
drawProgression True =
padLeftRight 1 $ str "Level Mode: " <+>
withAttr progressionAttr (str "ON")
drawProgression False =
padLeftRight 1 $ str "Level Mode: " <+>
withAttr fixedAttr (str "OFF")
drawStat :: String -> Int -> Widget Name
drawStat s n = padLeftRight 1 $ str s <+> padLeft Max (str $ show n)
@ -278,21 +284,23 @@ drawGameOver g =
theMap :: AttrMap
theMap = attrMap
V.defAttr
[ (iAttr , tToColor I `on` tToColor I)
, (oAttr , tToColor O `on` tToColor O)
, (tAttr , tToColor T `on` tToColor T)
, (sAttr , tToColor S `on` tToColor S)
, (zAttr , tToColor Z `on` tToColor Z)
, (jAttr , tToColor J `on` tToColor J)
, (lAttr , tToColor L `on` tToColor L)
, (ihAttr , fg $ tToColor I)
, (ohAttr , fg $ tToColor O)
, (thAttr , fg $ tToColor T)
, (shAttr , fg $ tToColor S)
, (zhAttr , fg $ tToColor Z)
, (jhAttr , fg $ tToColor J)
, (lhAttr , fg $ tToColor L)
, (gameOverAttr, fg V.red `V.withStyle` V.bold)
[ (iAttr , tToColor I `on` tToColor I)
, (oAttr , tToColor O `on` tToColor O)
, (tAttr , tToColor T `on` tToColor T)
, (sAttr , tToColor S `on` tToColor S)
, (zAttr , tToColor Z `on` tToColor Z)
, (jAttr , tToColor J `on` tToColor J)
, (lAttr , tToColor L `on` tToColor L)
, (ihAttr , fg $ tToColor I)
, (ohAttr , fg $ tToColor O)
, (thAttr , fg $ tToColor T)
, (shAttr , fg $ tToColor S)
, (zhAttr , fg $ tToColor Z)
, (jhAttr , fg $ tToColor J)
, (lhAttr , fg $ tToColor L)
, (gameOverAttr , fg V.red `V.withStyle` V.bold)
, (progressionAttr, fg V.green `V.withStyle` V.bold)
, (fixedAttr , fg V.blue `V.withStyle` V.bold)
]
tToColor :: Tetrimino -> V.Color
@ -327,3 +335,7 @@ emptyAttr = attrName "empty"
gameOverAttr :: AttrName
gameOverAttr = attrName "gameOver"
progressionAttr, fixedAttr :: AttrName
progressionAttr = attrName "progression"
fixedAttr = attrName "fixed"

92
src/UI/PickLevel.hs
View file

@ -1,5 +1,6 @@
module UI.PickLevel
( pickLevel
, LevelConfig(..)
) where
import System.Exit (exitSuccess)
@ -11,17 +12,39 @@ import qualified Brick.Widgets.Border.Style as BS
import qualified Brick.Widgets.Center as C
import qualified Graphics.Vty as V
app :: App (Maybe Int) e ()
data LevelConfig = LevelConfig
{ levelNumber :: Int
, progression :: Bool
} deriving (Show, Eq)
data MenuOption = YesOption | NoOption deriving (Eq)
data PickState = PickState
{ currentLevel :: Maybe Int
, showProgression :: Bool
, pickingLevel :: Bool
, selectedOption :: MenuOption
}
app :: App PickState e ()
app = App
{ appDraw = const [ui]
{ appDraw = drawUI
, appHandleEvent = handleEvent
, appStartEvent = pure ()
, appAttrMap = const $ attrMap V.defAttr []
, appAttrMap = const $ attrMap V.defAttr
[ (selectedAttr, V.black `on` V.white)
]
, appChooseCursor = neverShowCursor
}
ui :: Widget ()
ui =
selectedAttr :: AttrName
selectedAttr = attrName "selected"
drawUI :: PickState -> [Widget ()]
drawUI ps = [ui ps]
ui :: PickState -> Widget ()
ui ps =
padLeft (Pad 19)
$ padRight (Pad 21)
$ C.center
@ -30,17 +53,62 @@ ui =
$ withBorderStyle BS.unicodeBold
$ B.borderWithLabel (str "Tetris")
$ C.center
$ str " Choose Level (0-9)"
$ vBox
[ if pickingLevel ps
then str "Choose Level (0-9)"
else vBox
[ str "Level Progression?"
, str ""
, drawOption "YES" YesOption (selectedOption ps)
, drawOption "NO" NoOption (selectedOption ps)
, str ""
, str "Use ↑↓ to select"
, str "Press Enter to continue"
]
]
handleEvent :: BrickEvent () e -> EventM () (Maybe Int) ()
drawOption :: String -> MenuOption -> MenuOption -> Widget ()
drawOption label opt current =
withAttr (if opt == current then selectedAttr else attrName "")
$ str $ " " ++ label ++ " "
handleEvent :: BrickEvent () e -> EventM () PickState ()
handleEvent (VtyEvent (V.EvKey V.KEsc _)) = halt
handleEvent (VtyEvent (V.EvKey (V.KChar 'q') _)) = halt
handleEvent (VtyEvent (V.EvKey (V.KChar 'Q') _)) = halt
handleEvent (VtyEvent (V.EvKey (V.KChar d) [])) =
when (d `elem` ['0' .. '9']) $ do
put $ Just $ read [d]
halt
whenPickingLevel $ when (d `elem` ['0' .. '9']) $ do
modify $ \s -> s { currentLevel = Just $ read [d], pickingLevel = False }
handleEvent (VtyEvent (V.EvKey V.KEnter [])) = do
s <- get
when (not $ pickingLevel s) $ do
case currentLevel s of
Just l -> do
put $ PickState (Just l) (selectedOption s == YesOption) True YesOption
halt
Nothing -> pure ()
handleEvent (VtyEvent (V.EvKey V.KUp [])) =
whenNotPickingLevel $ modify $ \s -> s { selectedOption = YesOption }
handleEvent (VtyEvent (V.EvKey V.KDown [])) =
whenNotPickingLevel $ modify $ \s -> s { selectedOption = NoOption }
handleEvent _ = pure ()
pickLevel :: IO Int
pickLevel = defaultMain app Nothing >>= maybe exitSuccess return
whenPickingLevel :: EventM () PickState () -> EventM () PickState ()
whenPickingLevel action = do
picking <- gets pickingLevel
when picking action
whenNotPickingLevel :: EventM () PickState () -> EventM () PickState ()
whenNotPickingLevel action = do
picking <- gets pickingLevel
when (not picking) action
initialState :: PickState
initialState = PickState Nothing True True YesOption
pickLevel :: IO LevelConfig
pickLevel = do
result <- defaultMain app initialState
case currentLevel result of
Nothing -> exitSuccess
Just l -> return $ LevelConfig l (showProgression result)

75
stack.yaml
View file

@ -1,10 +1,67 @@
flags: {}
extra-package-dbs: []
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# A 'specific' Stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# snapshot: lts-22.28
# snapshot: nightly-2024-07-05
# snapshot: ghc-9.6.6
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# snapshot: ./custom-snapshot.yaml
# snapshot: https://example.com/snapshots/2024-01-01.yaml
snapshot:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- '.'
extra-deps: []
resolver: lts-22.19
nix:
packages:
- gcc
- ncurses
- .
# Dependency packages to be pulled from upstream that are not in the snapshot.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
# Override default flag values for project packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of Stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=3.1"
#
# Override the architecture used by Stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by Stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

9
stack.yaml.lock
View file

@ -6,7 +6,8 @@
packages: []
snapshots:
- completed:
sha256: e5cac927cf7ccbd52aa41476baa68b88c564ee6ddc3bc573dbf4210069287fe7
size: 713340
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/19.yaml
original: lts-22.19
sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146
size: 720271
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml

2
tetris.cabal
View file

@ -1,5 +1,5 @@
name: tetris
version: 0.1.5
version: 0.1.6
homepage: https://github.com/samtay/tetris#readme
license: BSD3
license-file: LICENSE