.github/workflows/release.yaml

@@ -1,138 +0,0 @@
-# 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 }}/${{ github.ref }}
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: true
-      matrix:
-        os: [ubuntu-latest, macOS-latest, windows-latest]
-
-    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
-        id: setup-haskell-cabal
-        with:
-          ghc-version: "latest"
-          cabal-version: "latest"
-
-      - 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 }}-${{ 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"
-
-      - if: matrix.os != 'macOS-latest'
-        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

app/Main.hs

@@ -9,7 +9,7 @@ import qualified System.Directory as D
 import System.FilePath ((</>))
 
 import Tetris (Game(..))
-import UI.PickLevel (pickLevel, LevelConfig(..))
+import UI.PickLevel (pickLevel)
 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
-  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)
+  (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
 
 handleEndGame :: Int -> IO ()
 handleEndGame s = do

src/Tetris.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
@@ -12,6 +11,7 @@ module Tetris
   , rotate
   , hardDrop
   -- Game state handlers
+  , execTetris
   , evalTetris
   -- Game state queries
   , isGameOver
@@ -25,7 +25,7 @@ module Tetris
   , Tetrimino(..)
   , Tetris
   -- Lenses
-  , block, board, level, nextShape, score, shape, linesCleared, progression
+  , block, board, level, nextShape, score, shape
   -- Constants
   , boardHeight, boardWidth, relCells
   ) where
@@ -33,10 +33,9 @@ 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.State.Class (MonadState, gets, put)
-import Control.Monad.Trans.State (evalStateT)
+
+import Control.Monad.Trans.State (StateT(..), gets, evalStateT, execStateT)
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Sequence (Seq(..), (><))
@@ -45,7 +44,6 @@ 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
@@ -79,17 +77,20 @@ data Game = Game
   , _block        :: Block
   , _nextShape    :: Tetrimino
   , _nextShapeBag :: Seq.Seq Tetrimino
-  , _linesCleared :: Int
+  , _rowClears    :: Seq.Seq Int
   , _score        :: Int
   , _board        :: Board
-  , _progression  :: Bool
-  } deriving (Eq)
+  } 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
 
-type Tetris a = forall m. MonadState Game m => m a
+execTetris :: Tetris a -> Game -> Game
+execTetris m = runIdentity . execStateT m
 
 -- Translate class for direct translations, without concern for boundaries
 -- 'shift' concerns safe translations with boundaries
@@ -162,8 +163,8 @@ bagFourTetriminoEach Empty =
   bagFourTetriminoEach <=< shuffle . Seq.fromList . take 28 $ cycle [I ..]
 
 -- | Initialize a game with a given level
-initGame :: Int -> Bool -> IO Game  -- Updated signature
-initGame lvl prog = do
+initGame :: Int -> IO Game
+initGame lvl = do
   (s1, bag1) <- bagFourTetriminoEach mempty
   (s2, bag2) <- bagFourTetriminoEach bag1
   pure $ Game
@@ -172,40 +173,31 @@ initGame lvl prog = do
     , _nextShape    = s2
     , _nextShapeBag = bag2
     , _score        = 0
-    , _linesCleared = 0
+    , _rowClears    = mempty
     , _board        = mempty
-    , _progression  = prog  -- Added prog parameter
     }
 
--- | Increment level
-nextLevel :: (MonadIO m, MonadState Game m) => m ()
-nextLevel = do
-  level %= (+ 1)
-
 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, MonadState Game m) => m ()
+timeStep :: MonadIO m => TetrisT m ()
 timeStep = do
   gets blockStopped >>= \case
     False -> gravitate
     True -> do
       freezeBlock
-      clearFullRows >>= updateScore
-      prog <- use progression
-      when prog $ do
-        levelFinished >>= \case
-          True -> nextLevel
-          False -> pure ()
+      n <- clearFullRows
+      addToRowClears n
+      updateScore
       nextBlock
 
 -- | Gravitate current block, i.e. shift down
-gravitate :: MonadState Game m => m ()
+gravitate :: Tetris ()
 gravitate = shift Down
 
 -- | If necessary: clear full rows and return the count
-clearFullRows :: MonadState Game m => m Int
+clearFullRows :: Tetris Int
 clearFullRows = do
   brd <- use board
   let rowSize r = length $ M.filterWithKey (\(V2 _ y) _ -> r == y) brd
@@ -215,42 +207,40 @@ clearFullRows = do
   -- Shift cells above full rows
   modifying board $ M.mapKeysMonotonic $ over _y $ \y ->
     y - length (filter (< y) fullRows)
-  let clearedLines = length fullRows
-  linesCleared %= (+ clearedLines)
-  pure clearedLines
+  return $ length fullRows
 
--- | This updates game points with respect to the provided number of cleared
--- lines.
+-- | Empties row on 0, otherwise appends value (just keeps consecutive information)
+addToRowClears :: Int -> Tetris ()
+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)
 --
--- 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
+-- 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 = do
+  multiplier <- (1 +) <$> use level
+  clears <- latestOrZero <$> use rowClears
+  let newPoints = multiplier * points clears
   score %= (+ newPoints)
   where
-    -- Translate row line clears to points
+    -- Translate row clears to points
     points 0 = 0
     points 1 = 40
     points 2 = 100
     points 3 = 300
-    points _ = 1200
-
--- | Using the fixed-goal system described here: https://tetris.wiki/Marathon
-levelFinished :: (MonadState Game m, MonadIO m) => m Bool
-levelFinished = do
-  prog <- use progression
-  if not prog
-    then pure False
-    else do
-      lvl <- use level
-      lc <- use linesCleared
-      pure $ lvl < 15 && lc >= 10 * (lvl + 1)
+    points _ = 800
+    -- | Get last value of sequence or 0 if empty
+    latestOrZero :: Seq.Seq Int -> Int
+    latestOrZero Empty     = 0
+    latestOrZero (_ :|> n) = n
 
 -- | Handle counterclockwise block rotation (if possible)
 -- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation
-rotate :: MonadState Game m => m ()
+rotate :: Tetris ()
 rotate = do
   blk <- use block
   brd <- use board
@@ -274,10 +264,10 @@ isStopped brd = any stopped . coords
   stopped = (||) <$> atBottom <*> (`M.member` brd) . translate Down
   atBottom = (== 1) . view _y
 
-hardDrop :: MonadState Game m => m ()
+hardDrop :: Tetris ()
 hardDrop = hardDroppedBlock >>= assign block
 
-hardDroppedBlock :: MonadState Game m => m Block
+hardDroppedBlock :: Tetris Block
 hardDroppedBlock = do
   boardCoords <- M.keys <$> use board
   blockCoords <- coords <$> use block
@@ -293,13 +283,13 @@ hardDroppedBlock = do
   translateBy dist Down <$> use block
 
 -- | Freeze current block
-freezeBlock :: MonadState Game m => m ()
+freezeBlock :: Tetris ()
 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, MonadState Game m) => m ()
+nextBlock :: MonadIO m => TetrisT m ()
 nextBlock = do
   bag <- use nextShapeBag
   (t, ts) <- liftIO $ bagFourTetriminoEach bag
@@ -308,7 +298,7 @@ nextBlock = do
   nextShapeBag .= ts
 
 -- | Try to shift current block; if shifting not possible, leave block where it is
-shift :: MonadState Game m => Direction -> m ()
+shift :: Direction -> Tetris ()
 shift dir = do
   brd <- use board
   blk <- use block

src/UI/Game.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -8,8 +7,9 @@ module UI.Game
   ) where
 
 import Control.Concurrent (threadDelay, forkIO)
-import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, writeTVar, atomically)
-import Control.Monad (void, forever)
+import Control.Monad (void, forever, when, unless)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.State (execStateT)
 import Prelude hiding (Left, Right)
 
 import Brick hiding (Down)
@@ -18,11 +18,7 @@ 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
 import Data.Map (Map)
 import qualified Data.Map as M
 import Linear.V2 (V2(..))
@@ -30,12 +26,10 @@ import Linear.V2 (V2(..))
 import Tetris
 
 data UI = UI
-  { _game      :: Game
-  , _initLevel :: Int
-  , _currLevel :: TVar Int
-  , _preview   :: Maybe String
-  , _locked    :: Bool
-  , _paused    :: Bool
+  { _game    :: Game         -- ^ tetris game
+  , _preview :: Maybe String -- ^ hard drop preview cell
+  , _locked  :: Bool         -- ^ lock after hard drop before time step
+  , _paused  :: Bool         -- ^ game paused
   }
 
 makeLenses ''UI
@@ -61,27 +55,24 @@ app = App
   , appAttrMap      = const theMap
   }
 
-playGame :: Int          -- ^ Starting level
-          -> Maybe String  -- ^ Preview cell (Nothing == no preview)
-          -> Bool         -- ^ Enable level progression
-          -> IO Game
-playGame lvl mp prog = do
+playGame
+  :: Int -- ^ Starting level
+  -> Maybe String -- ^ Preview cell (Nothing == no preview)
+  -> IO Game
+playGame lvl mp = do
+  let delay = levelToDelay lvl
   chan <- newBChan 10
-  tv <- newTVarIO lvl
   void . forkIO $ forever $ do
     writeBChan chan Tick
-    lvl <- readTVarIO tv
-    threadDelay $ levelToDelay 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
-    , _initLevel = lvl
-    , _currLevel = tv
-    , _preview   = mp
-    , _locked    = False
-    , _paused    = False
+    threadDelay delay
+  initialGame <- initGame lvl
+  let builder = V.mkVty V.defaultConfig
+  initialVty <- builder
+  ui <- customMain initialVty builder (Just chan) app $ UI
+    { _game    = initialGame
+    , _preview = mp
+    , _locked  = False
+    , _paused  = False
     }
   return $ ui ^. game
 
@@ -91,9 +82,7 @@ levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n)
 -- Handling events
 
 handleEvent :: BrickEvent Name Tick -> EventM Name UI ()
-handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart
-handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
-handleEvent (VtyEvent (V.EvKey V.KEsc        [])) = halt
+handleEvent (AppEvent Tick                      ) = handleTick
 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)
@@ -103,36 +92,53 @@ 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 ' ') [])) =
-  unlessM (orM [use paused, use (game . to isGameOver)]) $ do
-    zoom game hardDrop
-    assign locked True
+  guarded
+    (not . view paused)
+    (over game (execTetris hardDrop) . set locked True)
 handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) =
-  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
-    -- Keep level in sync with ticker (gross)
-    lvl <- use $ game . level
-    tv <- use $ currLevel
-    liftIO . atomically $ writeTVar tv lvl
-    assign locked False
+  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
 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 = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game
+exec op =
+  guarded
+    (not . \ui -> ui ^. paused || ui ^. locked)
+    (game %~ execTetris op)
 
--- | Restart game at the initially chosen level
+-- | 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
+
+-- | Restart game at the same level
 restart :: EventM Name UI ()
 restart = do
-  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
+  lvl <- use $ game . level
+  g <- liftIO $ initGame lvl
+  game .= g
+  locked .= False
 
 -- Drawing
 
@@ -212,20 +218,10 @@ 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
-        , padTop (Pad 1) $ drawProgression (g ^. progression)
         , drawLeaderBoard g
         ]
 
-drawProgression :: Bool -> Widget Name
-drawProgression True =
-    padLeftRight 1 $ str "Level Mode: " <+>
-    withAttr progressionAttr (padLeft Max $ str "ON")
-drawProgression False =
-    padLeftRight 1 $ str "Level Mode: " <+>
-    withAttr fixedAttr (padLeft Max $ str "Fixed")
-
 drawStat :: String -> Int -> Widget Name
 drawStat s n = padLeftRight 1 $ str s <+> padLeft Max (str $ show n)
 
@@ -287,23 +283,21 @@ 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)
-  , (progressionAttr, fg V.green `V.withStyle` V.bold)
-  , (fixedAttr      , fg V.blue `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)
   ]
 
 tToColor :: Tetrimino -> V.Color
@@ -338,7 +332,3 @@ emptyAttr = attrName "empty"
 
 gameOverAttr :: AttrName
 gameOverAttr = attrName "gameOver"
-
-progressionAttr, fixedAttr :: AttrName
-progressionAttr = attrName "progression"
-fixedAttr = attrName "fixed"

src/UI/PickLevel.hs

@@ -1,6 +1,5 @@
 module UI.PickLevel
   ( pickLevel
-  , LevelConfig(..)
   ) where
 
 import System.Exit (exitSuccess)
@@ -12,39 +11,17 @@ import qualified Brick.Widgets.Border.Style as BS
 import qualified Brick.Widgets.Center as C
 import qualified Graphics.Vty as V
 
-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 (Maybe Int) e ()
 app = App
-  { appDraw         = drawUI
+  { appDraw         = const [ui]
   , appHandleEvent  = handleEvent
   , appStartEvent   = pure ()
-  , appAttrMap      = const $ attrMap V.defAttr
-      [ (selectedAttr, V.black `on` V.white)
-      ]
+  , appAttrMap      = const $ attrMap V.defAttr []
   , appChooseCursor = neverShowCursor
   }
 
-selectedAttr :: AttrName
-selectedAttr = attrName "selected"
-
-drawUI :: PickState -> [Widget ()]
-drawUI ps = [ui ps]
-
-ui :: PickState -> Widget ()
-ui ps =
+ui :: Widget ()
+ui =
   padLeft (Pad 19)
     $ padRight (Pad 21)
     $ C.center
@@ -53,69 +30,17 @@ ui ps =
     $ withBorderStyle BS.unicodeBold
     $ B.borderWithLabel (str "Tetris")
     $ C.center
-    $ vBox
-    [ if pickingLevel ps
-        then str "Choose Level (0-9)"
-        else vBox
-          [ str "Level Progression?"
-          , str ""
-          , C.hCenter $ drawOption "YES" YesOption (selectedOption ps)
-          , C.hCenter $ drawOption "NO" NoOption (selectedOption ps)
-          , str ""
-          , C.hCenter $ str "Use ↑↓ or j/k"
-          , C.hCenter $ str "to Select."
-          , str ""
-          , C.hCenter $ str "Press Enter"
-          , C.hCenter $ str "to Continue."
-          ]
-    ]
+    $ str " Choose Level (0-9)"
 
-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 :: BrickEvent () e -> EventM () (Maybe Int) ()
 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) [])) =
-  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 (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 }
+  when (d `elem` ['0' .. '9']) $ do
+    put $ Just $ read [d]
+    halt
 handleEvent _ = pure ()
 
-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)
+pickLevel :: IO Int
+pickLevel = defaultMain app Nothing >>= maybe exitSuccess return

stack.yaml

@@ -1,67 +1,10 @@
-# 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
+flags: {}
+extra-package-dbs: []
 packages:
-- .
-# 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
+  - '.'
+extra-deps: []
+resolver: lts-20.1
+nix:
+  packages:
+    - gcc
+    - ncurses

stack.yaml.lock

@@ -6,8 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    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
+    sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5
+    size: 648424
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml
+  original: lts-20.1

tetris.cabal

@@ -1,5 +1,5 @@
 name:                tetris
-version:             0.1.6
+version:             0.1.5
 homepage:            https://github.com/samtay/tetris#readme
 license:             BSD3
 license-file:        LICENSE
@@ -19,15 +19,11 @@ library
   build-depends:       base >= 4.7 && < 5
                      , brick
                      , containers
-                     , extra
                      , lens
                      , linear
-                     , mtl
                      , random
-                     , stm
                      , transformers
                      , vty
-                     , vty-crossplatform
   default-language:    Haskell2010
 
 executable tetris