diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Mario Lang (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# betris + +A vertical version of tetris for braille display users. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +module Main where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM.TBChan +import Control.Lens +import Control.Monad (forever) +import Control.Monad.STM (atomically) +import Data.Char (chr) +import Data.Foldable (for_) +import qualified Data.Map as Map +import Data.Semigroup ((<>)) +import Game.Tetris +import Graphics.Vty +import Linear.V2 (V2(..)) +import Prelude hiding (Left, Right) + +data Event e = Tick | Ev e deriving (Eq, Read, Show, Functor) + +main = do + vty <- mkVty defaultConfig + chan <- atomically $ newTBChan 10 + game <- initGame 0 + + forkIO $ forever $ do + e <- nextEvent vty + atomically $ writeTBChan chan $ Ev e + + forkIO $ forever $ do + threadDelay 1000000 + atomically $ writeTBChan chan Tick + + consume vty chan game + + shutdown vty + +consume vty chan game = if isGameOver game then pure () else do + update vty $ picForImage $ string defAttr (gstr game) <|> string defAttr (show $ game ^. score) + e <- atomically $ readTBChan chan + case e of + Ev (EvKey KEsc []) -> return () + Tick -> timeStep game >>= consume vty chan + Ev (EvKey KLeft []) -> consume vty chan (hardDrop game) + Ev (EvKey KUp []) -> consume vty chan (shift Left game) + Ev (EvKey KDown []) -> consume vty chan (shift Right game) + Ev (EvKey KEnter []) -> consume vty chan (rotate game) + _ -> do + consume vty chan game + +gstr :: Game -> String +gstr g = map go [1, 3 .. boardHeight] where + go y = chr $ foldr (f' y) 0x2800 [((0,0), 1), ((1,0), 2), ((2,0), 4), ((0,1), 8), ((1,1),16), ((2,1),32), ((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 + x = minimum $ (boardWidth - 3) : map (\(V2 x _) -> x) (coords $ g ^. block) + fullBoard = g ^. board <> blk (g ^. block) + blk b = Map.fromList $ map (, b ^. shape) $ coords b diff --git a/betris.cabal b/betris.cabal new file mode 100644 --- /dev/null +++ b/betris.cabal @@ -0,0 +1,64 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f9ba6b4b5ef2e7b1d45d1ccacf5b650ca1fe2cfb20437e37390d9582602a661a + +name: betris +version: 0.1.0.0 +synopsis: Braille friendly vertical version of tetris +description: Please see the README on Github at +category: Game +homepage: https://github.com/mlang/betris#readme +bug-reports: https://github.com/mlang/betris/issues +author: Mario Lang +maintainer: mlang@blind.guru +copyright: 2018 Mario Lang +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/mlang/betris + +library + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers + , lens + , linear + , random + , stm + , stm-chans + , vty + exposed-modules: + Game.Tetris + other-modules: + Paths_betris + default-language: Haskell2010 + +executable betris-exe + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , betris + , containers + , lens + , linear + , random + , stm + , stm-chans + , vty + other-modules: + Paths_betris + default-language: Haskell2010 diff --git a/src/Game/Tetris.hs b/src/Game/Tetris.hs new file mode 100644 --- /dev/null +++ b/src/Game/Tetris.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +------------------------------------------------------------------------------- +-- | +-- Module : Game.Tetris +-- Copyright : (c) 2017 Samuel Tay +-- License : BSD-style (see LICENSE) +-- Maintainer : Mario Lang +-- +-- A library implementation of Tetris. +-- +-- This module has been taken from https://github.com/SamTay/tetris +-- +module Game.Tetris +( Game +, Direction(..) +, boardWidth, boardHeight +, initGame, isGameOver +, timeStep, rotate, shift, hardDrop +, board, shape, score, block, coords +) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>), (><)) +import qualified Data.Sequence as Seq +import Control.Lens hiding ((:<), (<|), (|>), (:>)) +import Linear.V2 (V2(..), _x, _y) +import qualified Linear.V2 as LV +import System.Random (getStdRandom, randomR) + +import Prelude hiding (Left, Right) +import Data.Bool (bool) +import Data.Maybe (fromMaybe) +import Data.Monoid (First(..)) + +-- Types and instances + +-- | Tetris shape types +data Tetrimino = I | O | T | S | Z | J | L + deriving (Eq, Show, Enum) + +-- | Coordinates +type Coord = V2 Int + +-- | Tetris shape in location context +data Block = Block + { _shape :: Tetrimino -- ^ block type + , _origin :: Coord -- ^ origin + , _extra :: [Coord] -- ^ extraneous cells + } deriving (Eq, Show) + +makeLenses ''Block + +data Direction = Left | Right | Down + deriving (Eq, Show) + +-- | Board +-- +-- If coordinate not present in map, yet in bounds, then it is empty, +-- otherwise its value is the type of tetrimino occupying it. +type Board = Map Coord Tetrimino + +-- | Game state +data Game = Game + { _level :: Int + , _block :: Block + , _nextShape :: Tetrimino + , _nextShapeBag :: Seq.Seq Tetrimino + , _rowClears :: Seq.Seq Int + , _score :: Int + , _board :: Board + } deriving (Eq, Show) + +makeLenses ''Game + +-- Translate class for direct translations, without concern for boundaries +-- 'shift' concerns safe translations with boundaries +class Translatable s where + translate :: Direction -> s -> s + translate = translateBy 1 + translateBy :: Int -> Direction -> s -> s + +instance Translatable Coord where + translateBy n Left (V2 x y) = V2 (x-n) y + translateBy n Right (V2 x y) = V2 (x+n) y + translateBy n Down (V2 x y) = V2 x (y-n) + +instance Translatable Block where + translateBy n d b = + b & origin %~ translateBy n d + & extra %~ fmap (translateBy n d) + +-- Low level functions on blocks and coordinates + +initBlock :: Tetrimino -> Block +initBlock t = Block t startOrigin . fmap (+ startOrigin) . relCells $ t + +relCells :: Tetrimino -> [Coord] +relCells I = map v2 [(-2,0), (-1,0), (1,0)] +relCells O = map v2 [(-1,0), (-1,-1), (0,-1)] +relCells S = map v2 [(-1,-1), (0,-1), (1,0)] +relCells Z = map v2 [(-1,0), (0,-1), (1,-1)] +relCells L = map v2 [(-1,-1), (-1,0), (1,0)] +relCells J = map v2 [(-1,0), (1,0), (1,-1)] +relCells T = map v2 [(-1,0), (0,-1), (1,0)] + +-- | Visible, active board size +boardWidth, boardHeight :: Int +boardWidth = 10 +boardHeight = 20 + +-- | Starting block origin +startOrigin :: Coord +startOrigin = V2 6 22 + +-- | Rotate block counter clockwise about origin +-- *Note*: Strict unsafe rotation not respecting boundaries +-- Safety can only be assured within Game context +rotate' :: Block -> Block +rotate' b@(Block s o@(V2 xo yo) cs) + | s == O = b -- O doesn't need rotation + | s == I && V2 xo (yo+1) `elem` cs = rotateWith clockwise -- I only has two orientations + | otherwise = rotateWith counterclockwise + where + rotateWith :: (Coord -> Coord) -> Block + rotateWith dir = b & extra %~ fmap dir + clockwise = (+ o) . (cwperp) . (subtract o) + counterclockwise = (+ o) . LV.perp . (subtract o) + cwperp (V2 x y) = V2 y (-x) + +-- | Get coordinates of entire block +coords :: Block -> [Coord] +coords b = b ^. origin : b ^. extra + +-- Higher level functions on game and board + +-- | Facilitates cycling through at least 4 occurences of each shape +-- before next bag (random permutation of 4*each tetrimino) is created. If input is empty, +-- generates new bag, otherwise just unshifts the first value and returns pair. +bagFourTetriminoEach :: Seq.Seq Tetrimino -> IO (Tetrimino, Seq.Seq Tetrimino) +bagFourTetriminoEach = go . Seq.viewl + where + go (t :< ts) = pure (t, ts) + go EmptyL = freshList >>= bagFourTetriminoEach + freshList = shuffle . Seq.fromList . take 28 . cycle $ [(I)..] + +-- | Initialize a game with a given level +initGame :: Int -> IO Game +initGame lvl = do + (s1, bag1) <- bagFourTetriminoEach mempty + (s2, bag2) <- bagFourTetriminoEach bag1 + pure $ + Game { _level = lvl + , _block = initBlock s1 + , _nextShape = s2 + , _nextShapeBag = bag2 + , _score = 0 + , _rowClears = mempty + , _board = mempty } + +isGameOver :: Game -> Bool +isGameOver g = blockStopped g && g ^. block ^. origin == startOrigin + +timeStep :: Game -> IO Game +timeStep g = + if blockStopped g + then nextBlock . updateScore . clearFullRows . freezeBlock $ g + else pure . gravitate $ g + +-- TODO check if mapKeysMonotonic works +clearFullRows :: Game -> Game +clearFullRows g = g & board %~ clearBoard + & rowClears %~ (addToRowClears rowCount) + where + clearBoard = M.mapKeys shiftCoordAbove . M.filterWithKey notInFullRow + notInFullRow (V2 _ y) _ = y `notElem` fullRowIndices + rowCount = length fullRowIndices + fullRowIndices = filter isFullRow [1..boardHeight] + isFullRow r = boardWidth == (length . M.filterWithKey (inRow r) $ g ^. board) + inRow r (V2 _ y) _ = r == y + shiftCoordAbove (V2 x y) = + let offset = length . filter (< y) $ fullRowIndices + in V2 x (y - offset) + +-- | This updates game points with respect to the current +-- _rowClears value (thus should only be used ONCE per step) +-- +-- Note I'm keeping rowClears as a sequence in case I want to award +-- more points for back to back clears, right now the scoring is more simple +updateScore :: Game -> Game +updateScore g = g & score %~ (+ newPoints) + where + newPoints = (1 + g ^. level) * (g ^. rowClears ^. to latestOrZero ^. to points) + points 0 = 0 + points 1 = 40 + points 2 = 100 + points 3 = 300 + points n = 800 + +-- | Empties row on 0, otherwise appends value (just keeps consecutive information) +addToRowClears :: Int -> Seq.Seq Int -> Seq.Seq Int +addToRowClears 0 _ = mempty +addToRowClears n rs = rs |> n + +-- | Get last value of sequence or 0 if empty +latestOrZero :: Seq.Seq Int -> Int +latestOrZero = go . Seq.viewr + where go EmptyR = 0 + go (_ :> n) = n + +-- | Handle counterclockwise block rotation (if possible) +-- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation +rotate :: Game -> Game +rotate g = g & block .~ nextB + where nextB = fromMaybe blk $ getFirst . mconcat $ First <$> bs + bs = map ($ blk) safeFuncs + safeFuncs = map (mkSafe .) funcs + mkSafe = boolMaybe (isValidBlockPosition brd) + funcs = [rotate', rotate' . translate Left, rotate' . translate Right] + blk = g ^. block + brd = g ^. board + +blockStopped :: Game -> Bool +blockStopped g = isStopped (g ^. board) (g ^. block) + +-- | Check if a block on a board is stopped from further gravitation +isStopped :: Board -> Block -> Bool +isStopped brd = any cStopped . coords + where cStopped = (||) <$> inRow1 <*> (`M.member` brd) . (translate Down) + inRow1 (V2 _ y) = y == 1 + +hardDrop :: Game -> Game +hardDrop g = g & block .~ hardDroppedBlock g + +hardDroppedBlock :: Game -> Block +hardDroppedBlock g = translateBy n Down $ g ^. block + where n = minimum $ (subtract 1) <$> (minY : diffs) + diffs = [y - yo | (V2 xo yo) <- brdCs, (V2 x y) <- blkCs, xo == x, yo < y] + brdCs = g ^. board ^. to M.keys + blkCs = g ^. block ^. to coords + minY = minimum (fmap (^. _y) blkCs) + +-- | Freeze current block +freezeBlock :: Game -> Game +freezeBlock g = g & board %~ (M.union blkMap) + where blk = g ^. block + blkMap = M.fromList $ [(c, blk ^. shape) | c <- blk ^. to coords] + +-- | Replace block with next block +nextBlock :: Game -> IO Game +nextBlock g = do + (t, ts) <- bagFourTetriminoEach (g ^. nextShapeBag) + pure $ + g & block .~ initBlock (g ^. nextShape) + & nextShape .~ t + & nextShapeBag .~ ts + +-- | Try to shift current block; if shifting not possible, leave block where it is +shift :: Direction -> Game -> Game +shift d g = g & block %~ shiftBlock + where shiftBlock b = if isValidBlockPosition (g ^. board) (translate d b) + then translate d b + else b + +-- | Check if coordinate is already occupied or free in board +isFree, isOccupied :: Board -> Coord -> Bool +isFree = flip M.notMember +isOccupied = flip M.member + +-- | Check if coordinate is in or out of bounds +isInBounds, isOutOfBounds :: Coord -> Bool +isInBounds (V2 x y) = 1 <= x && x <= boardWidth && 1 <= y +isOutOfBounds = not . isInBounds + +-- | Gravitate current block, i.e. shift down +gravitate :: Game -> Game +gravitate = shift Down + +-- | Checks if block's potential new location is valid +isValidBlockPosition :: Board -> Block -> Bool +isValidBlockPosition brd = all validCoord . coords + where validCoord = (&&) <$> isFree brd <*> isInBounds + +-- General utilities + +-- | Shuffle a sequence (random permutation) +shuffle :: Seq.Seq a -> IO (Seq.Seq a) +shuffle xs + | null xs = mempty + | otherwise = do + randomPosition <- getStdRandom (randomR (0, length xs - 1)) + let (left, right) = Seq.splitAt randomPosition xs + (y :< ys) = Seq.viewl right + fmap (y <|) (shuffle $ left >< ys) + +-- | Take predicate and input and transform to Maybe +boolMaybe :: (a -> Bool) -> a -> Maybe a +boolMaybe p a = if p a then Just a else Nothing + +v2 :: (a, a) -> V2 a +v2 (x, y) = V2 x y