From c12bef50b3700553ec6f321765edfb1ff4f0a122 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sat, 17 Jun 2017 02:55:21 -0400 Subject: [PATCH] Finish level picker, start game interface --- app/Main.hs | 39 ++---------- src/UI/Game.hs | 147 ++++++++++++++++++++++++++++++++++++++++++++ src/UI/PickLevel.hs | 48 +++++++++++++++ tetris.cabal | 7 ++- 4 files changed, 205 insertions(+), 36 deletions(-) create mode 100644 src/UI/Game.hs create mode 100644 src/UI/PickLevel.hs diff --git a/app/Main.hs b/app/Main.hs index b6c401e..912b011 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,41 +1,14 @@ module Main where -import Control.Concurrent (threadDelay, forkIO) -import Control.Monad (void, forever) +import Tetris (Game) -import Tetris - -import Brick -import Brick.BChan -import qualified Graphics.Vty as V - --- | Ticks mark passing of time -data Tick = Tick - --- | Named resources -type Name = () - -app :: App Game Tick Name -app = undefined +import UI.PickLevel (pickLevel) +import UI.Game (playGame) +-- | TODO possibly allow a small number of CLI args, +-- like tetris --high-score main :: IO () -main = pickLevel >>= playGame - -pickLevel :: IO Int -pickLevel = undefined - -playGame :: Int -> IO () -playGame lvl = do - let delay = levelToDelay lvl - chan <- newBChan 10 - forkIO $ forever $ do - writeBChan chan Tick - threadDelay delay - initialGame <- initGame lvl - customMain (V.mkVty V.defaultConfig) (Just chan) app initialGame >>= handleEndGame - -levelToDelay :: Int -> Int -levelToDelay = undefined +main = pickLevel >>= playGame >>= handleEndGame -- | TODO possibly save high score (with 3 initials? kick it real old school?) to ~/.tetris handleEndGame :: Game -> IO () diff --git a/src/UI/Game.hs b/src/UI/Game.hs new file mode 100644 index 0000000..a0c3a2f --- /dev/null +++ b/src/UI/Game.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module UI.Game + ( playGame + ) where + +import Control.Concurrent (threadDelay, forkIO) +import Control.Monad (void, forever) +import Control.Monad.IO.Class (liftIO) +import Prelude hiding (Left, Right) + +import Tetris + +import Brick hiding (Down) +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 qualified Graphics.Vty as V +import Data.Map (Map) +import qualified Data.Map as M +import Lens.Micro + +-- | Ticks mark passing of time +data Tick = Tick + +-- | Named resources +type Name = () + +-- App definition and execution + +app :: App Game Tick Name +app = App { appDraw = drawUI + , appChooseCursor = neverShowCursor + , appHandleEvent = handleEvent + , appStartEvent = return + , appAttrMap = const theMap + } + +playGame :: Int -> IO Game +playGame lvl = do + let delay = levelToDelay lvl + chan <- newBChan 10 + forkIO $ forever $ do + writeBChan chan Tick + threadDelay delay + initialGame <- initGame lvl + customMain (V.mkVty V.defaultConfig) (Just chan) app initialGame + +levelToDelay :: Int -> Int +levelToDelay n = 1000000 -- floor $ fromIntegral $ 72500 * 0.85 ^ n + n + +-- Handling events + +handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) +handleEvent g (AppEvent Tick) = liftIO (timeStep g) >>= continue +handleEvent g (VtyEvent (V.EvKey V.KRight [])) = continue $ shift Right g +handleEvent g (VtyEvent (V.EvKey V.KLeft [])) = continue $ shift Left g +handleEvent g (VtyEvent (V.EvKey V.KDown [])) = continue $ shift Down g +handleEvent g (VtyEvent (V.EvKey V.KUp [])) = continue $ rotate g +handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g +handleEvent g (VtyEvent (V.EvKey V.KEsc [])) = halt g +handleEvent g _ = continue g + +-- Drawing + +drawUI :: Game -> [Widget Name] +drawUI g = + [ hBox + [ drawScore (g ^. score) + , drawGrid g + , drawNextShape (g ^. nextShape) + ] + ] + +drawGrid :: Game -> Widget Name +drawGrid g = withBorderStyle BS.unicodeBold + $ B.borderWithLabel (str "Tetris") + $ C.center + $ str $ show $ blkMap + -- $ foldr (<=>) emptyWidget rows + where + rows = [foldr (<+>) emptyWidget $ M.filterWithKey (inRow r) gmap + | r <- [boardHeight,boardHeight-1..1] + ] + inRow r (_,y) _ = r == y + gmap = drawMCell <$> mconcat [brdMap, blkMap, emptyMap] + brdMap = Just <$> g ^. board + blkMap = M.fromList [(c, Just $ g ^. block ^. shape) | c <- g ^. block ^. to coords] + +emptyMap :: Map Coord (Maybe a) +emptyMap = M.fromList [((x,y), Nothing) | x <- [1..boardWidth], y <- [1,boardHeight]] + +drawMCell :: Maybe Tetrimino -> Widget Name +drawMCell Nothing = withAttr emptyAttr cw +drawMCell (Just t) = drawCell t + +drawCell :: Tetrimino -> Widget Name +drawCell t = withAttr (tToAttr t) cw + where tToAttr I = iAttr + tToAttr O = oAttr + tToAttr T = tAttr + tToAttr S = sAttr + tToAttr Z = zAttr + tToAttr J = jAttr + tToAttr L = lAttr + +cw :: Widget Name +cw = str " " + +drawScore :: Int -> Widget Name +drawScore n = vBox [ C.vCenter $ str "Score" + , C.center $ str $ show n + ] + +drawNextShape :: Tetrimino -> Widget Name +-- TODO try vbox and see if different than foldr +drawNextShape t = padAll 1 + $ foldr (<=>) emptyWidget $ mkRow <$> [0,-1] + where + mkRow y = foldr (<+>) emptyWidget $ drawMCell . cellAt . (,y) <$> [-2..1] + cellAt (x,y) = if (x,y) `elem` cs then Just t else Nothing + blk = Block t (0,0) (relCells t) + cs = blk ^. to coords + +-- TODO test on mac terminal defAttr vs (bg black) +theMap = attrMap V.defAttr + [ (iAttr, bg V.cyan) + , (oAttr, bg V.yellow) + , (tAttr, bg V.magenta) + , (sAttr, bg V.green) + , (zAttr, bg V.red) + , (jAttr, bg V.blue) + , (lAttr, bg V.white) -- damn no orange in ANSI + ] + +iAttr, oAttr, tAttr, sAttr, zAttr, jAttr, lAttr :: AttrName +iAttr = "I" +oAttr = "O" +tAttr = "T" +sAttr = "S" +zAttr = "Z" +jAttr = "J" +lAttr = "L" + +emptyAttr :: AttrName +emptyAttr = "empty" diff --git a/src/UI/PickLevel.hs b/src/UI/PickLevel.hs new file mode 100644 index 0000000..95a2414 --- /dev/null +++ b/src/UI/PickLevel.hs @@ -0,0 +1,48 @@ +module UI.PickLevel + ( pickLevel + ) where + +import System.Exit (exitSuccess) + +import Tetris + +import Brick +import qualified Brick.Widgets.Border as B +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 () +app = App { appDraw = const [ui] + , appHandleEvent = handleEvent + , appStartEvent = return + , appAttrMap = const theMap + , appChooseCursor = neverShowCursor + } + +ui :: Widget () +ui = + C.center + $ hLimit 20 $ vLimit 30 + $ withBorderStyle BS.unicodeBold + $ B.borderWithLabel (str "Tetris") + $ C.center + $ str "Choose Level (0-9)" + +theMap :: AttrMap +theMap = attrMap V.defAttr [] + +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 + +pickLevel :: IO Int +pickLevel = + defaultMain app Nothing + >>= maybe exitSuccess return diff --git a/tetris.cabal b/tetris.cabal index 2ec27bd..5818776 100644 --- a/tetris.cabal +++ b/tetris.cabal @@ -16,22 +16,23 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Tetris + , UI.PickLevel + , UI.Game build-depends: base >= 4.7 && < 5 , brick , containers == 0.5.10.2 , microlens , microlens-th , random + , vty >= 5.15 default-language: Haskell2010 executable tetris hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base - , microlens + build-depends: base >= 4.7 && < 5 , tetris - , vty >= 5.15 default-language: Haskell2010 test-suite tetris-test