From bcd6b3897826d7b54288ea723636baff11c77a6e Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Mon, 6 May 2024 12:33:41 -0400 Subject: [PATCH 01/10] Bump to lts-22.19 and brick-2.1.1 --- src/UI/Game.hs | 8 +++++--- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- tetris.cabal | 2 ++ 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/UI/Game.hs b/src/UI/Game.hs index c4c5214..353eaf3 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -19,6 +19,8 @@ import qualified Brick.Widgets.Border.Style as BS import qualified Brick.Widgets.Center as C import Control.Lens hiding (preview, op, zoom) import qualified Graphics.Vty as V +import qualified Graphics.Vty.CrossPlatform +import qualified Graphics.Vty.Config import Data.Map (Map) import qualified Data.Map as M import Linear.V2 (V2(..)) @@ -66,9 +68,9 @@ playGame lvl mp = do writeBChan chan Tick threadDelay delay initialGame <- initGame lvl - let builder = V.mkVty V.defaultConfig - initialVty <- builder - ui <- customMain initialVty builder (Just chan) app $ UI + let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig + initialVty <- buildVty + ui <- customMain initialVty buildVty (Just chan) app $ UI { _game = initialGame , _preview = mp , _locked = False diff --git a/stack.yaml b/stack.yaml index 906c2fd..be59776 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,7 @@ extra-package-dbs: [] packages: - '.' extra-deps: [] -resolver: lts-20.1 +resolver: lts-22.19 nix: packages: - gcc diff --git a/stack.yaml.lock b/stack.yaml.lock index e067f78..f8f2098 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5 - size: 648424 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml - original: lts-20.1 + sha256: e5cac927cf7ccbd52aa41476baa68b88c564ee6ddc3bc573dbf4210069287fe7 + size: 713340 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/19.yaml + original: lts-22.19 diff --git a/tetris.cabal b/tetris.cabal index 8520835..46ab498 100644 --- a/tetris.cabal +++ b/tetris.cabal @@ -21,9 +21,11 @@ library , containers , lens , linear + , mtl , random , transformers , vty + , vty-crossplatform default-language: Haskell2010 executable tetris From e8c6c804c5d4330e91497be64490c0724dcba56c Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Mon, 6 May 2024 13:39:16 -0400 Subject: [PATCH 02/10] Refactor --- src/Tetris.hs | 36 +++++++++++++++---------------- src/UI/Game.hs | 57 +++++++++++++++++--------------------------------- tetris.cabal | 1 + 3 files changed, 37 insertions(+), 57 deletions(-) diff --git a/src/Tetris.hs b/src/Tetris.hs index cc04ee9..767bb88 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -11,7 +12,6 @@ module Tetris , rotate , hardDrop -- Game state handlers - , execTetris , evalTetris -- Game state queries , isGameOver @@ -33,9 +33,10 @@ module Tetris import Prelude hiding (Left, Right) import Control.Applicative ((<|>)) import Control.Monad (forM_, mfilter, when, (<=<)) -import Control.Monad.IO.Class (MonadIO(..), liftIO) -import Control.Monad.Trans.State (StateT(..), gets, evalStateT, execStateT) +import Control.Monad.IO.Class (MonadIO(..), liftIO) +import Control.Monad.State.Class (MonadState, gets) +import Control.Monad.Trans.State (evalStateT) import Data.Map (Map) import qualified Data.Map as M import Data.Sequence (Seq(..), (><)) @@ -44,6 +45,7 @@ import Control.Lens hiding (Empty) import Linear.V2 (V2(..), _y) import qualified Linear.V2 as LV import System.Random (getStdRandom, randomR) + -- Types and instances -- | Tetris shape types @@ -83,14 +85,10 @@ data Game = Game } deriving (Eq, Show) makeLenses ''Game -type TetrisT = StateT Game -type Tetris a = forall m. (Monad m) => TetrisT m a - evalTetris :: Tetris a -> Game -> a evalTetris m = runIdentity . evalStateT m -execTetris :: Tetris a -> Game -> Game -execTetris m = runIdentity . execStateT m +type Tetris a = forall m. MonadState Game m => m a -- Translate class for direct translations, without concern for boundaries -- 'shift' concerns safe translations with boundaries @@ -181,7 +179,7 @@ isGameOver :: Game -> Bool isGameOver g = blockStopped g && g ^. (block . origin) == startOrigin -- | The main game execution, this is executed at each discrete time step -timeStep :: MonadIO m => TetrisT m () +timeStep :: (MonadIO m, MonadState Game m) => m () timeStep = do gets blockStopped >>= \case False -> gravitate @@ -193,11 +191,11 @@ timeStep = do nextBlock -- | Gravitate current block, i.e. shift down -gravitate :: Tetris () +gravitate :: MonadState Game m => m () gravitate = shift Down -- | If necessary: clear full rows and return the count -clearFullRows :: Tetris Int +clearFullRows :: MonadState Game m => m Int clearFullRows = do brd <- use board let rowSize r = length $ M.filterWithKey (\(V2 _ y) _ -> r == y) brd @@ -210,7 +208,7 @@ clearFullRows = do return $ length fullRows -- | Empties row on 0, otherwise appends value (just keeps consecutive information) -addToRowClears :: Int -> Tetris () +addToRowClears :: MonadState Game m => Int -> m () addToRowClears 0 = rowClears .= mempty addToRowClears n = rowClears %= (|> n) @@ -220,7 +218,7 @@ addToRowClears n = rowClears %= (|> n) -- Note I'm keeping rowClears as a sequence in case I want to award -- more points for back to back clears, right now the scoring is more simple, -- but you do get more points for more rows cleared at once. -updateScore :: Tetris () +updateScore :: MonadState Game m => m () updateScore = do multiplier <- (1 +) <$> use level clears <- latestOrZero <$> use rowClears @@ -240,7 +238,7 @@ updateScore = do -- | Handle counterclockwise block rotation (if possible) -- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation -rotate :: Tetris () +rotate :: MonadState Game m => m () rotate = do blk <- use block brd <- use board @@ -264,10 +262,10 @@ isStopped brd = any stopped . coords stopped = (||) <$> atBottom <*> (`M.member` brd) . translate Down atBottom = (== 1) . view _y -hardDrop :: Tetris () +hardDrop :: MonadState Game m => m () hardDrop = hardDroppedBlock >>= assign block -hardDroppedBlock :: Tetris Block +hardDroppedBlock :: MonadState Game m => m Block hardDroppedBlock = do boardCoords <- M.keys <$> use board blockCoords <- coords <$> use block @@ -283,13 +281,13 @@ hardDroppedBlock = do translateBy dist Down <$> use block -- | Freeze current block -freezeBlock :: Tetris () +freezeBlock :: MonadState Game m => m () freezeBlock = do blk <- use block modifying board $ M.union $ M.fromList [ (c, _shape blk) | c <- coords blk ] -- | Replace block with next block -nextBlock :: MonadIO m => TetrisT m () +nextBlock :: (MonadIO m, MonadState Game m) => m () nextBlock = do bag <- use nextShapeBag (t, ts) <- liftIO $ bagFourTetriminoEach bag @@ -298,7 +296,7 @@ nextBlock = do nextShapeBag .= ts -- | Try to shift current block; if shifting not possible, leave block where it is -shift :: Direction -> Tetris () +shift :: MonadState Game m => Direction -> m () shift dir = do brd <- use board blk <- use block diff --git a/src/UI/Game.hs b/src/UI/Game.hs index 353eaf3..793a88c 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -7,9 +8,7 @@ module UI.Game ) where import Control.Concurrent (threadDelay, forkIO) -import Control.Monad (void, forever, when, unless) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State (execStateT) +import Control.Monad (void, forever) import Prelude hiding (Left, Right) import Brick hiding (Down) @@ -18,6 +17,8 @@ import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border.Style as BS import qualified Brick.Widgets.Center as C import Control.Lens hiding (preview, op, zoom) +import Control.Monad.Extra (orM, unlessM) +import Control.Monad.IO.Class (liftIO) import qualified Graphics.Vty as V import qualified Graphics.Vty.CrossPlatform import qualified Graphics.Vty.Config @@ -84,7 +85,9 @@ levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n) -- Handling events handleEvent :: BrickEvent Name Tick -> EventM Name UI () -handleEvent (AppEvent Tick ) = handleTick +handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart +handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt handleEvent (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right) handleEvent (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left) handleEvent (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down) @@ -94,53 +97,31 @@ handleEvent (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down) handleEvent (VtyEvent (V.EvKey V.KUp [])) = exec rotate handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) = - guarded - (not . view paused) - (over game (execTetris hardDrop) . set locked True) + unlessM (orM [use paused, use (game . to isGameOver)]) $ do + zoom game hardDrop + assign locked True handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) = - guarded - (not . view locked) - (over paused not) -handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart -handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt -handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt + unlessM (orM [use locked, use (game . to isGameOver)]) $ do + modifying paused not +handleEvent (AppEvent Tick ) = + unlessM (orM [use paused, use (game . to isGameOver)]) $ do + zoom game timeStep + assign locked False handleEvent _ = pure () -- | This common execution function is used for all game user input except hard -- drop and pause. If paused or locked (from hard drop) do nothing, else -- execute the state computation. exec :: Tetris () -> EventM Name UI () -exec op = - guarded - (not . \ui -> ui ^. paused || ui ^. locked) - (game %~ execTetris op) - --- | This base execution function takes a predicate and only issues UI --- modification when predicate passes and game is not over. -guarded :: (UI -> Bool) -> (UI -> UI) -> EventM Name UI () -guarded p f = do - ui <- get - when (p ui && not (ui ^. game . to isGameOver)) $ - modify f - --- | Handles time steps, does nothing if game is over or paused -handleTick :: EventM Name UI () -handleTick = do - ui <- get - unless (ui ^. paused || ui ^. game . to isGameOver) $ do - -- awkward, should just mutate the inner state - --zoom game timeStep - g' <- execStateT timeStep $ ui ^. game - game .= g' - locked .= False +exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game -- | Restart game at the same level restart :: EventM Name UI () restart = do lvl <- use $ game . level g <- liftIO $ initGame lvl - game .= g - locked .= False + assign game g + assign locked False -- Drawing diff --git a/tetris.cabal b/tetris.cabal index 46ab498..0def627 100644 --- a/tetris.cabal +++ b/tetris.cabal @@ -19,6 +19,7 @@ library build-depends: base >= 4.7 && < 5 , brick , containers + , extra , lens , linear , mtl From 37eb8a514c93b1ae7f9e0ef849fcc89477afe2e4 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sat, 19 Oct 2024 18:42:39 -0400 Subject: [PATCH 03/10] Implement leveling --- src/Tetris.hs | 73 +++++++++++++++++++++++++++++--------------------- src/UI/Game.hs | 28 +++++++++++++------ tetris.cabal | 1 + 3 files changed, 63 insertions(+), 39 deletions(-) diff --git a/src/Tetris.hs b/src/Tetris.hs index 767bb88..4dfe45b 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -25,7 +25,7 @@ module Tetris , Tetrimino(..) , Tetris -- Lenses - , block, board, level, nextShape, score, shape + , block, board, level, nextShape, score, shape, linesCleared -- Constants , boardHeight, boardWidth, relCells ) where @@ -35,7 +35,7 @@ import Control.Applicative ((<|>)) import Control.Monad (forM_, mfilter, when, (<=<)) import Control.Monad.IO.Class (MonadIO(..), liftIO) -import Control.Monad.State.Class (MonadState, gets) +import Control.Monad.State.Class (MonadState, gets, put) import Control.Monad.Trans.State (evalStateT) import Data.Map (Map) import qualified Data.Map as M @@ -79,10 +79,10 @@ data Game = Game , _block :: Block , _nextShape :: Tetrimino , _nextShapeBag :: Seq.Seq Tetrimino - , _rowClears :: Seq.Seq Int + , _linesCleared :: Int , _score :: Int , _board :: Board - } deriving (Eq, Show) + } deriving (Eq) makeLenses ''Game evalTetris :: Tetris a -> Game -> a @@ -171,10 +171,23 @@ initGame lvl = do , _nextShape = s2 , _nextShapeBag = bag2 , _score = 0 - , _rowClears = mempty + , _linesCleared = 0 , _board = mempty } +-- | Increment level and reset the board +nextLevel :: (MonadIO m, MonadState Game m) => m () +nextLevel = do + -- Increment level + level %= (+ 1) + -- Reset board + (s1, bag1) <- liftIO $ bagFourTetriminoEach mempty + (s2, bag2) <- liftIO $ bagFourTetriminoEach bag1 + block .= initBlock s1 + nextShape .= s2 + nextShapeBag .= bag2 + board .= mempty + isGameOver :: Game -> Bool isGameOver g = blockStopped g && g ^. (block . origin) == startOrigin @@ -185,10 +198,10 @@ timeStep = do False -> gravitate True -> do freezeBlock - n <- clearFullRows - addToRowClears n - updateScore - nextBlock + clearFullRows >>= updateScore + levelFinished >>= \case + True -> nextLevel + False -> nextBlock -- | Gravitate current block, i.e. shift down gravitate :: MonadState Game m => m () @@ -205,36 +218,34 @@ clearFullRows = do -- Shift cells above full rows modifying board $ M.mapKeysMonotonic $ over _y $ \y -> y - length (filter (< y) fullRows) - return $ length fullRows + let clearedLines = length fullRows + linesCleared %= (+ clearedLines) + pure clearedLines --- | Empties row on 0, otherwise appends value (just keeps consecutive information) -addToRowClears :: MonadState Game m => Int -> m () -addToRowClears 0 = rowClears .= mempty -addToRowClears n = rowClears %= (|> n) - --- | This updates game points with respect to the current --- _rowClears value (thus should only be used ONCE per step) +-- | This updates game points with respect to the provided number of cleared +-- lines. -- --- Note I'm keeping rowClears as a sequence in case I want to award --- more points for back to back clears, right now the scoring is more simple, --- but you do get more points for more rows cleared at once. -updateScore :: MonadState Game m => m () -updateScore = do - multiplier <- (1 +) <$> use level - clears <- latestOrZero <$> use rowClears - let newPoints = multiplier * points clears +-- See https://tetris.fandom.com/wiki/Scoring +updateScore :: (MonadState Game m, MonadIO m) => Int -> m () +updateScore 0 = pure () +updateScore lines = do + lvl <- use level + let newPoints = (lvl + 1) * points lines score %= (+ newPoints) where - -- Translate row clears to points + -- Translate row line clears to points points 0 = 0 points 1 = 40 points 2 = 100 points 3 = 300 - points _ = 800 - -- | Get last value of sequence or 0 if empty - latestOrZero :: Seq.Seq Int -> Int - latestOrZero Empty = 0 - latestOrZero (_ :|> n) = n + points _ = 1200 + +-- | 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) -- | Handle counterclockwise block rotation (if possible) -- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation diff --git a/src/UI/Game.hs b/src/UI/Game.hs index 793a88c..358a2da 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -8,6 +8,7 @@ module UI.Game ) where import Control.Concurrent (threadDelay, forkIO) +import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, writeTVar, atomically) import Control.Monad (void, forever) import Prelude hiding (Left, Right) @@ -29,10 +30,12 @@ import Linear.V2 (V2(..)) import Tetris data UI = UI - { _game :: Game -- ^ tetris game - , _preview :: Maybe String -- ^ hard drop preview cell - , _locked :: Bool -- ^ lock after hard drop before time step - , _paused :: Bool -- ^ game paused + { _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 } makeLenses ''UI @@ -63,16 +66,20 @@ playGame -> Maybe String -- ^ Preview cell (Nothing == no preview) -> IO Game playGame lvl mp = do - let delay = levelToDelay lvl 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 - threadDelay delay + lvl <- readTVarIO tv + threadDelay $ levelToDelay lvl initialGame <- initGame lvl let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig initialVty <- buildVty ui <- customMain initialVty buildVty (Just chan) app $ UI { _game = initialGame + , _initLevel = lvl + , _currLevel = tv , _preview = mp , _locked = False , _paused = False @@ -106,6 +113,10 @@ handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) = handleEvent (AppEvent Tick ) = unlessM (orM [use paused, use (game . to isGameOver)]) $ do zoom game timeStep + -- Keep level in sync with ticker (gross) + lvl <- use $ game . level + tv <- use $ currLevel + liftIO . atomically $ writeTVar tv lvl assign locked False handleEvent _ = pure () @@ -115,10 +126,10 @@ handleEvent _ = pure () exec :: Tetris () -> EventM Name UI () exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game --- | Restart game at the same level +-- | Restart game at the initially chosen level restart :: EventM Name UI () restart = do - lvl <- use $ game . level + lvl <- use $ initLevel g <- liftIO $ initGame lvl assign game g assign locked False @@ -201,6 +212,7 @@ drawStats g = $ B.borderWithLabel (str "Stats") $ vBox [ drawStat "Score" $ g ^. score + , padTop (Pad 1) $ drawStat "Lines" $ g ^. linesCleared , padTop (Pad 1) $ drawStat "Level" $ g ^. level , drawLeaderBoard g ] diff --git a/tetris.cabal b/tetris.cabal index 0def627..c2221ba 100644 --- a/tetris.cabal +++ b/tetris.cabal @@ -24,6 +24,7 @@ library , linear , mtl , random + , stm , transformers , vty , vty-crossplatform From 772d59507a08addf5594b281c6e5676564737cea Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sat, 19 Oct 2024 19:41:53 -0400 Subject: [PATCH 04/10] Try new release workflow --- .github/workflows/release.yaml | 140 +++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 .github/workflows/release.yaml diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml new file mode 100644 index 0000000..6a9a37d --- /dev/null +++ b/.github/workflows/release.yaml @@ -0,0 +1,140 @@ +# This is copied from the stan project +# +# Note [environment variables] +# +# It seems absurd, but the syntax for creating environment variables +# differs between Windows and Linux/MacOS. See +# +# https://docs.github.com/en/actions/learn-github-actions/variables +# +# In Linux/MacOS we have to use +# +# run: echo "VARNAME=content" >> "$GITHUB_ENV" +# +# whereas in Windows we have to use +# +# run: echo "VARNAME=content" >> $env:GITHUB_ENV + +name: Release + +on: + # Trigger the workflow on the new 'v*' tag created + push: + tags: + - "v*" + +jobs: + create_release: + name: Create Github Release + runs-on: ubuntu-latest + steps: + - name: Check out code + uses: actions/checkout@v4 + + - name: Create Release + id: create_release + uses: actions/create-release@v1.1.4 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + tag_name: ${{ github.ref }} + release_name: Release ${{ github.ref }} + draft: true + prerelease: false + + - name: Output Release URL File + run: echo "${{ steps.create_release.outputs.upload_url }}" > release_url.txt + - name: Save Release URL File for publish + uses: actions/upload-artifact@v3 + with: + name: release_url + path: release_url.txt + + build_artifact: + needs: [create_release] + name: ${{ matrix.os }}/GHC ${{ matrix.ghc }}/${{ github.ref }} + runs-on: ${{ matrix.os }} + strategy: + fail-fast: true + matrix: + os: [ubuntu-latest, macOS-latest, windows-latest] + ghc: + - "9.6.3" + cabal: ["3.8"] + + steps: + - name: Check out code + uses: actions/checkout@v4 + + - name: Set tag name + uses: olegtarasov/get-tag@v2.1.2 + id: tag + with: + tagRegex: "v(.*)" + tagRegexGroup: 1 + + - name: Setup Haskell + uses: haskell/actions/setup@v2.4.7 + id: setup-haskell-cabal + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Freeze + run: | + cabal freeze + + - name: Cache ~/.cabal/store + uses: actions/cache@v4 + with: + path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + + - name: Build binary + run: | + mkdir dist + cabal install exe:tetris --install-method=copy --overwrite-policy=always --installdir=dist + + # See Note [environment variables] + - if: matrix.os == 'windows-latest' + name: Set binary path name on Windows + run: echo "BINARY_PATH=./dist/tetris.exe" >> $env:GITHUB_ENV + + # See Note [environment variables] + - if: matrix.os != 'windows-latest' + name: Set binary path name not on Windows + run: echo "BINARY_PATH=./dist/tetris" >> "$GITHUB_ENV" + + - name: Compress binary + uses: svenstaro/upx-action@2.3.0 + with: + file: ${{ env.BINARY_PATH }} + + - name: Load Release URL File from release job + uses: actions/download-artifact@v3 + with: + name: release_url + path: release_url + + # See Note [environment variables] + - if: matrix.os == 'windows-latest' + name: Get Release File Name & Upload URL on Widows + run: | + echo "upload_url=$(cat release_url/release_url.txt)" >> $env:GITHUB_ENV + + # See Note [environment variables] + - if: matrix.os != 'windows-latest' + name: Get Release File Name & Upload URL not on Widows + run: | + echo "upload_url=$(cat release_url/release_url.txt)" >> $GITHUB_ENV + + - name: Upload Release Asset + id: upload-release-asset + uses: actions/upload-release-asset@v1.0.2 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ env.upload_url }} + asset_path: ${{ env.BINARY_PATH }} + asset_name: tetris-${{ steps.tag.outputs.tag }}-${{ runner.os }} + asset_content_type: application/octet-stream From 05ee7b315a087a1a34b1e48b52baadb0081a2383 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sat, 19 Oct 2024 21:57:43 -0400 Subject: [PATCH 05/10] Fix mac release --- .github/workflows/release.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 6a9a37d..45a675c 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -105,7 +105,8 @@ jobs: name: Set binary path name not on Windows run: echo "BINARY_PATH=./dist/tetris" >> "$GITHUB_ENV" - - name: Compress binary + - if: matrix.os != 'macOS-latest' + name: Compress binary uses: svenstaro/upx-action@2.3.0 with: file: ${{ env.BINARY_PATH }} From d543d9253581b0c31928ebd417aec99221c46291 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sat, 19 Oct 2024 22:53:29 -0400 Subject: [PATCH 06/10] Get rid of ghc/cabal matrix --- .github/workflows/release.yaml | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 45a675c..97f0777 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -52,15 +52,12 @@ jobs: build_artifact: needs: [create_release] - name: ${{ matrix.os }}/GHC ${{ matrix.ghc }}/${{ github.ref }} + name: ${{ matrix.os }}/${{ github.ref }} runs-on: ${{ matrix.os }} strategy: fail-fast: true matrix: os: [ubuntu-latest, macOS-latest, windows-latest] - ghc: - - "9.6.3" - cabal: ["3.8"] steps: - name: Check out code @@ -77,8 +74,8 @@ jobs: uses: haskell/actions/setup@v2.4.7 id: setup-haskell-cabal with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} + ghc-version: "latest" + cabal-version: "latest" - name: Freeze run: | @@ -88,7 +85,7 @@ jobs: uses: actions/cache@v4 with: path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + key: ${{ runner.os }}-${{ hashFiles('cabal.project.freeze') }} - name: Build binary run: | From f16248734e829000b643d5dc68b8e87748576496 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sat, 19 Oct 2024 22:53:49 -0400 Subject: [PATCH 07/10] Update setup-haskell action --- .github/workflows/release.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 97f0777..510527d 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -71,7 +71,7 @@ jobs: tagRegexGroup: 1 - name: Setup Haskell - uses: haskell/actions/setup@v2.4.7 + uses: haskell-actions/setup@v2 id: setup-haskell-cabal with: ghc-version: "latest" From b0c7f6c55789b235da77bf78ca1fa301e4e09c12 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sun, 17 Nov 2024 13:58:35 -0500 Subject: [PATCH 08/10] Dont reset board on level up --- src/Tetris.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Tetris.hs b/src/Tetris.hs index 4dfe45b..0e4b031 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -175,18 +175,10 @@ initGame lvl = do , _board = mempty } --- | Increment level and reset the board +-- | Increment level nextLevel :: (MonadIO m, MonadState Game m) => m () nextLevel = do - -- Increment level level %= (+ 1) - -- Reset board - (s1, bag1) <- liftIO $ bagFourTetriminoEach mempty - (s2, bag2) <- liftIO $ bagFourTetriminoEach bag1 - block .= initBlock s1 - nextShape .= s2 - nextShapeBag .= bag2 - board .= mempty isGameOver :: Game -> Bool isGameOver g = blockStopped g && g ^. (block . origin) == startOrigin From f074add7a34ca603a3d13ef27d7ba8a0e4b1583b Mon Sep 17 00:00:00 2001 From: hello Date: Fri, 6 Dec 2024 15:32:32 +0530 Subject: [PATCH 09/10] Implemented toggling functionality for Level Acceleration Mode --- app/Main.hs | 12 +++--- src/Tetris.hs | 27 ++++++++----- src/UI/Game.hs | 80 ++++++++++++++++++++++----------------- src/UI/PickLevel.hs | 92 +++++++++++++++++++++++++++++++++++++++------ stack.yaml | 75 +++++++++++++++++++++++++++++++----- stack.yaml.lock | 9 +++-- tetris.cabal | 2 +- 7 files changed, 222 insertions(+), 75 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 39d9d59..efdf1db 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/src/Tetris.hs b/src/Tetris.hs index 0e4b031..51440e6 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -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 diff --git a/src/UI/Game.hs b/src/UI/Game.hs index 358a2da..db6825c 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -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" diff --git a/src/UI/PickLevel.hs b/src/UI/PickLevel.hs index 9101ddb..e94039d 100644 --- a/src/UI/PickLevel.hs +++ b/src/UI/PickLevel.hs @@ -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) diff --git a/stack.yaml b/stack.yaml index be59776..d8656a4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock index f8f2098..e542442 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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 diff --git a/tetris.cabal b/tetris.cabal index c2221ba..f8d27f4 100644 --- a/tetris.cabal +++ b/tetris.cabal @@ -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 From 725b7bdf9456707f7ff2da4afb60a7909151caa5 Mon Sep 17 00:00:00 2001 From: sherlock Date: Thu, 13 Mar 2025 12:21:05 +0530 Subject: [PATCH 10/10] move to forgejo --- src/UI/Game.hs | 9 ++++++--- src/UI/PickLevel.hs | 15 +++++++++++---- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/src/UI/Game.hs b/src/UI/Game.hs index db6825c..bd8e7d9 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -61,7 +61,10 @@ app = App , appAttrMap = const theMap } -playGame :: Int -> Maybe String -> Bool -> IO Game +playGame :: Int -- ^ Starting level + -> Maybe String -- ^ Preview cell (Nothing == no preview) + -> Bool -- ^ Enable level progression + -> IO Game playGame lvl mp prog = do chan <- newBChan 10 tv <- newTVarIO lvl @@ -218,10 +221,10 @@ drawStats g = drawProgression :: Bool -> Widget Name drawProgression True = padLeftRight 1 $ str "Level Mode: " <+> - withAttr progressionAttr (str "ON") + withAttr progressionAttr (padLeft Max $ str "ON") drawProgression False = padLeftRight 1 $ str "Level Mode: " <+> - withAttr fixedAttr (str "OFF") + withAttr fixedAttr (padLeft Max $ str "Fixed") drawStat :: String -> Int -> Widget Name drawStat s n = padLeftRight 1 $ str s <+> padLeft Max (str $ show n) diff --git a/src/UI/PickLevel.hs b/src/UI/PickLevel.hs index e94039d..bcbce47 100644 --- a/src/UI/PickLevel.hs +++ b/src/UI/PickLevel.hs @@ -59,11 +59,14 @@ ui ps = else vBox [ str "Level Progression?" , str "" - , drawOption "YES" YesOption (selectedOption ps) - , drawOption "NO" NoOption (selectedOption ps) + , C.hCenter $ drawOption "YES" YesOption (selectedOption ps) + , C.hCenter $ drawOption "NO" NoOption (selectedOption ps) , str "" - , str "Use ↑↓ to select" - , str "Press Enter to continue" + , C.hCenter $ str "Use ↑↓ or j/k" + , C.hCenter $ str "to Select." + , str "" + , C.hCenter $ str "Press Enter" + , C.hCenter $ str "to Continue." ] ] @@ -91,6 +94,10 @@ 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 (VtyEvent (V.EvKey (V.KChar 'j') [])) = + whenNotPickingLevel $ modify $ \s -> s { selectedOption = YesOption } +handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = + whenNotPickingLevel $ modify $ \s -> s { selectedOption = NoOption } handleEvent _ = pure () whenPickingLevel :: EventM () PickState () -> EventM () PickState ()