-
Notifications
You must be signed in to change notification settings - Fork 0
/
Main.hs
66 lines (57 loc) · 2.09 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module Main where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM.TVar
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
speed <- newTVarIO 1000000
forkIO $ forever $ do
e <- nextEvent vty
atomically $ writeTBChan chan $ Ev e
forkIO $ forever $ do
delay <- readTVarIO speed
atomically $ modifyTVar speed ((-) 100)
threadDelay delay
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