betris (empty) → 0.1.0.0

raw patch · 6 files changed

+462/−0 lines, 6 filesdep +basedep +betrisdep +containerssetup-changed

Dependencies added: base, betris, containers, lens, linear, random, stm, stm-chans, vty

Files

LICENSE +30/−0
README.md +4/−0
Setup.hs +2/−0
app/Main.hs +60/−0
betris.cabal +64/−0
src/Game/Tetris.hs +302/−0

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,4 @@+# betris++A vertical version of tetris for braille display users.+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -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

+ betris.cabal view

@@ -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 <https://github.com/mlang/betris#readme>+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

+ src/Game/Tetris.hs view

@@ -0,0 +1,302 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+-------------------------------------------------------------------------------+-- |+-- Module      :  Game.Tetris+-- Copyright   :  (c) 2017 Samuel Tay <sam.chong.tay@gmail.com>+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Mario Lang <mlang@blind.guru>+--+-- 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