diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,8 @@ module Main where -import qualified Command.Betris as Betris -import Control.Monad (join) -import Options.Applicative +import qualified Command.Betris as Betris +import Control.Monad (join) +import Options.Applicative main :: IO () main = join $ execParser $ info (helper <*> Betris.command) $ diff --git a/betris.cabal b/betris.cabal --- a/betris.cabal +++ b/betris.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack -- --- hash: 273304bd3d50cc8549848071abf1c6189bc8ce587d83c258ec2cc6943b51118b +-- hash: a590a5b99480bbc59bde069ff1bb894b267187f99bc037518a7a80a5659b918f name: betris -version: 0.2.2.0 +version: 0.2.3.0 synopsis: A horizontal version of tetris for braille users description: The game of tetris for braille display users, implemented using unicode braille rotated 90 degrees. Tetriminos are "falling" from right to left. category: Game @@ -39,15 +39,16 @@ ghc-options: -Wall build-depends: ansi-terminal - , base >=4.9.0 && <4.16 + , base >=4.9.0 && <5 , containers >=0.5.7 && <0.7 - , lens >=4.15.4 && <5.1 , linear >=1.20.7 && <1.22 - , optparse-applicative >=0.14.2 && <0.17 + , microlens + , microlens-th + , optparse-applicative >=0.14.2 && <0.18 , random >=1.1 && <1.3 , stm >=2.4.5 && <2.6 , time-units >=1.0.0 && <1.1 - , vty >=5.21 && <5.34 + , vty >=5.35 default-language: Haskell2010 executable betris @@ -59,14 +60,15 @@ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: ansi-terminal - , base >=4.9.0 && <4.16 + , base >=4.9.0 && <5 , betris , containers >=0.5.7 && <0.7 - , lens >=4.15.4 && <5.1 , linear >=1.20.7 && <1.22 - , optparse-applicative >=0.14.2 && <0.17 + , microlens + , microlens-th + , optparse-applicative >=0.14.2 && <0.18 , random >=1.1 && <1.3 , stm >=2.4.5 && <2.6 , time-units >=1.0.0 && <1.1 - , vty >=5.21 && <5.34 + , vty >=5.35 default-language: Haskell2010 diff --git a/src/Command/Betris.hs b/src/Command/Betris.hs --- a/src/Command/Betris.hs +++ b/src/Command/Betris.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Command.Betris (command, Options(..), betris) where -import Prelude hiding (Left, Right) -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.STM.TChan -import Control.Lens hiding (argument) -import Control.Monad (forever) -import Control.Monad.STM (atomically) -import Data.Char (chr) -import Data.IORef -import qualified Data.Map as Map -import Data.Time.Units -import Data.Version (showVersion) -import Game.Tetris -import Graphics.Vty.Config (userConfig) -import Graphics.Vty.Input hiding (Event) -import qualified Graphics.Vty.Input as Vty (Event) -import Linear.V2 (V2(..), _x) -import Paths_betris (version) -import Prelude hiding (Left, Right) -import Options.Applicative hiding (command, (<|>)) -import System.Console.ANSI -import System.IO (hFlush, stdout) +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM.TChan +import Control.Monad (forever) +import Control.Monad.STM (atomically) +import Data.Char (chr) +import Data.IORef +import qualified Data.Map as Map +import Data.Time.Units +import Data.Version (showVersion) +import Game.Tetris +import Graphics.Vty.Config (userConfig) +import Graphics.Vty.Input hiding (Event) +import qualified Graphics.Vty.Input as Vty (Event) +import Graphics.Vty.Input.Events (InternalEvent (InputEvent)) +import Lens.Micro ((^.)) +import Linear.V2 (V2 (..), _x) +import Options.Applicative hiding (command, (<|>)) +import Paths_betris (version) +import Prelude hiding (Left, Right) +import System.Console.ANSI +import System.IO (hFlush, stdout) command :: Parser (IO ()) command = betris <$> (versionOption <*> programOptions) @@ -44,8 +44,9 @@ game <- initGame 0 delay <- newIORef $ fromIntegral $ toMicroseconds initialDelay - _ <- forkIO . forever . atomically $ - readTChan (_eventChannel input) >>= writeTChan chan . Ev + _ <- forkIO . forever . atomically $ readTChan (_eventChannel input) >>= \case + InputEvent e -> writeTChan chan (Ev e) + _ -> pure () _ <- forkIO $ forever $ do readIORef delay >>= threadDelay modifyIORef delay (subtract 100) @@ -65,14 +66,14 @@ <> clearFromCursorToLineEndCode hFlush stdout atomically (readTChan chan) >>= \case - Tick -> play chan =<< timeStep tetris + Tick -> play chan =<< timeStep tetris Ev (EvKey (KChar ' ') []) -> play chan =<< timeStep tetris - Ev (EvKey KLeft []) -> play chan $ hardDrop tetris - Ev (EvKey KUp []) -> play chan $ Left `shift` tetris - Ev (EvKey KDown []) -> play chan $ Right `shift` tetris - Ev (EvKey KEnter []) -> play chan $ rotate tetris - Ev (EvKey KEsc []) -> pure tetris - _ -> play chan tetris + Ev (EvKey KLeft []) -> play chan $ hardDrop tetris + Ev (EvKey KUp []) -> play chan $ Left `shift` tetris + Ev (EvKey KDown []) -> play chan $ Right `shift` tetris + Ev (EvKey KEnter []) -> play chan $ rotate tetris + Ev (EvKey KEsc []) -> pure tetris + _ -> play chan tetris emboss :: Game -> String emboss game = map go [1, 3 .. boardHeight + 6] where @@ -81,7 +82,7 @@ ,((3,0),64),((3,1),128)] f y ((x',y'), v) a = case Map.lookup (V2 (x+x') (y+y')) fullBoard of Just _ -> a + v - _ -> a + _ -> a minx b = minimum $ (boardWidth - 3) : map (^. _x) (coords b) x = minx (game ^. block) fullBoard = game ^. board <> blk (game ^. block) <> blk next diff --git a/src/Game/Tetris.hs b/src/Game/Tetris.hs --- a/src/Game/Tetris.hs +++ b/src/Game/Tetris.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------- -- | -- Module : Game.Tetris @@ -21,18 +21,19 @@ , board, shape, origin, score, block, coords, nextShape, initBlock ) where -import Control.Lens hiding ((:<), (<|), (|>), (:>)) -import Data.Bool (bool) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Monoid (First(..)) -import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>), (><)) +import Data.Bool (bool) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Monoid (First (..)) +import Data.Sequence (ViewL (..), ViewR (..), (<|), (><), (|>)) import qualified Data.Sequence as Seq -import Linear.V2 (V2(..), _x, _y) -import qualified Linear.V2 as LV -import Prelude hiding (Left, Right) -import System.Random (getStdRandom, randomR) +import Lens.Micro hiding ((:<), (:>), (<|), (|>)) +import Lens.Micro.TH (makeLenses) +import Linear.V2 (V2 (..), _x, _y) +import qualified Linear.V2 as LV +import Prelude hiding (Left, Right) +import System.Random (getStdRandom, randomR) -- Types and instances @@ -142,7 +143,7 @@ bagFourTetriminoEach = go . Seq.viewl where go (t :< ts) = pure (t, ts) - go EmptyL = freshList >>= bagFourTetriminoEach + go EmptyL = freshList >>= bagFourTetriminoEach freshList = shuffle . Seq.fromList . take 28 . cycle $ [I ..] -- | Initialize a game with a given level @@ -206,7 +207,7 @@ -- | Get last value of sequence or 0 if empty latestOrZero :: Seq.Seq Int -> Int latestOrZero = go . Seq.viewr - where go EmptyR = 0 + where go EmptyR = 0 go (_ :> n) = n -- | Handle counterclockwise block rotation (if possible)