diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml new file mode 100644 index 0000000..510527d --- /dev/null +++ b/.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 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 cc04ee9..51440e6 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 @@ -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 -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 @@ -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 lvl = do +initGame :: Int -> Bool -> IO Game -- Updated signature +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 - addToRowClears n - updateScore + clearFullRows >>= updateScore + prog <- use progression + 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) -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) +-- | 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 :: Tetris () -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 + 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 diff --git a/src/UI/Game.hs b/src/UI/Game.hs index c4c5214..bd8e7d9 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,8 @@ 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.Concurrent.STM (TVar, newTVarIO, readTVarIO, writeTVar, atomically) +import Control.Monad (void, forever) 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 - , _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 @@ -55,24 +61,27 @@ app = App , appAttrMap = const theMap } -playGame - :: Int -- ^ Starting level - -> Maybe String -- ^ Preview cell (Nothing == no preview) - -> IO Game -playGame lvl mp = do - let delay = levelToDelay lvl +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 void . forkIO $ forever $ 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 - { _game = initialGame - , _preview = mp - , _locked = False - , _paused = False + 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 } 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 - (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 + -- 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 = - guarded - (not . \ui -> ui ^. paused || ui ^. locked) - (game %~ execTetris op) +exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game --- | 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 game at the initially chosen level restart :: EventM Name UI () restart = do - lvl <- use $ game . level - g <- liftIO $ initGame lvl - game .= g - locked .= False + 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 -- 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) - , (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 @@ -332,3 +338,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..bcbce47 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,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 - 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 (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 -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 906c2fd..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-20.1 -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 e067f78..e542442 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,8 @@ 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: 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 8520835..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 @@ -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