move to forgejo

.github/workflows/release.yaml

@@ -0,0 +1,138 @@
+# 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)
+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
+  (Opts hd ml hs) <- execParser fullopts
-  when hs (getHighScore >>= printM >> exitSuccess) -- show high score and exit
+  when hs (getHighScore >>= printM >> exitSuccess)
-  l <- maybe pickLevel return ml                   -- pick level prompt if necessary
+  levelConfig <- maybe pickLevel (\l -> return $ LevelConfig l False) ml
-  g <- playGame l (hdOptStr hd)                    -- play game
+  g <- playGame (levelNumber levelConfig) (hdOptStr hd) (progression levelConfig)
-  handleEndGame (_score g)                         -- save & print score
+  handleEndGame (_score g)
 
 handleEndGame :: Int -> IO ()
 handleEndGame s = do

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
@@ -25,7 +25,7 @@ module Tetris
   , Tetrimino(..)
   , Tetris
   -- Lenses
-  , block, board, level, nextShape, score, shape
+  , block, board, level, nextShape, score, shape, linesCleared, progression
   -- Constants
   , boardHeight, boardWidth, relCells
   ) where
@@ -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, put)
+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
@@ -77,20 +79,17 @@ data Game = Game
   , _block        :: Block
   , _nextShape    :: Tetrimino
   , _nextShapeBag :: Seq.Seq Tetrimino
-  , _rowClears    :: Seq.Seq Int
+  , _linesCleared :: Int
   , _score        :: Int
   , _board        :: Board
-  } deriving (Eq, Show)
+  , _progression  :: Bool
+  } deriving (Eq)
 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
+type Tetris a = forall m. MonadState Game m => m a
-execTetris m = runIdentity . execStateT m
 
 -- Translate class for direct translations, without concern for boundaries
 -- 'shift' concerns safe translations with boundaries
@@ -163,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 :: Int -> Bool -> IO Game  -- Updated signature
-initGame lvl = do
+initGame lvl prog = do
   (s1, bag1) <- bagFourTetriminoEach mempty
   (s2, bag2) <- bagFourTetriminoEach bag1
   pure $ Game
@@ -173,31 +172,40 @@ initGame lvl = do
     , _nextShape    = s2
     , _nextShapeBag = bag2
     , _score        = 0
-    , _rowClears    = mempty
+    , _linesCleared = 0
     , _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 => TetrisT m ()
+timeStep :: (MonadIO m, MonadState Game m) => m ()
 timeStep = do
   gets blockStopped >>= \case
     False -> gravitate
     True -> do
       freezeBlock
-      n <- clearFullRows
+      clearFullRows >>= updateScore
-      addToRowClears n
+      prog <- use progression
-      updateScore
+      when prog $ do
+        levelFinished >>= \case
+          True -> nextLevel
+          False -> pure ()
       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
@@ -207,40 +215,42 @@ 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)
+-- | This updates game points with respect to the provided number of cleared
-addToRowClears :: Int -> Tetris ()
+-- lines.
-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)
 --
--- Note I'm keeping rowClears as a sequence in case I want to award
+-- See https://tetris.fandom.com/wiki/Scoring
--- more points for back to back clears, right now the scoring is more simple,
+updateScore :: (MonadState Game m, MonadIO m) => Int -> m ()
--- but you do get more points for more rows cleared at once.
+updateScore 0 = pure ()
-updateScore :: Tetris ()
+updateScore lines = do
-updateScore = do
+  lvl <- use level
-  multiplier <- (1 +) <$> use level
+  let newPoints = (lvl + 1) * points lines
-  clears <- latestOrZero <$> use rowClears
-  let newPoints = multiplier * points clears
   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
+    points _ = 1200
-    -- | Get last value of sequence or 0 if empty
+
-    latestOrZero :: Seq.Seq Int -> Int
+-- | Using the fixed-goal system described here: https://tetris.wiki/Marathon
-    latestOrZero Empty     = 0
+levelFinished :: (MonadState Game m, MonadIO m) => m Bool
-    latestOrZero (_ :|> n) = n
+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)
 
 -- | 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 +274,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 +293,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 +308,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

src/UI/Game.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -7,9 +8,8 @@ module UI.Game
   ) where
 
 import Control.Concurrent (threadDelay, forkIO)
-import Control.Monad (void, forever, when, unless)
+import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, writeTVar, atomically)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad (void, forever)
-import Control.Monad.Trans.State (execStateT)
 import Prelude hiding (Left, Right)
 
 import Brick hiding (Down)
@@ -18,7 +18,11 @@ 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(..))
@@ -26,10 +30,12 @@ import Linear.V2 (V2(..))
 import Tetris
 
 data UI = UI
-  { _game    :: Game         -- ^ tetris game
+  { _game      :: Game
-  , _preview :: Maybe String -- ^ hard drop preview cell
+  , _initLevel :: Int
-  , _locked  :: Bool         -- ^ lock after hard drop before time step
+  , _currLevel :: TVar Int
-  , _paused  :: Bool         -- ^ game paused
+  , _preview   :: Maybe String
+  , _locked    :: Bool
+  , _paused    :: Bool
   }
 
 makeLenses ''UI
@@ -55,24 +61,27 @@ app = App
   , appAttrMap      = const theMap
   }
 
-playGame
+playGame :: Int          -- ^ Starting level
-  :: Int -- ^ Starting level
+          -> Maybe String  -- ^ Preview cell (Nothing == no preview)
-  -> Maybe String -- ^ Preview cell (Nothing == no preview)
+          -> Bool         -- ^ Enable level progression
-  -> IO Game
+          -> IO Game
-playGame lvl mp = do
+playGame lvl mp prog = do
-  let delay = levelToDelay lvl
   chan <- newBChan 10
+  tv <- newTVarIO lvl
   void . forkIO $ forever $ do
     writeBChan chan Tick
-    threadDelay delay
+    lvl <- readTVarIO tv
-  initialGame <- initGame lvl
+    threadDelay $ levelToDelay lvl
-  let builder = V.mkVty V.defaultConfig
+  initialGame <- initGame lvl prog  -- Pass the progression parameter
-  initialVty <- builder
+  let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig
-  ui <- customMain initialVty builder (Just chan) app $ UI
+  initialVty <- buildVty
-    { _game    = initialGame
+  ui <- customMain initialVty buildVty (Just chan) app $ UI
-    , _preview = mp
+    { _game      = initialGame
-    , _locked  = False
+    , _initLevel = lvl
-    , _paused  = False
+    , _currLevel = tv
+    , _preview   = mp
+    , _locked    = False
+    , _paused    = False
     }
   return $ ui ^. game
 
@@ -82,7 +91,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)
@@ -92,53 +103,36 @@ 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
+  unlessM (orM [use paused, use (game . to isGameOver)]) $ do
-    (not . view paused)
+    zoom game hardDrop
-    (over game (execTetris hardDrop) . set locked True)
+    assign locked True
 handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) =
-  guarded
+  unlessM (orM [use locked, use (game . to isGameOver)]) $ do
-    (not . view locked)
+    modifying paused not
-    (over paused not)
+handleEvent (AppEvent Tick                      ) =
-handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart
+  unlessM (orM [use paused, use (game . to isGameOver)]) $ do
-handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
+    zoom game timeStep
-handleEvent (VtyEvent (V.EvKey V.KEsc        [])) = halt
+    -- Keep level in sync with ticker (gross)
+    lvl <- use $ game . level
+    tv <- use $ currLevel
+    liftIO . atomically $ writeTVar tv lvl
+    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 =
+exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game
-  guarded
-    (not . \ui -> ui ^. paused || ui ^. locked)
-    (game %~ execTetris op)
 
--- | This base execution function takes a predicate and only issues UI
+-- | Restart game at the initially chosen level
--- 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 $ game . level
+  lvl <- use initLevel
-  g <- liftIO $ initGame lvl
+  prog <- use (game . progression)  -- Get current progression setting
-  game .= g
+  g <- liftIO $ initGame lvl prog   -- Use it when restarting
-  locked .= False
+  assign game g
+  assign locked False
 
 -- Drawing
 
@@ -218,10 +212,20 @@ 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)
 
@@ -283,21 +287,23 @@ drawGameOver g =
 theMap :: AttrMap
 theMap = attrMap
   V.defAttr
-  [ (iAttr       , tToColor I `on` tToColor I)
+  [ (iAttr          , tToColor I `on` tToColor I)
-  , (oAttr       , tToColor O `on` tToColor O)
+  , (oAttr          , tToColor O `on` tToColor O)
-  , (tAttr       , tToColor T `on` tToColor T)
+  , (tAttr          , tToColor T `on` tToColor T)
-  , (sAttr       , tToColor S `on` tToColor S)
+  , (sAttr          , tToColor S `on` tToColor S)
-  , (zAttr       , tToColor Z `on` tToColor Z)
+  , (zAttr          , tToColor Z `on` tToColor Z)
-  , (jAttr       , tToColor J `on` tToColor J)
+  , (jAttr          , tToColor J `on` tToColor J)
-  , (lAttr       , tToColor L `on` tToColor L)
+  , (lAttr          , tToColor L `on` tToColor L)
-  , (ihAttr      , fg $ tToColor I)
+  , (ihAttr         , fg $ tToColor I)
-  , (ohAttr      , fg $ tToColor O)
+  , (ohAttr         , fg $ tToColor O)
-  , (thAttr      , fg $ tToColor T)
+  , (thAttr         , fg $ tToColor T)
-  , (shAttr      , fg $ tToColor S)
+  , (shAttr         , fg $ tToColor S)
-  , (zhAttr      , fg $ tToColor Z)
+  , (zhAttr         , fg $ tToColor Z)
-  , (jhAttr      , fg $ tToColor J)
+  , (jhAttr         , fg $ tToColor J)
-  , (lhAttr      , fg $ tToColor L)
+  , (lhAttr         , fg $ tToColor L)
-  , (gameOverAttr, fg V.red `V.withStyle` V.bold)
+  , (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
@@ -332,3 +338,7 @@ emptyAttr = attrName "empty"
 
 gameOverAttr :: AttrName
 gameOverAttr = attrName "gameOver"
+
+progressionAttr, fixedAttr :: AttrName
+progressionAttr = attrName "progression"
+fixedAttr = attrName "fixed"

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 ()
+selectedAttr :: AttrName
-ui =
+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,69 @@ 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 ""
+          , 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."
+          ]
+    ]
 
-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
+  whenPickingLevel $ when (d `elem` ['0' .. '9']) $ do
-    put $ Just $ read [d]
+    modify $ \s -> s { currentLevel = Just $ read [d], pickingLevel = False }
-    halt
+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 }
 handleEvent _ = pure ()
 
-pickLevel :: IO Int
+whenPickingLevel :: EventM () PickState () -> EventM () PickState ()
-pickLevel = defaultMain app Nothing >>= maybe exitSuccess return
+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)

stack.yaml

@@ -1,10 +1,67 @@
-flags: {}
+# This file was automatically generated by 'stack init'
-extra-package-dbs: []
+#
+# 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: []
+# Dependency packages to be pulled from upstream that are not in the snapshot.
-resolver: lts-20.1
+# These entries can reference officially published versions as well as
-nix:
+# forks / in-progress versions pinned to a git hash. For example:
-  packages:
+#
-    - gcc
+# extra-deps:
-    - ncurses
+# - 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

stack.yaml.lock

@@ -6,7 +6,8 @@
 packages: []
 snapshots:
 - completed:
-    sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5
+    sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146
-    size: 648424
+    size: 720271
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml
-  original: lts-20.1
+  original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml

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
@@ -19,11 +19,15 @@ library
   build-depends:       base >= 4.7 && < 5
                      , brick
                      , containers
+                     , extra
                      , lens
                      , linear
+                     , mtl
                      , random
+                     , stm
                      , transformers
                      , vty
+                     , vty-crossplatform
   default-language:    Haskell2010
 
 executable tetris