diff --git a/app/Main.hs b/app/Main.hs index 39d9d59..60269db 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) -- show high score and exit + levelConfig <- maybe pickLevel (\l -> return $ LevelConfig l False) ml -- pick level prompt if necessary + g <- playGame (levelNumber levelConfig) (hdOptStr hd) (progression levelConfig) -- 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 0e4b031..493d219 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -25,7 +25,7 @@ module Tetris , Tetrimino(..) , Tetris -- Lenses - , block, board, level, nextShape, score, shape, linesCleared + , block, board, level, nextShape, score, shape, linesCleared, progression -- Constants , boardHeight, boardWidth, relCells ) where @@ -82,6 +82,7 @@ data Game = Game , _linesCleared :: Int , _score :: Int , _board :: Board + , _progression :: Bool } deriving (Eq) makeLenses ''Game @@ -161,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 +initGame lvl prog = do (s1, bag1) <- bagFourTetriminoEach mempty (s2, bag2) <- bagFourTetriminoEach bag1 pure $ Game @@ -173,6 +174,7 @@ initGame lvl = do , _score = 0 , _linesCleared = 0 , _board = mempty + , _progression = prog } -- | Increment level @@ -191,9 +193,12 @@ timeStep = do True -> do freezeBlock clearFullRows >>= updateScore - levelFinished >>= \case - True -> nextLevel - False -> nextBlock + prog <- use progression + when prog $ do + levelFinished >>= \case + True -> nextLevel + False -> pure () + nextBlock -- | Gravitate current block, i.e. shift down gravitate :: MonadState Game m => m () @@ -235,9 +240,13 @@ updateScore lines = do -- | Using the fixed-goal system described here: https://tetris.wiki/Marathon levelFinished :: (MonadState Game m, MonadIO m) => m Bool levelFinished = do - lvl <- use level - lc <- use linesCleared - pure $ lvl < 15 && lc >= 10 * (lvl + 1) + 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 diff --git a/src/UI/Game.hs b/src/UI/Game.hs index 358a2da..5f2588d 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -30,12 +30,12 @@ import Linear.V2 (V2(..)) import Tetris data UI = UI - { _game :: Game -- ^ tetris game - , _initLevel :: Int -- ^ initial level chosen - , _currLevel :: TVar Int -- ^ current level - , _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 @@ -61,28 +61,27 @@ app = App , appAttrMap = const theMap } -playGame - :: Int -- ^ Starting level - -> Maybe String -- ^ Preview cell (Nothing == no preview) - -> IO Game -playGame lvl mp = do - chan <- newBChan 10 - -- share the current level with the thread so it can adjust speed +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 -- share the current level with the thread so it can adjust speed tv <- newTVarIO lvl void . forkIO $ forever $ do writeBChan chan Tick lvl <- readTVarIO tv threadDelay $ levelToDelay lvl - initialGame <- initGame 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 + { _game = initialGame , _initLevel = lvl , _currLevel = tv - , _preview = mp - , _locked = False - , _paused = False + , _preview = mp + , _locked = False + , _paused = False } return $ ui ^. game @@ -129,8 +128,9 @@ exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom -- | Restart game at the initially chosen level restart :: EventM Name UI () restart = do - lvl <- use $ initLevel - g <- liftIO $ initGame lvl + 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 @@ -214,9 +214,18 @@ drawStats g = [ 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) @@ -278,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 @@ -327,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." + ] + ] + +drawOption :: String -> MenuOption -> MenuOption -> Widget () +drawOption label opt current = + withAttr (if opt == current then selectedAttr else attrName "") + $ str $ " " ++ label ++ " " -handleEvent :: BrickEvent () e -> EventM () (Maybe Int) () +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/tetris.cabal b/tetris.cabal index c2221ba..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