Add hard drop preview

Really annoying to have all these new attributes flying around. The code
would take like 2 lines if I could figure out how to reference the
default bg color from vty..

src/Tetris.hs

@@ -21,9 +21,6 @@ import Data.Monoid (First(..))
 --   0. BUG in hard drop - if block is under an overhang then it gets sent above
 --   1. leaderboard saved to txt file (requires adding viewport for name entry)
 --      and probably wrapping game in a ui state
---   2. Add ToDo: Custom RGB colors or find a good theme and steal it. See if attribute monoid is used for defaulting when color not displayable?
---   2. Consider allow speeding up just like Conway (thus removing pickLevel and having one interface)
---   2. consider adding hard drop preview like other games, but need another color
 --   3. USE linear V2 instead of tuples.. dummy
 --   3. Consider refactoring (Game -> a) with State or Reader abstraction
 --   4. README with gif
@@ -229,7 +226,10 @@ isStopped brd = any cStopped . coords
         inRow1 (_,y) = y == 1
 
 hardDrop :: Game -> Game
-hardDrop g = g & block %~ translateBy n Down
+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 | (xo,yo) <- brdCs, (x,y) <- blkCs, xo == x]
         brdCs = M.keys $ M.filterWithKey inCols $ g ^. board

src/UI/Game.hs

@@ -28,6 +28,7 @@ data Tick = Tick
 type Name = ()
 
 data CellLocation = InGrid | InNextShape
+data TVisual = Normal | HardDrop
 
 -- App definition and execution
 
@@ -95,29 +96,43 @@ drawGrid g = hLimit 22
              | r <- [boardHeight,boardHeight-1..1]
            ]
     inRow r (_,y) _ = r == y
-    gmap = drawMCell InGrid <$> mconcat [brdMap, blkMap, emptyMap]
+    gmap = mconcat [brdMap, cBlkMap, hrdMap, emptyCellMap]
-    brdMap = Just <$> g ^. board
+    brdMap = draw Normal . Just <$> g ^. board
-    blkMap = M.fromList [(c, Just $ g ^. block ^. shape) | c <- g ^. block ^. to coords]
+    hrdMap = blkMap (hardDroppedBlock g) HardDrop
+    cBlkMap = blkMap (g ^. block) Normal
+    blkMap b v = M.fromList . map (, draw v . Just $ b ^. shape) $ coords b
+    draw = drawMCell InGrid
 
-emptyMap :: Map Coord (Maybe a)
+emptyCellMap :: Map Coord (Widget Name)
-emptyMap = M.fromList [((x,y), Nothing) | x <- [1..boardWidth], y <- [1..boardHeight]]
+emptyCellMap = M.fromList cws
+  where
+    cws = [((x,y), ew) | x <- [1..boardWidth], y <- [1..boardHeight]]
+    ew = drawMCell InGrid Normal Nothing
 
-drawMCell :: CellLocation -> Maybe Tetrimino -> Widget Name
+drawMCell :: CellLocation -> TVisual -> Maybe Tetrimino -> Widget Name
-drawMCell InGrid Nothing = withAttr emptyAttr cw
+drawMCell InGrid _ Nothing = withAttr emptyAttr cw
-drawMCell InNextShape Nothing = withAttr emptyAttr ecw
+drawMCell InNextShape _ Nothing = withAttr emptyAttr ecw
-drawMCell _ (Just t) = drawCell t
+drawMCell _ v (Just t) = drawCell t v
 
-drawCell :: Tetrimino -> Widget Name
+drawCell :: Tetrimino -> TVisual ->  Widget Name
-drawCell t = withAttr (tToAttr t) cw
+drawCell t Normal = withAttr (tToAttr t) cw
-  where tToAttr I = iAttr
+drawCell t HardDrop = withAttr (tToAttrH t) hcw
-        tToAttr O = oAttr
-        tToAttr T = tAttr
-        tToAttr S = sAttr
-        tToAttr Z = zAttr
-        tToAttr J = jAttr
-        tToAttr L = lAttr
 
--- TODO • for hardDrop preview
+tToAttr I = iAttr
+tToAttr O = oAttr
+tToAttr T = tAttr
+tToAttr S = sAttr
+tToAttr Z = zAttr
+tToAttr J = jAttr
+tToAttr L = lAttr
+
+tToAttrH I = ihAttr
+tToAttrH O = ohAttr
+tToAttrH T = thAttr
+tToAttrH S = shAttr
+tToAttrH Z = zhAttr
+tToAttrH J = jhAttr
+tToAttrH L = lhAttr
 
 cw :: Widget Name
 cw = str " ."
@@ -125,6 +140,9 @@ cw = str " ."
 ecw :: Widget Name
 ecw = str "  "
 
+hcw :: Widget Name
+hcw = str "◤◢"
+
 drawStats :: Game -> Widget Name
 drawStats g = hLimit 22
   $ withBorderStyle BS.unicodeBold
@@ -155,7 +173,7 @@ drawNextShape t = withBorderStyle BS.unicodeBold
   $ vLimit 4
   $ vBox $ mkRow <$> [0,-1]
   where
-    mkRow y = hBox $ drawMCell InNextShape . cellAt . (,y) <$> [-2..1]
+    mkRow y = hBox $ drawMCell InNextShape Normal . cellAt . (,y) <$> [-2..1]
     cellAt (x,y) = if (x,y) `elem` cs then Just t else Nothing
     blk = Block t (0,0) (relCells t)
     cs = blk ^. to coords
@@ -184,16 +202,34 @@ drawGameOver g = if (isGameOver g)
 
 theMap :: AttrMap
 theMap = attrMap V.defAttr
-  [ (iAttr, on V.cyan V.cyan)
+  [ (iAttr, tToColor I `on` tToColor I)
-  , (oAttr, on V.yellow V.yellow)
+  , (oAttr, tToColor O `on` tToColor O)
-  , (tAttr, on V.magenta V.magenta)
+  , (tAttr, tToColor T `on` tToColor T)
-  , (sAttr, on V.green V.green)
+  , (sAttr, tToColor S `on` tToColor S)
-  , (zAttr, on V.red V.red)
+  , (zAttr, tToColor Z `on` tToColor Z)
-  , (jAttr, on V.blue V.blue)
+  , (jAttr, tToColor J `on` tToColor J)
-  , (lAttr, on V.white V.white) -- damn no orange in ANSI
+  , (lAttr, tToColor L `on` tToColor L)
+  -- attributes for hard drop preview (would be VERY clean if I could figure out how to
+  -- query for default background color.. alas
+  , (ihAttr, fg $ tToColor I)
+  , (ohAttr, fg $ tToColor O)
+  , (thAttr, fg $ tToColor T)
+  , (shAttr, fg $ tToColor S)
+  , (zhAttr, fg $ tToColor Z)
+  , (jhAttr, fg $ tToColor J)
+  , (lhAttr, fg $ tToColor L)
   , (gameOverAttr, fg V.red `V.withStyle` V.bold)
   ]
 
+tToColor :: Tetrimino -> V.Color
+tToColor I = V.cyan
+tToColor O = V.yellow
+tToColor T = V.magenta
+tToColor S = V.green
+tToColor Z = V.red
+tToColor J = V.blue
+tToColor L = V.white
+
 iAttr, oAttr, tAttr, sAttr, zAttr, jAttr, lAttr :: AttrName
 iAttr = "I"
 oAttr = "O"
@@ -203,6 +239,15 @@ zAttr = "Z"
 jAttr = "J"
 lAttr = "L"
 
+ihAttr, ohAttr, thAttr, shAttr, zhAttr, jhAttr, lhAttr :: AttrName
+ihAttr = "Ih"
+ohAttr = "Oh"
+thAttr = "Th"
+shAttr = "Sh"
+zhAttr = "Zh"
+jhAttr = "Jh"
+lhAttr = "Lh"
+
 emptyAttr :: AttrName
 emptyAttr = "empty"