aadit/tetris-cli
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Update stack lts to 20.1

Browse source
This commit is contained in:
Sam Tay 2022-11-28 16:50:52 -08:00
parent e3605d48f3
commit e271067771
No known key found for this signature in database
6 changed files with 79 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
src/Tetris.hs
View file

@ -187,7 +187,8 @@ timeStep = do
False -> gravitate False -> gravitate
True -> do True -> do
freezeBlock freezeBlock
clearFullRows >>= addToRowClears n <- clearFullRows
addToRowClears n
updateScore updateScore
nextBlock nextBlock
@ -326,8 +327,9 @@ shuffle xs
| null xs = mempty | null xs = mempty
| otherwise = do | otherwise = do
randomPosition <- getStdRandom (randomR (0, length xs - 1)) randomPosition <- getStdRandom (randomR (0, length xs - 1))
let (left, y :<| ys) = Seq.splitAt randomPosition xs case Seq.splitAt randomPosition xs of
fmap (y <|) (shuffle $ left >< ys) (left, y :<| ys) -> fmap (y <|) (shuffle $ left >< ys)
_ -> error "impossible"
v2 :: (a, a) -> V2 a v2 :: (a, a) -> V2 a
v2 (x, y) = V2 x y v2 (x, y) = V2 x y

113
src/UI/Game.hs
View file

@ -7,8 +7,9 @@ module UI.Game
) where ) where
import Control.Concurrent (threadDelay, forkIO) 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.IO.Class (liftIO)
import Control.Monad.Trans.State (execStateT)
import Prelude hiding (Left, Right) import Prelude hiding (Left, Right)
import Brick hiding (Down) import Brick hiding (Down)
@ -16,8 +17,7 @@ import Brick.BChan
import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Border.Style as BS import qualified Brick.Widgets.Border.Style as BS
import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Center as C
import Control.Lens hiding (preview, op) import Control.Lens hiding (preview, op, zoom)
import Control.Monad.Trans.State
import qualified Graphics.Vty as V import qualified Graphics.Vty as V
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
@ -51,7 +51,7 @@ app = App
{ appDraw = drawUI { appDraw = drawUI
, appChooseCursor = neverShowCursor , appChooseCursor = neverShowCursor
, appHandleEvent = handleEvent , appHandleEvent = handleEvent
, appStartEvent = return , appStartEvent = pure ()
, appAttrMap = const theMap , appAttrMap = const theMap
} }
@ -81,35 +81,33 @@ levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n)
-- Handling events -- Handling events
handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI) handleEvent :: BrickEvent Name Tick -> EventM Name UI ()
handleEvent ui (AppEvent Tick ) = handleTick ui handleEvent (AppEvent Tick ) = handleTick
handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right) ui handleEvent (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right)
handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left) ui handleEvent (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left)
handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down) ui handleEvent (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down)
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right) ui handleEvent (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right)
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left) ui handleEvent (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left)
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down) ui handleEvent (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down)
handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = exec rotate ui handleEvent (VtyEvent (V.EvKey V.KUp [])) = exec rotate
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate ui handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate
handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) = handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) =
guarded guarded
(not . view paused) (not . view paused)
(over game (execTetris hardDrop) . set locked True) (over game (execTetris hardDrop) . set locked True)
ui handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) =
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'p') [])) =
guarded guarded
(not . view locked) (not . view locked)
(over paused not) (over paused not)
ui handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart ui handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt
handleEvent ui (VtyEvent (V.EvKey V.KEsc [])) = halt ui handleEvent _ = pure ()
handleEvent ui _ = continue ui
-- | This common execution function is used for all game user input except hard -- | 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 -- drop and pause. If paused or locked (from hard drop) do nothing, else
-- execute the state computation. -- execute the state computation.
exec :: Tetris () -> UI -> EventM Name (Next UI) exec :: Tetris () -> EventM Name UI ()
exec op = exec op =
guarded guarded
(not . \ui -> ui ^. paused || ui ^. locked) (not . \ui -> ui ^. paused || ui ^. locked)
@ -117,29 +115,30 @@ exec op =
-- | This base execution function takes a predicate and only issues UI -- | This base execution function takes a predicate and only issues UI
-- modification when predicate passes and game is not over. -- modification when predicate passes and game is not over.
guarded :: (UI -> Bool) -> (UI -> UI) -> UI -> EventM Name (Next UI) guarded :: (UI -> Bool) -> (UI -> UI) -> EventM Name UI ()
guarded p f ui = continue guarded p f = do
$ if not (p ui) || ui ^. game . to isGameOver ui <- get
then ui when (p ui && not (ui ^. game . to isGameOver)) $
else f ui modify f
-- | Handles time steps, does nothing if game is over or paused -- | Handles time steps, does nothing if game is over or paused
handleTick :: UI -> EventM Name (Next UI) handleTick :: EventM Name UI ()
handleTick ui = handleTick = do
if ui ^. paused || ui ^. game . to isGameOver ui <- get
then continue ui unless (ui ^. paused || ui ^. game . to isGameOver) $ do
else do -- awkward, should just mutate the inner state
next <- execStateT timeStep $ ui ^. game --zoom game timeStep
continue $ ui & game .~ next g' <- execStateT timeStep $ ui ^. game
& locked .~ False game .= g'
locked .= False
-- | Restart game at the same level -- | Restart game at the same level
restart :: UI -> EventM Name (Next UI) restart :: EventM Name UI ()
restart ui = do restart = do
let lvl = ui ^. (game . level) lvl <- use $ game . level
g <- liftIO $ initGame lvl g <- liftIO $ initGame lvl
continue $ ui & game .~ g game .= g
& locked .~ False locked .= False
-- Drawing -- Drawing
@ -311,25 +310,25 @@ tToColor J = V.blue
tToColor L = V.white tToColor L = V.white
iAttr, oAttr, tAttr, sAttr, zAttr, jAttr, lAttr :: AttrName iAttr, oAttr, tAttr, sAttr, zAttr, jAttr, lAttr :: AttrName
iAttr = "I" iAttr = attrName "I"
oAttr = "O" oAttr = attrName "O"
tAttr = "T" tAttr = attrName "T"
sAttr = "S" sAttr = attrName "S"
zAttr = "Z" zAttr = attrName "Z"
jAttr = "J" jAttr = attrName "J"
lAttr = "L" lAttr = attrName "L"
ihAttr, ohAttr, thAttr, shAttr, zhAttr, jhAttr, lhAttr :: AttrName ihAttr, ohAttr, thAttr, shAttr, zhAttr, jhAttr, lhAttr :: AttrName
ihAttr = "Ih" ihAttr = attrName "Ih"
ohAttr = "Oh" ohAttr = attrName "Oh"
thAttr = "Th" thAttr = attrName "Th"
shAttr = "Sh" shAttr = attrName "Sh"
zhAttr = "Zh" zhAttr = attrName "Zh"
jhAttr = "Jh" jhAttr = attrName "Jh"
lhAttr = "Lh" lhAttr = attrName "Lh"
emptyAttr :: AttrName emptyAttr :: AttrName
emptyAttr = "empty" emptyAttr = attrName "empty"
gameOverAttr :: AttrName gameOverAttr :: AttrName
gameOverAttr = "gameOver" gameOverAttr = attrName "gameOver"

21
src/UI/PickLevel.hs
View file

@ -3,6 +3,7 @@ module UI.PickLevel
) where ) where
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import Control.Monad (when)
import Brick import Brick
import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border as B
@ -14,7 +15,7 @@ app :: App (Maybe Int) e ()
app = App app = App
{ appDraw = const [ui] { appDraw = const [ui]
, appHandleEvent = handleEvent , appHandleEvent = handleEvent
, appStartEvent = return , appStartEvent = pure ()
, appAttrMap = const $ attrMap V.defAttr [] , appAttrMap = const $ attrMap V.defAttr []
, appChooseCursor = neverShowCursor , appChooseCursor = neverShowCursor
} }
@ -31,15 +32,15 @@ ui =
$ C.center $ C.center
$ str " Choose Level (0-9)" $ str " Choose Level (0-9)"
handleEvent :: Maybe Int -> BrickEvent () e -> EventM () (Next (Maybe Int)) handleEvent :: BrickEvent () e -> EventM () (Maybe Int) ()
handleEvent n (VtyEvent (V.EvKey V.KEsc _)) = halt n handleEvent (VtyEvent (V.EvKey V.KEsc _)) = halt
handleEvent n (VtyEvent (V.EvKey (V.KChar 'q') _)) = halt n handleEvent (VtyEvent (V.EvKey (V.KChar 'q') _)) = halt
handleEvent n (VtyEvent (V.EvKey (V.KChar 'Q') _)) = halt n handleEvent (VtyEvent (V.EvKey (V.KChar 'Q') _)) = halt
handleEvent n (VtyEvent (V.EvKey (V.KChar d) [])) = handleEvent (VtyEvent (V.EvKey (V.KChar d) [])) =
if d `elem` ['0' .. '9'] when (d `elem` ['0' .. '9']) $ do
then halt $ Just (read [d]) put $ Just $ read [d]
else continue n halt
handleEvent n _ = continue n handleEvent _ = pure ()
pickLevel :: IO Int pickLevel :: IO Int
pickLevel = defaultMain app Nothing >>= maybe exitSuccess return pickLevel = defaultMain app Nothing >>= maybe exitSuccess return

2
stack.yaml
View file

@ -3,7 +3,7 @@ extra-package-dbs: []
packages: packages:
- '.' - '.'
extra-deps: [] extra-deps: []
resolver: lts-17.9 resolver: lts-20.1
nix: nix:
packages: packages:
- gcc - gcc

8
stack.yaml.lock
View file

@ -6,7 +6,7 @@
packages: [] packages: []
snapshots: snapshots:
- completed: - completed:
size: 567037 sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/9.yaml size: 648424
sha256: d7d8d5106e53d1669964bd8bd2b0f88a5ad192d772f5376384b76738fd992311 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml
original: lts-17.9 original: lts-20.1

4
tetris.cabal
View file

@ -1,11 +1,11 @@
name: tetris name: tetris
version: 0.1.4.0 version: 0.1.4.1
homepage: https://github.com/samtay/tetris#readme homepage: https://github.com/samtay/tetris#readme
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Sam Tay author: Sam Tay
maintainer: sam.chong.tay@pm.me maintainer: sam.chong.tay@pm.me
copyright: 2021 Sam Tay copyright: 2022 Sam Tay
category: Web category: Web
build-type: Simple build-type: Simple
extra-source-files: README.md extra-source-files: README.md