diff --git a/src/Tetris.hs b/src/Tetris.hs index cf84d37..cc04ee9 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -187,7 +187,8 @@ timeStep = do False -> gravitate True -> do freezeBlock - clearFullRows >>= addToRowClears + n <- clearFullRows + addToRowClears n updateScore nextBlock @@ -326,8 +327,9 @@ shuffle xs | null xs = mempty | otherwise = do randomPosition <- getStdRandom (randomR (0, length xs - 1)) - let (left, y :<| ys) = Seq.splitAt randomPosition xs - fmap (y <|) (shuffle $ left >< ys) + case Seq.splitAt randomPosition xs of + (left, y :<| ys) -> fmap (y <|) (shuffle $ left >< ys) + _ -> error "impossible" v2 :: (a, a) -> V2 a v2 (x, y) = V2 x y diff --git a/src/UI/Game.hs b/src/UI/Game.hs index c7cff94..c4c5214 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -7,8 +7,9 @@ module UI.Game ) where import Control.Concurrent (threadDelay, forkIO) -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) @@ -16,8 +17,7 @@ import Brick.BChan 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) -import Control.Monad.Trans.State +import Control.Lens hiding (preview, op, zoom) import qualified Graphics.Vty as V import Data.Map (Map) import qualified Data.Map as M @@ -51,7 +51,7 @@ app = App { appDraw = drawUI , appChooseCursor = neverShowCursor , appHandleEvent = handleEvent - , appStartEvent = return + , appStartEvent = pure () , appAttrMap = const theMap } @@ -81,35 +81,33 @@ levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n) -- Handling events -handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI) -handleEvent ui (AppEvent Tick ) = handleTick ui -handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right) ui -handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left) ui -handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down) ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right) ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left) ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down) ui -handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = exec rotate ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) = +handleEvent :: BrickEvent Name Tick -> EventM Name UI () +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) +handleEvent (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right) +handleEvent (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left) +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) - ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar 'p') [])) = +handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) = guarded (not . view locked) (over paused not) - ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart ui -handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui -handleEvent ui (VtyEvent (V.EvKey V.KEsc [])) = halt ui -handleEvent ui _ = continue 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 _ = 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 () -> UI -> EventM Name (Next UI) +exec :: Tetris () -> EventM Name UI () exec op = guarded (not . \ui -> ui ^. paused || ui ^. locked) @@ -117,29 +115,30 @@ exec op = -- | This base execution function takes a predicate and only issues UI -- modification when predicate passes and game is not over. -guarded :: (UI -> Bool) -> (UI -> UI) -> UI -> EventM Name (Next UI) -guarded p f ui = continue - $ if not (p ui) || ui ^. game . to isGameOver - then ui - else f ui +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 :: UI -> EventM Name (Next UI) -handleTick ui = - if ui ^. paused || ui ^. game . to isGameOver - then continue ui - else do - next <- execStateT timeStep $ ui ^. game - continue $ ui & game .~ next - & locked .~ False +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 :: UI -> EventM Name (Next UI) -restart ui = do - let lvl = ui ^. (game . level) +restart :: EventM Name UI () +restart = do + lvl <- use $ game . level g <- liftIO $ initGame lvl - continue $ ui & game .~ g - & locked .~ False + game .= g + locked .= False -- Drawing @@ -311,25 +310,25 @@ tToColor J = V.blue tToColor L = V.white iAttr, oAttr, tAttr, sAttr, zAttr, jAttr, lAttr :: AttrName -iAttr = "I" -oAttr = "O" -tAttr = "T" -sAttr = "S" -zAttr = "Z" -jAttr = "J" -lAttr = "L" +iAttr = attrName "I" +oAttr = attrName "O" +tAttr = attrName "T" +sAttr = attrName "S" +zAttr = attrName "Z" +jAttr = attrName "J" +lAttr = attrName "L" ihAttr, ohAttr, thAttr, shAttr, zhAttr, jhAttr, lhAttr :: AttrName -ihAttr = "Ih" -ohAttr = "Oh" -thAttr = "Th" -shAttr = "Sh" -zhAttr = "Zh" -jhAttr = "Jh" -lhAttr = "Lh" +ihAttr = attrName "Ih" +ohAttr = attrName "Oh" +thAttr = attrName "Th" +shAttr = attrName "Sh" +zhAttr = attrName "Zh" +jhAttr = attrName "Jh" +lhAttr = attrName "Lh" emptyAttr :: AttrName -emptyAttr = "empty" +emptyAttr = attrName "empty" gameOverAttr :: AttrName -gameOverAttr = "gameOver" +gameOverAttr = attrName "gameOver" diff --git a/src/UI/PickLevel.hs b/src/UI/PickLevel.hs index 378bb6d..9101ddb 100644 --- a/src/UI/PickLevel.hs +++ b/src/UI/PickLevel.hs @@ -3,6 +3,7 @@ module UI.PickLevel ) where import System.Exit (exitSuccess) +import Control.Monad (when) import Brick import qualified Brick.Widgets.Border as B @@ -14,7 +15,7 @@ app :: App (Maybe Int) e () app = App { appDraw = const [ui] , appHandleEvent = handleEvent - , appStartEvent = return + , appStartEvent = pure () , appAttrMap = const $ attrMap V.defAttr [] , appChooseCursor = neverShowCursor } @@ -31,15 +32,15 @@ ui = $ C.center $ str " Choose Level (0-9)" -handleEvent :: Maybe Int -> BrickEvent () e -> EventM () (Next (Maybe Int)) -handleEvent n (VtyEvent (V.EvKey V.KEsc _)) = halt n -handleEvent n (VtyEvent (V.EvKey (V.KChar 'q') _)) = halt n -handleEvent n (VtyEvent (V.EvKey (V.KChar 'Q') _)) = halt n -handleEvent n (VtyEvent (V.EvKey (V.KChar d) [])) = - if d `elem` ['0' .. '9'] - then halt $ Just (read [d]) - else continue n -handleEvent n _ = continue n +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) [])) = + when (d `elem` ['0' .. '9']) $ do + put $ Just $ read [d] + halt +handleEvent _ = pure () pickLevel :: IO Int pickLevel = defaultMain app Nothing >>= maybe exitSuccess return diff --git a/stack.yaml b/stack.yaml index 945f1e2..906c2fd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,7 @@ extra-package-dbs: [] packages: - '.' extra-deps: [] -resolver: lts-17.9 +resolver: lts-20.1 nix: packages: - gcc diff --git a/stack.yaml.lock b/stack.yaml.lock index 348de92..e067f78 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 567037 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/9.yaml - sha256: d7d8d5106e53d1669964bd8bd2b0f88a5ad192d772f5376384b76738fd992311 - original: lts-17.9 + 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 bc8a87a..db9e7d9 100644 --- a/tetris.cabal +++ b/tetris.cabal @@ -1,11 +1,11 @@ name: tetris -version: 0.1.4.0 +version: 0.1.4.1 homepage: https://github.com/samtay/tetris#readme license: BSD3 license-file: LICENSE author: Sam Tay maintainer: sam.chong.tay@pm.me -copyright: 2021 Sam Tay +copyright: 2022 Sam Tay category: Web build-type: Simple extra-source-files: README.md