diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml deleted file mode 100644 index 510527d..0000000 --- a/.github/workflows/release.yaml +++ /dev/null @@ -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 diff --git a/app/Main.hs b/app/Main.hs index efdf1db..39d9d59 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, 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 diff --git a/src/Tetris.hs b/src/Tetris.hs index 51440e6..cc04ee9 100644 --- a/src/Tetris.hs +++ b/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 diff --git a/src/UI/Game.hs b/src/UI/Game.hs index bd8e7d9..c4c5214 100644 --- a/src/UI/Game.hs +++ b/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" diff --git a/src/UI/PickLevel.hs b/src/UI/PickLevel.hs index bcbce47..9101ddb 100644 --- a/src/UI/PickLevel.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index d8656a4..906c2fd 100644 --- a/stack.yaml +++ b/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 diff --git a/stack.yaml.lock b/stack.yaml.lock index e542442..e067f78 100644 --- a/stack.yaml.lock +++ b/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 diff --git a/tetris.cabal b/tetris.cabal index f8d27f4..8520835 100644 --- a/tetris.cabal +++ b/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