Formatting only
This commit is contained in:
Sam Tay
parent
ccbd9d8e36
commit
b3d812bee5
1 changed files with 119 additions and 101 deletions
220
src/UI/Game.hs
220
src/UI/Game.hs
|
|
@ -45,12 +45,13 @@ data TVisual = Normal | HardDrop
|
||||||
-- App definition and execution
|
-- App definition and execution
|
||||||
|
|
||||||
app :: App UI Tick Name
|
app :: App UI Tick Name
|
||||||
app = App { appDraw = drawUI
|
app = App
|
||||||
, appChooseCursor = neverShowCursor
|
{ appDraw = drawUI
|
||||||
, appHandleEvent = handleEvent
|
, appChooseCursor = neverShowCursor
|
||||||
, appStartEvent = return
|
, appHandleEvent = handleEvent
|
||||||
, appAttrMap = const theMap
|
, appStartEvent = return
|
||||||
}
|
, appAttrMap = const theMap
|
||||||
|
}
|
||||||
|
|
||||||
playGame :: Int -> Maybe String -> IO Game
|
playGame :: Int -> Maybe String -> IO Game
|
||||||
playGame lvl mp = do
|
playGame lvl mp = do
|
||||||
|
|
@ -70,21 +71,21 @@ levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n)
|
||||||
-- Handling events
|
-- Handling events
|
||||||
|
|
||||||
handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI)
|
handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI)
|
||||||
handleEvent ui (AppEvent Tick) = handleTick ui
|
handleEvent ui (AppEvent Tick ) = handleTick ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right) ui
|
handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right) ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left) ui
|
handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left) ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down) ui
|
handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down) ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right) ui
|
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right) ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left) ui
|
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left) ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down) ui
|
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down) ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = exec rotate ui
|
handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = exec rotate ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate ui
|
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ ui & game %~ execTetris hardDrop
|
handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) =
|
||||||
& locked .~ True
|
continue $ ui & game %~ execTetris hardDrop & locked .~ True
|
||||||
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart ui
|
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui
|
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui
|
||||||
handleEvent ui (VtyEvent (V.EvKey V.KEsc [])) = halt ui
|
handleEvent ui (VtyEvent (V.EvKey V.KEsc [])) = halt ui
|
||||||
handleEvent ui _ = continue ui
|
handleEvent ui _ = continue ui
|
||||||
|
|
||||||
-- | This common execution function is used for all game input except hard
|
-- | This common execution function is used for all game input except hard
|
||||||
-- drop. If locked (from hard drop) do nothing, else execute the state
|
-- drop. If locked (from hard drop) do nothing, else execute the state
|
||||||
|
|
@ -117,44 +118,48 @@ restart ui = do
|
||||||
|
|
||||||
drawUI :: UI -> [Widget Name]
|
drawUI :: UI -> [Widget Name]
|
||||||
drawUI ui =
|
drawUI ui =
|
||||||
[ C.vCenter $ vLimit 22 $ hBox [ padLeft Max $ padRight (Pad 2) $ drawStats (ui ^. game)
|
[ C.vCenter $ vLimit 22 $ hBox
|
||||||
, drawGrid ui
|
[ padLeft Max $ padRight (Pad 2) $ drawStats (ui ^. game)
|
||||||
, padRight Max $ padLeft (Pad 2) $ drawInfo (ui ^. game)
|
, drawGrid ui
|
||||||
]
|
, padRight Max $ padLeft (Pad 2) $ drawInfo (ui ^. game)
|
||||||
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
drawGrid :: UI -> Widget Name
|
drawGrid :: UI -> Widget Name
|
||||||
drawGrid ui = hLimit 22
|
drawGrid ui =
|
||||||
$ withBorderStyle BS.unicodeBold
|
hLimit 22
|
||||||
$ B.borderWithLabel (str "Tetris")
|
$ withBorderStyle BS.unicodeBold
|
||||||
$ vBox rows
|
$ B.borderWithLabel (str "Tetris")
|
||||||
where
|
$ vBox rows
|
||||||
rows = [foldr (<+>) emptyWidget $ M.filterWithKey (inRow r) gmap
|
where
|
||||||
| r <- [boardHeight,boardHeight-1..1]
|
rows =
|
||||||
]
|
[ foldr (<+>) emptyWidget $ M.filterWithKey (inRow r) gmap
|
||||||
inRow r (V2 _ y) _ = r == y
|
| r <- [boardHeight, boardHeight - 1 .. 1]
|
||||||
gmap = mconcat [brdMap, cBlkMap, hrdMap, emptyCellMap]
|
]
|
||||||
brdMap = draw Normal . Just <$> g ^. board
|
inRow r (V2 _ y) _ = r == y
|
||||||
hrdMap = blkMap (evalTetris hardDroppedBlock g) HardDrop
|
gmap = mconcat [brdMap, cBlkMap, hrdMap, emptyCellMap]
|
||||||
cBlkMap = blkMap (g ^. block) Normal
|
brdMap = draw Normal . Just <$> g ^. board
|
||||||
blkMap b v = M.fromList . map (, draw v . Just $ b ^. shape) $ coords b
|
hrdMap = blkMap (evalTetris hardDroppedBlock g) HardDrop
|
||||||
draw = drawMCell (ui ^. preview) InGrid
|
cBlkMap = blkMap (g ^. block) Normal
|
||||||
g = ui ^. game
|
draw = drawMCell (ui ^. preview) InGrid
|
||||||
|
g = ui ^. game
|
||||||
|
blkMap b v = M.fromList . map (, draw v . Just $ b ^. shape) $ coords b
|
||||||
|
|
||||||
emptyCellMap :: Map Coord (Widget Name)
|
emptyCellMap :: Map Coord (Widget Name)
|
||||||
emptyCellMap = M.fromList cws
|
emptyCellMap = M.fromList cws
|
||||||
where
|
where
|
||||||
cws = [((V2 x y), ew) | x <- [1..boardWidth], y <- [1..boardHeight]]
|
cws = [ ((V2 x y), ew) | x <- [1 .. boardWidth], y <- [1 .. boardHeight] ]
|
||||||
ew = drawMCell Nothing InGrid Normal Nothing
|
ew = drawMCell Nothing InGrid Normal Nothing
|
||||||
|
|
||||||
drawMCell :: Maybe String -> CellLocation -> TVisual -> Maybe Tetrimino -> Widget Name
|
drawMCell
|
||||||
drawMCell _ InGrid _ Nothing = withAttr emptyAttr cw
|
:: Maybe String -> CellLocation -> TVisual -> Maybe Tetrimino -> Widget Name
|
||||||
drawMCell _ InNextShape _ Nothing = withAttr emptyAttr ecw
|
drawMCell _ InGrid _ Nothing = withAttr emptyAttr cw
|
||||||
drawMCell mp _ v (Just t) = drawCell mp t v
|
drawMCell _ InNextShape _ Nothing = withAttr emptyAttr ecw
|
||||||
|
drawMCell mp _ v (Just t) = drawCell mp t v
|
||||||
|
|
||||||
drawCell :: Maybe String -> Tetrimino -> TVisual -> Widget Name
|
drawCell :: Maybe String -> Tetrimino -> TVisual -> Widget Name
|
||||||
drawCell _ t Normal = withAttr (tToAttr t) cw
|
drawCell _ t Normal = withAttr (tToAttr t) cw
|
||||||
drawCell Nothing t HardDrop = withAttr (tToAttrH t) hcw
|
drawCell Nothing t HardDrop = withAttr (tToAttrH t) hcw
|
||||||
drawCell (Just p) t HardDrop = withAttr (tToAttrH t) (str p)
|
drawCell (Just p) t HardDrop = withAttr (tToAttrH t) (str p)
|
||||||
|
|
||||||
tToAttr :: Tetrimino -> AttrName
|
tToAttr :: Tetrimino -> AttrName
|
||||||
|
|
@ -185,82 +190,95 @@ hcw :: Widget Name
|
||||||
hcw = str "◤◢"
|
hcw = str "◤◢"
|
||||||
|
|
||||||
drawStats :: Game -> Widget Name
|
drawStats :: Game -> Widget Name
|
||||||
drawStats g = hLimit 22
|
drawStats g =
|
||||||
$ withBorderStyle BS.unicodeBold
|
hLimit 22
|
||||||
$ B.borderWithLabel (str "Stats")
|
$ withBorderStyle BS.unicodeBold
|
||||||
$ vBox [ drawStat "Score" $ g ^. score
|
$ B.borderWithLabel (str "Stats")
|
||||||
, padTop (Pad 1) $ drawStat "Level" $ g ^. level
|
$ vBox
|
||||||
, drawLeaderBoard g
|
[ drawStat "Score" $ g ^. score
|
||||||
]
|
, padTop (Pad 1) $ drawStat "Level" $ g ^. level
|
||||||
|
, drawLeaderBoard g
|
||||||
|
]
|
||||||
|
|
||||||
drawStat :: String -> Int -> Widget Name
|
drawStat :: String -> Int -> Widget Name
|
||||||
drawStat s n = padLeftRight 1
|
drawStat s n = padLeftRight 1 $ str s <+> (padLeft Max $ str $ show n)
|
||||||
$ str s <+> (padLeft Max $ str $ show n)
|
|
||||||
|
|
||||||
drawLeaderBoard :: Game -> Widget Name
|
drawLeaderBoard :: Game -> Widget Name
|
||||||
drawLeaderBoard _ = emptyWidget
|
drawLeaderBoard _ = emptyWidget
|
||||||
|
|
||||||
drawInfo :: Game -> Widget Name
|
drawInfo :: Game -> Widget Name
|
||||||
drawInfo g = hLimit 18 -- size of next piece box
|
drawInfo g = hLimit 18 -- size of next piece box
|
||||||
$ vBox [ drawNextShape (g ^. nextShape)
|
$ vBox
|
||||||
, padTop (Pad 2) $ drawHelp
|
[ drawNextShape (g ^. nextShape)
|
||||||
, padTop (Pad 1) $ drawGameOver g
|
, padTop (Pad 2) $ drawHelp
|
||||||
]
|
, padTop (Pad 1) $ drawGameOver g
|
||||||
|
]
|
||||||
|
|
||||||
drawNextShape :: Tetrimino -> Widget Name
|
drawNextShape :: Tetrimino -> Widget Name
|
||||||
drawNextShape t = withBorderStyle BS.unicodeBold
|
drawNextShape t =
|
||||||
$ B.borderWithLabel (str "Next")
|
withBorderStyle BS.unicodeBold
|
||||||
$ padTopBottom 1 $ padLeftRight 4
|
$ B.borderWithLabel (str "Next")
|
||||||
$ vLimit 4
|
$ padTopBottom 1
|
||||||
$ vBox $ mkRow <$> [0,-1]
|
$ padLeftRight 4
|
||||||
where
|
$ vLimit 4
|
||||||
mkRow y = hBox $ drawMCell Nothing InNextShape Normal . cellAt . (`V2` y) <$> [-2..1]
|
$ vBox
|
||||||
cellAt (V2 x y) = if (V2 x y) `elem` cs then Just t else Nothing
|
$ mkRow
|
||||||
blk = Block t (V2 0 0) (relCells t)
|
<$> [0, -1]
|
||||||
cs = blk ^. to coords
|
where
|
||||||
|
mkRow y =
|
||||||
|
hBox
|
||||||
|
$ drawMCell Nothing InNextShape Normal
|
||||||
|
. cellAt
|
||||||
|
. (`V2` y)
|
||||||
|
<$> [-2 .. 1]
|
||||||
|
cellAt (V2 x y) = if (V2 x y) `elem` cs then Just t else Nothing
|
||||||
|
blk = Block t (V2 0 0) (relCells t)
|
||||||
|
cs = blk ^. to coords
|
||||||
|
|
||||||
drawHelp :: Widget Name
|
drawHelp :: Widget Name
|
||||||
drawHelp = withBorderStyle BS.unicodeBold
|
drawHelp =
|
||||||
$ B.borderWithLabel (str "Help")
|
withBorderStyle BS.unicodeBold
|
||||||
$ padTopBottom 1
|
$ B.borderWithLabel (str "Help")
|
||||||
$ vBox $ map (uncurry drawKeyInfo)
|
$ padTopBottom 1
|
||||||
$ [ ("Left", "h, ←")
|
$ vBox
|
||||||
, ("Right", "l, →")
|
$ map (uncurry drawKeyInfo)
|
||||||
, ("Down", "j, ↓")
|
$ [ ("Left" , "h, ←")
|
||||||
, ("Rotate", "k, ↑")
|
, ("Right" , "l, →")
|
||||||
, ("Drop", "space")
|
, ("Down" , "j, ↓")
|
||||||
, ("Restart", "r")
|
, ("Rotate" , "k, ↑")
|
||||||
, ("Quit", "q")
|
, ("Drop" , "space")
|
||||||
]
|
, ("Restart", "r")
|
||||||
|
, ("Quit" , "q")
|
||||||
|
]
|
||||||
|
|
||||||
drawKeyInfo :: String -> String -> Widget Name
|
drawKeyInfo :: String -> String -> Widget Name
|
||||||
drawKeyInfo action keys =
|
drawKeyInfo action keys =
|
||||||
(padRight Max $ padLeft (Pad 1) $ str action)
|
(padRight Max $ padLeft (Pad 1) $ str action)
|
||||||
<+> (padLeft Max $ padRight (Pad 1) $ str keys)
|
<+> (padLeft Max $ padRight (Pad 1) $ str keys)
|
||||||
|
|
||||||
drawGameOver :: Game -> Widget Name
|
drawGameOver :: Game -> Widget Name
|
||||||
drawGameOver g = if (isGameOver g)
|
drawGameOver g =
|
||||||
then padLeftRight 4 $ withAttr gameOverAttr $ str "GAME OVER"
|
if (isGameOver g)
|
||||||
else emptyWidget
|
then padLeftRight 4 $ withAttr gameOverAttr $ str "GAME OVER"
|
||||||
|
else emptyWidget
|
||||||
|
|
||||||
theMap :: AttrMap
|
theMap :: AttrMap
|
||||||
theMap = attrMap V.defAttr
|
theMap = attrMap
|
||||||
[ (iAttr, tToColor I `on` tToColor I)
|
V.defAttr
|
||||||
, (oAttr, tToColor O `on` tToColor O)
|
[ (iAttr , tToColor I `on` tToColor I)
|
||||||
, (tAttr, tToColor T `on` tToColor T)
|
, (oAttr , tToColor O `on` tToColor O)
|
||||||
, (sAttr, tToColor S `on` tToColor S)
|
, (tAttr , tToColor T `on` tToColor T)
|
||||||
, (zAttr, tToColor Z `on` tToColor Z)
|
, (sAttr , tToColor S `on` tToColor S)
|
||||||
, (jAttr, tToColor J `on` tToColor J)
|
, (zAttr , tToColor Z `on` tToColor Z)
|
||||||
, (lAttr, tToColor L `on` tToColor L)
|
, (jAttr , tToColor J `on` tToColor J)
|
||||||
-- attributes for hard drop preview (would be VERY clean if I could figure out how to
|
, (lAttr , tToColor L `on` tToColor L)
|
||||||
-- query for default background color.. alas
|
, (ihAttr , fg $ tToColor I)
|
||||||
, (ihAttr, fg $ tToColor I)
|
, (ohAttr , fg $ tToColor O)
|
||||||
, (ohAttr, fg $ tToColor O)
|
, (thAttr , fg $ tToColor T)
|
||||||
, (thAttr, fg $ tToColor T)
|
, (shAttr , fg $ tToColor S)
|
||||||
, (shAttr, fg $ tToColor S)
|
, (zhAttr , fg $ tToColor Z)
|
||||||
, (zhAttr, fg $ tToColor Z)
|
, (jhAttr , fg $ tToColor J)
|
||||||
, (jhAttr, fg $ tToColor J)
|
, (lhAttr , fg $ tToColor L)
|
||||||
, (lhAttr, fg $ tToColor L)
|
|
||||||
, (gameOverAttr, fg V.red `V.withStyle` V.bold)
|
, (gameOverAttr, fg V.red `V.withStyle` V.bold)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue