brick-0.24.1: programs/Testing.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

module Main where

import Control.Monad (void)
import Data.Function ((&))
import Data.Function (on)
import Data.List     (transpose)

import qualified Brick                as B
import qualified Brick.Widgets.Core   as B
import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Center as B
import qualified Graphics.Vty         as V

type Name = ()
data Tick
data Game

app :: B.App Game Tick Name
app = B.App
    { B.appDraw         = drawUI
    , B.appChooseCursor = B.neverShowCursor
    , B.appHandleEvent  = handleEvent
    , B.appStartEvent   = pure
    , B.appAttrMap      = const theMap
    }

theMap :: B.AttrMap
theMap = B.attrMap V.defAttr
    [ (blackSquare, go V.withBackColor V.black)
    , (redSquare, go V.withBackColor V.red)
    ]
  where
    go a b = a V.defAttr b

blackSquare, redSquare :: B.AttrName
blackSquare = "blackSquare"
redSquare = "redSquare"

vkey :: B.BrickEvent Name Tick -> Maybe V.Key
vkey (B.VtyEvent (V.EvKey y [])) = Just y
vkey _ = Nothing

handleEvent :: Game -> B.BrickEvent Name Tick -> B.EventM Name (B.Next Game)
handleEvent g (vkey -> Just (V.KChar 'q')) = g & B.halt
handleEvent g (vkey -> Just (V.KEsc))      = g & B.halt
handleEvent g (vkey -> Nothing)            = g & B.continue
handleEvent g _                            = g & B.continue

drawUI :: Game -> [B.Widget Name]
drawUI = pure . drawBoard

boardNumbers :: Game -> [[B.Widget Name]]
boardNumbers _ =
    board
  where
    (.:) = (.) . (.)

    ap = take 8 .: zipC `on` repeat

    board    = ap oddRows evenRows
    oddRows  = ap reds    blacks
    evenRows = ap blacks  reds

    zipC = (concat . transpose) .: mappend `on` pure

    pattern p = B.withAttr p . B.center . B.str $ " "

    reds   = pattern redSquare
    blacks = pattern blackSquare

drawBoard :: Game -> B.Widget Name
drawBoard = B.border . B.vBox . fmap B.hBox . boardNumbers

main :: IO ()
main = void $ B.defaultMain app undefined