termbox-tea-0.1.0: examples/Demo.hs

module Main (main) where

import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar
import Control.Monad (forever)
import GHC.Clock (getMonotonicTime)
import qualified Ki
import qualified Termbox.Tea as Termbox
import Text.Printf (printf)

main :: IO ()
main = do
  t0 <- getMonotonicTime
  result <-
    Ki.scoped \scope -> do
      timeVar <- newEmptyMVar
      Ki.fork_ scope do
        forever do
          threadDelay 100_000
          getMonotonicTime >>= putMVar timeVar
      Termbox.run
        Termbox.Program
          { initialize,
            pollEvent = pollEvent t0 timeVar,
            handleEvent,
            render,
            finished
          }
  case result of
    Left err -> print err
    Right _state -> pure ()

data State = State
  { elapsed :: Double,
    lastKey :: Maybe Termbox.Key,
    bright :: Bool
  }

initialize :: Termbox.Size -> State
initialize _size =
  State
    { elapsed = 0,
      lastKey = Nothing,
      bright = False
    }

pollEvent :: Double -> MVar Double -> Maybe (IO Double)
pollEvent t0 timeVar =
  Just do
    t1 <- takeMVar timeVar
    pure (t1 - t0)

handleEvent :: State -> Termbox.Event Double -> IO State
handleEvent State {elapsed, lastKey, bright} = \case
  Termbox.EventKey key ->
    pure
      State
        { elapsed,
          lastKey = Just key,
          bright =
            case key of
              Termbox.KeyChar '*' -> not bright
              _ -> bright
        }
  Termbox.EventUser elapsed1 ->
    pure
      State
        { elapsed = elapsed1,
          lastKey,
          bright
        }
  _ ->
    pure
      State
        { elapsed,
          lastKey,
          bright
        }

render :: State -> Termbox.Scene
render State {elapsed, lastKey, bright} =
  renderBox Termbox.Pos {row = 1, col = 2} $
    vcat
      [ string "Welcome to Termbox. Try typing, clicking, and resizing the terminal!",
        string " ",
        hcat
          [ string "Elapsed time: ",
            string (map Termbox.char (printf "%.1fs" elapsed))
          ],
        hcat
          [ string "Latest key press: ",
            case lastKey of
              Nothing -> emptyBox
              Just event -> string (map (Termbox.bold . Termbox.char) (show event))
          ],
        string " ",
        string "default red green yellow blue magenta cyan white",
        hcat
          [ rect
              Rect
                { size = Termbox.Size {width = 7, height = 2},
                  color = brighten Termbox.defaultColor
                },
            string " ",
            rect
              Rect
                { size = Termbox.Size {width = 3, height = 2},
                  color = brighten Termbox.red
                },
            string " ",
            rect
              Rect
                { size = Termbox.Size {width = 5, height = 2},
                  color = brighten Termbox.green
                },
            string " ",
            rect
              Rect
                { size = Termbox.Size {width = 6, height = 2},
                  color = brighten Termbox.yellow
                },
            string " ",
            rect
              Rect
                { size = Termbox.Size {width = 4, height = 2},
                  color = brighten Termbox.blue
                },
            string " ",
            rect
              Rect
                { size = Termbox.Size {width = 7, height = 2},
                  color = brighten Termbox.magenta
                },
            string " ",
            rect
              Rect
                { size = Termbox.Size {width = 4, height = 2},
                  color = brighten Termbox.cyan
                },
            string " ",
            rect
              Rect
                { size = Termbox.Size {width = 5, height = 2},
                  color = brighten Termbox.white
                },
            string " ",
            vcat
              [ string ("Press " ++ [Termbox.bold (Termbox.char '*')] ++ " to toggle brightness."),
                string
                  ( let selected = map (Termbox.bg (Termbox.gray 20) . Termbox.fg (Termbox.gray 0))
                     in if bright
                          then "normal " ++ selected "bright"
                          else selected "normal" ++ " bright"
                  )
              ]
          ],
        string " ",
        string "color 0 .. color 215",
        vcat
          ( map
              ( \is ->
                  hcat
                    ( map
                        ( \i ->
                            acat
                              [ rect
                                  Rect
                                    { size = Termbox.Size {width = 4, height = 2},
                                      color = Termbox.color i
                                    },
                                string (map (Termbox.bg (Termbox.color i) . Termbox.char) (show i))
                              ]
                        )
                        is
                    )
              )
              (chunksOf 24 [0 .. 215])
          ),
        string " ",
        string "gray 0 .. gray 23",
        hcat
          ( map
              ( \i ->
                  acat
                    [ rect
                        Rect
                          { size = Termbox.Size {width = 4, height = 2},
                            color = Termbox.gray i
                          },
                      string (map (Termbox.bg (Termbox.gray i) . Termbox.char) (show i))
                    ]
              )
              [0 .. 23]
          ),
        string " ",
        hcat
          [ string (map Termbox.bold "This text is bold."),
            string " ",
            string (map Termbox.underline "This text is underlined."),
            string " ",
            string (map Termbox.blink "This text is blinking (maybe).")
          ],
        string " ",
        hcat
          [ string "Press ",
            string (map Termbox.bold "Esc"),
            string " to quit!"
          ]
      ]
  where
    brighten :: Termbox.Color -> Termbox.Color
    brighten =
      if bright
        then Termbox.bright
        else id

finished :: State -> Bool
finished State {lastKey} =
  case lastKey of
    Just Termbox.KeyEsc -> True
    _ -> False

data Box
  = Box !Termbox.Size Content

data Content
  = E
  | O !Termbox.Cell
  | A !Box !Box
  | H !Box !Box
  | V !Box !Box

emptyBox :: Box
emptyBox =
  Box (Termbox.Size 0 0) E

one :: Termbox.Cell -> Box
one cell =
  Box (Termbox.Size 1 1) (O cell) -- assume it's not an empty cell *shrug*

acat :: [Box] -> Box
acat =
  foldr f emptyBox
  where
    f :: Box -> Box -> Box
    f box1@(Box (Termbox.Size w1 h1) _) box2@(Box (Termbox.Size w2 h2) _) =
      Box (Termbox.Size (max w1 w2) (max h1 h2)) (A box1 box2)

hcat :: [Box] -> Box
hcat =
  foldr f emptyBox
  where
    f :: Box -> Box -> Box
    f box1@(Box (Termbox.Size w1 h1) _) box2@(Box (Termbox.Size w2 h2) _) =
      Box (Termbox.Size (w1 + w2) (max h1 h2)) (H box1 box2)

vcat :: [Box] -> Box
vcat =
  foldr f emptyBox
  where
    f :: Box -> Box -> Box
    f box1@(Box (Termbox.Size w1 h1) _) box2@(Box (Termbox.Size w2 h2) _) =
      Box (Termbox.Size (max w1 w2) (h1 + h2)) (V box1 box2)

renderBox :: Termbox.Pos -> Box -> Termbox.Scene
renderBox pos (Box _ content) =
  case content of
    E -> mempty
    O cell -> Termbox.cell pos cell
    A box1 box2 -> renderBox pos box1 <> renderBox pos box2
    H box1@(Box (Termbox.Size w1 _) _) box2 -> renderBox pos box1 <> renderBox (Termbox.posRight w1 pos) box2
    V box1@(Box (Termbox.Size _ h1) _) box2 -> renderBox pos box1 <> renderBox (Termbox.posDown h1 pos) box2

string :: [Termbox.Cell] -> Box
string =
  hcat . map one

data Rect = Rect
  { size :: Termbox.Size,
    color :: Termbox.Color
  }

rect :: Rect -> Box
rect Rect {size = Termbox.Size {width, height}, color} =
  vcat (replicate height (string (replicate width (Termbox.bg color (Termbox.char ' ')))))

chunksOf :: Int -> [a] -> [[a]]
chunksOf n = \case
  [] -> []
  xs ->
    let (ys, zs) = splitAt n xs
     in ys : chunksOf n zs