diff --git a/app/Main.hs b/app/Main.hs index f24db73..c775371 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,4 +3,4 @@ module Main where import Tetris main :: IO () -main = someFunc +main = undefined diff --git a/src/Tetris.hs b/src/Tetris.hs index 95eba51..7567538 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -2,35 +2,32 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -module Tetris - ( - ) where +module Tetris where +import Data.Map (Map) import qualified Data.Map as M +import Data.Sequence (ViewL(..), (<|), (><)) +import qualified Data.Sequence as Seq import Lens.Micro import Lens.Micro.TH +import System.Random (getStdRandom, randomR) + import Prelude hiding (Left, Right) +-- Types and instances + -- | Tetris shape types -data Tetrimino = - I - | O - | T - | S - | Z - | J - | L +data Tetrimino = I | O | T | S | Z | J | L deriving (Eq, Show, Enum) -- | Coordinates type Coord = (Int, Int) -type CoordMap = (Int -> Int, Int -> Int) -- | Tetris shape in coordinate context data Block = Block { _shape :: Tetrimino -- ^ block type - , _origin :: Coord -- ^ origin (absolute) - , _extra :: [Coord] -- ^ extraneous cells (relative) + , _origin :: Coord -- ^ origin + , _extra :: [Coord] -- ^ extraneous cells } deriving (Eq, Show) makeLenses ''Block @@ -43,13 +40,14 @@ data Cell = Filled Tetrimino | Empty deriving (Eq, Show) -- | Board of cells -type Board = M.Map Coord Cell +type Board = Map Coord Cell -- | Game state data Game = Game - { _speed :: Int + { _level :: Int , _currBlock :: Block , _nextShape :: Tetrimino + , _nextShapeBag :: Seq.Seq Tetrimino , _score :: Int , _board :: Board } deriving (Eq, Show) @@ -66,27 +64,84 @@ instance Translatable Coord where translate Down (x,y) = (x, y-1) instance Translatable Block where - translate d b = b & origin %~ translate d + translate d b = + b & origin %~ translate d + & extra %~ fmap (translate d) -initI, initO, initS, initZ, initL, initJ, initT :: Block -initI = Block I (0,0) [(-2,0), (-1,0), (1,0)] -initO = Block O (0,0) [(-1,0), (-1,-1), (0,-1)] -initS = Block S (0,0) [(-1,-1), (0,-1), (1,0)] -initZ = Block Z (0,0) [(-1,0), (0,-1), (1,-1)] -initL = Block L (0,0) [(-1,-1), (-1,0), (1,0)] -initJ = Block J (0,0) [(-1,0), (1,0), (1,-1)] -initT = Block T (0,0) [(-1,0), (0,-1), (1,0)] +-- Low level functions on blocks, cells, and coordinates + +initBlock :: Tetrimino -> Block +initBlock I = Block I startOrigin [(-2,0), (-1,0), (1,0)] +initBlock O = Block O startOrigin [(-1,0), (-1,-1), (0,-1)] +initBlock S = Block S startOrigin [(-1,-1), (0,-1), (1,0)] +initBlock Z = Block Z startOrigin [(-1,0), (0,-1), (1,-1)] +initBlock L = Block L startOrigin [(-1,-1), (-1,0), (1,0)] +initBlock J = Block J startOrigin [(-1,0), (1,0), (1,-1)] +initBlock T = Block T startOrigin [(-1,0), (0,-1), (1,0)] + +-- | Visible, active board size +boardWidth, boardHeight :: Int +boardWidth = 10 +boardHeight = 20 + +-- | Starting block origin cell +startOrigin :: Coord +startOrigin = (6, 21) -- | 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' = (& extra %~ fmap (\(x,y) -> (-y, x))) +rotate' b@(Block s o@(xo,yo) cs) + | s == O = b -- O doesn't need rotation + | s == I && (xo,yo+1) `elem` cs = rotateWith clockwise b -- I only has two orientations + | otherwise = rotateWith counterclockwise b --- | Get absolute coordinates of extraneous block cells -absExtra :: Block -> [Coord] -absExtra (Block _ (xo,yo) cs) = fmap (\(x,y) -> (x+xo, y+yo)) cs +rotateWith :: (Coord -> Coord -> Coord) -> Block -> Block +rotateWith dir b = let o = b ^. origin + in b & extra %~ fmap (dir o) --- | Get absolute coordinates of all block cells -absAll :: Block -> [Coord] -absAll (Block _ o@(xo,yo) cs) = o : fmap (\(x,y) -> (x+xo, y+yo)) cs +clockwise :: Coord -- ^ origin + -> Coord -- ^ point to rotate around origin + -> Coord +clockwise (xo, yo) (x, y) = (xo + y - yo, xo + y - x) + +counterclockwise :: Coord -- ^ origin + -> Coord -- ^ point to rotate around origin + -> Coord +counterclockwise (xo, yo) (x, y) = (xo + yo - y, x + yo - xo) + +-- | Get coordinates of all block cells +occupiedCells :: Block -> [Coord] +occupiedCells b = b ^. origin : b ^. extra + +-- Higher level functions on game and board + +bagFourTetriminoEach :: IO (Seq.Seq Tetrimino) +bagFourTetriminoEach = + shuffle $ Seq.cycleTaking 28 $ Seq.fromList [(I)..] + +-- | Initialize a game with a given level +initGame :: Int -> IO Game +initGame lvl = do + initBag <- bagFourTetriminoEach + let (fstShape :< fstBag) = Seq.viewl initBag + (sndShape :< sndBag) = Seq.viewl fstBag + return + Game { _level = lvl + , _currBlock = initBlock fstShape + , _nextShape = sndShape + , _nextShapeBag = sndBag + , _score = 0 + , _board = mempty } + +-- | TODO wallkicks http://tetris.wikia.com/wiki/TGM_rotation + +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) diff --git a/stack.yaml b/stack.yaml index 298b56e..11ebef5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,66 +1,7 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# http://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-8.18 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. +flags: {} +extra-package-dbs: [] packages: - '.' -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: [] - -# Override default flag values for local packages and extra-deps -flags: {} - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.4" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file +extra-deps: +- containers-0.5.10.2 +resolver: lts-8.18 diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..ce19c38 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,3 @@ main :: IO () main = putStrLn "Test suite not yet implemented" +-- TODO specs for mocking game and ensuring boundaries respected diff --git a/tetris.cabal b/tetris.cabal index cc645b1..dbba85b 100644 --- a/tetris.cabal +++ b/tetris.cabal @@ -18,9 +18,10 @@ library exposed-modules: Tetris build-depends: base >= 4.7 && < 5 , brick - , containers + , containers == 0.5.10.2 , microlens , microlens-th + , random default-language: Haskell2010 executable tetris