Build out more game mechanics

Typical tetris randomizer, bring in `containers`, swap to absolute cell
locations, write game initializer.

app/Main.hs

@@ -3,4 +3,4 @@ module Main where
 import Tetris
 
 main :: IO ()
-main = someFunc
+main = undefined

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)

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
+extra-deps:
+- containers-0.5.10.2
+resolver: lts-8.18

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

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