1 files changed, 523 insertions, 0 deletions

diff --git a/src/countdown.hs b/src/countdown.hs
new file mode 100755
index 0000000..1910bec
--- /dev/null
+++ b/src/countdown.hs
@@ -0,0 +1,523 @@
+#!/usr/bin/env stack
+{- stack script --resolver lts-19.23 --install-ghc -}
+{-# OPTIONS_GHC
+  -Wall
+  -Wno-unused-imports
+  -Wno-unused-top-binds
+  -Wno-name-shadowing
+#-}
+{-# language NoImplicitPrelude #-}
+{-# language RecordWildCards #-}
+{-# language FlexibleContexts #-}
+{-# language TemplateHaskell #-}
+{-# language ViewPatterns #-}
+{-# language OverloadedStrings #-}
+import Rebase.Prelude hiding (toList, on, (<+>), Max)
+import qualified Rebase.Prelude as Prelude
+import Control.Lens hiding ((<|))
+import Data.Foldable (toList)
+import Data.Ratio
+import Text.Printf
+import Graphics.Vty
+import Data.Time.LocalTime
+import Control.Monad.RWS
+import Data.Time.Calendar.OrdinalDate
+import qualified Data.Text as Text
+import Data.Text.Format.Numbers
+import Rebase.Data.Map.Strict (Map)
+import qualified Rebase.Data.Map.Strict as Map
+
+import Brick
+import Brick.Types
+import Data.Text (unpack)
+import Control.Lens
+import Control.Monad (void, forever)
+import Control.Concurrent (threadDelay, forkIO)
+import qualified Graphics.Vty as V
+import Brick.Widgets.ProgressBar as P
+import Brick.BChan
+import Brick.Widgets.Center
+import Brick.Widgets.Border
+import Brick.Main
+  ( App(..)
+  , showFirstCursor
+  , customMain
+  , continue
+  , halt
+  )
+import Brick.AttrMap
+  ( attrMap
+  )
+import Brick.Types
+  ( Widget
+  , Next
+  , EventM
+  , BrickEvent(..)
+  )
+import Brick.Widgets.Core
+  ( (<=>)
+  , str
+  )
+import Brick.AttrMap as A
+import Brick.Util (fg, bg, on, clamp)
+import Brick.Widgets.Core
+import Brick.Widgets.Table
+
+import CosmicCalendar
+import CosmicCalendarEvents
+
+data CustomEvent = TimeChanged ZonedTime deriving Show
+
+data St =
+    St { _stLastBrickEvent :: Maybe (BrickEvent () CustomEvent)
+       , _stClockTime      :: LocalTime
+       , _stDisplayTime    :: LocalTime
+       , _stNextEvent      :: Maybe UTCTime
+       , _stPaused         :: Bool
+       , _stShowConversion :: Bool
+       }
+
+makeLenses ''St
+
+yearNumber :: LocalTime -> Integer
+yearNumber (LocalTime t _) = y
+  where
+    (y, _, _) = toGregorian t
+
+yearEnd :: LocalTime -> LocalTime
+yearEnd (LocalTime d _) = LocalTime d' t'
+  where
+    d' = fromGregorian (y + 1) 1 1
+    t' = TimeOfDay 0 0 0
+    (y, _, _) = toGregorian d
+
+
+dayNumOfYear :: LocalTime -> Int
+dayNumOfYear = snd . toOrdinalDate . localDay
+
+pluralize :: (Num n, Eq n) => n -> String
+pluralize 1 = ""
+pluralize _ = "s"
+
+pluralizeVerb :: (Num n, Eq n) => n -> String
+pluralizeVerb 1 = "s"
+pluralizeVerb _ = ""
+
+drawUI :: St -> [Widget ()]
+drawUI st = [a]
+  where
+    a = vBox [
+        -- (str $ "Last event: " <> (show $ st ^. stLastBrickEvent)),
+        -- (str "\n"),
+        (str "\n"),
+        (countdownWidget (st ^. stShowConversion) (isSimulatedTime st) $ st ^. stDisplayTime)
+      ]
+
+showTime' :: Bool -> NominalDiffTime -> String
+showTime' True 1          = printf "%-3s second" ("1" :: Text)
+showTime' True t | t < 60 = printf "%.1f seconds" (realToFrac t :: Float)
+showTime' _ t = showTime t
+
+showTime :: NominalDiffTime -> String
+showTime t | t < 1           = printf "%.3f seconds" (realToFrac t :: Float)
+showTime t | t == 1          = "1 second"
+-- showTime t | t < 10          = formatTime defaultTimeLocale "%2Es seconds" t -- BUG! Doesn't respect <width> parameter at all!
+showTime t | t < 60          = printf "%.1f seconds" (realToFrac t :: Float)
+showTime t | t == 60         = formatTime defaultTimeLocale "%M minute" t
+showTime t | t < 60*2        = formatTime defaultTimeLocale "%M minute %Ss" t
+showTime t | t < 60*10       = formatTime defaultTimeLocale "%M minutes %Ss" t
+showTime t | t < 60*60       = formatTime defaultTimeLocale "%M minutes" t
+showTime t | t == 60*60      = "1 hour"
+showTime t | t < 60*60*2     = formatTime defaultTimeLocale "%H hour %Mm" t
+showTime t | t < 60*60*24    = formatTime defaultTimeLocale "%H hours %Mm" t
+showTime t | t == 60*60*24   = formatTime defaultTimeLocale "%d day" t
+showTime t | t < 60*60*24*2  = formatTime defaultTimeLocale "%d day %Hh" t
+showTime t | t == 60*60*24*7 = formatTime defaultTimeLocale "%d days" t
+showTime t | t < 60*60*24*10 = formatTime defaultTimeLocale "%d days %Hh" t
+showTime t                   = formatTime defaultTimeLocale "%d days" t
+-- showTime _ t = formatTime defaultTimeLocale "%w weeks %D days" t
+
+yearsToCosmicTime :: Integral i => i -> NominalDiffTime
+yearsToCosmicTime = (/ (realToFrac ageOfUniverseInYears)) . (* lengthOfYear) . realToFrac
+
+showCosmicYears :: Integer -> Widget n
+showCosmicYears = str . showTime . yearsToCosmicTime
+
+toCosmicTime :: NominalDiffTime -> Rational
+toCosmicTime t = realToFrac ageOfUniverseInYears * (realToFrac $ t // yearLength) :: Rational
+  where
+    yearLength = daysPerYear * nominalDay
+    x // y     = fromRational $ toRational x / toRational y :: Double
+
+showCosmicTime :: NominalDiffTime -> String
+showCosmicTime n = showLarge (fromRational $ toCosmicTime n) ++ " years"
+
+conversionTableRowFromCosmicSeconds :: NominalDiffTime -> [Widget n]
+conversionTableRowFromCosmicSeconds n = [cosmicTime, realTime]
+  where
+    realTime = str $ showCosmicTime n
+    cosmicTime = str $ showTime n
+
+cosmicConversion' :: Widget n
+cosmicConversion' = renderTable $
+  table
+  [
+    conversionTableRowFromCosmicSeconds $ 30 * 24 * 60 * 60,
+    conversionTableRowFromCosmicSeconds $ 7 * 24 * 60 * 60,
+    conversionTableRowFromCosmicSeconds $ 24 * 60 * 60,
+    conversionTableRowFromCosmicSeconds $ 60 * 60,
+    conversionTableRowFromCosmicSeconds $ 60,
+    conversionTableRowFromCosmicSeconds $ 1
+  ]
+
+cosmicConversion :: Widget n
+cosmicConversion = renderTable $
+  table
+  [
+    [str "1 billion years"    , showCosmicYears $ 1000 * 1000 * 1000],
+    [str "100 million years"  , showCosmicYears $ 100 * 1000 * 1000],
+    [str "10 million years"   , showCosmicYears $ 10 * 1000 * 1000],
+    [str "1 million years"    , showCosmicYears $ 1000 * 1000],
+    [str "100 thousand years" , showCosmicYears $ 100 * 1000],
+    [str "10 thousand years"  , showCosmicYears $ 10 * 1000],
+    [str "1 thousand years"   , showCosmicYears 1000],
+    [str "100 years"          , showCosmicYears 100],
+    [str "10 years"           , showCosmicYears 10],
+    [str "1 year"             , showCosmicYears 1]
+  ]
+
+showLarge :: Double -> String
+showLarge n | n >= 10 * 1000 * 1000 * 1000 = printf "%.0f billion"  (n / (1000 * 1000 * 1000))
+showLarge n | n >= 1000 * 1000 * 1000      = printf "%.1f billion"  (n / (1000 * 1000 * 1000))
+showLarge n | n >= 10 * 1000 * 1000        = printf "%.0f million"  (n / (1000 * 1000))
+showLarge n | n >= 1000 * 1000             = printf "%.1f million"  (n / (1000 * 1000))
+showLarge n | n >= 10 * 1000               = printf "%.0f thousand" (n / 1000)
+showLarge n | n >= 10                      = unpack $ commasF 0 n
+showLarge n                                = printf "%.3f" n
+
+countdownWidget :: Bool -> Bool -> LocalTime -> Widget n
+countdownWidget showConversion isSimulated t =
+  (border $ vBox [
+    (hCenter $ hBox
+     [ countdownBox
+     , currentTimeBox
+     , cosmicTimeBox
+     ])
+    ,
+    str "\n"
+    ,
+    (borderWithLabel (str progressLabel) $
+            updateAttrMap
+            (A.mapAttrName yDoneAttr P.progressCompleteAttr .
+             A.mapAttrName yToDoAttr P.progressIncompleteAttr) $
+            progressBar Nothing (realToFrac $ yearElapsed // yearLength))
+    ])
+    <=>
+    str "\n"
+    <=>
+    hCenter (hBox [
+                -- TODO: accumulate all entries on today's date into one vBox
+                if currentEntryIsCurrent then
+                  (borderWithLabel (txt "Now on the Cosmic Calendar") currentEntry) <=>
+                  (fromMaybe (str "") $ fmap (borderWithLabel (txt "Next on the Cosmic Calendar")) nextEntryShort)
+                else
+                  borderWithLabel (txt "Next on the Cosmic Calendar") nextEntry,
+                -- vBox [ cosmicCalendarCurrent, txt "\n", cosmicCalendarNext ],
+                if showConversion
+                then
+                  str "   " <=> borderWithLabel (str "Cosmic Conversion") (hBox [cosmicConversion, cosmicConversion'])
+                else
+                  str ""
+    ])
+  where
+    -- TODO: We want to display "today" or "now" on the cosmic calendar;
+    -- We want to display what happened previously on the cosmic calendar
+    -- We want to say how long ago the previous happening was relative to today's date and today's place on the cosmic calendar
+    -- (E.g., if it's 1AM Jan 1, then we say the big bang was 1 hour ago and 1.6 million years ago)
+    -- We want to say similar for how long until the next happening
+    -- We also _may_ want to say the same thing for the current happening, depending on if it's an instant or a stage
+    -- If it's a stage, we want to say how long it lasts; how long since it started, and how long until it ends
+
+    currentEntryIsCurrent = fromMaybe True $ do
+      (LocalTime entryDay _) <- (`addLocalTime` yearStart t) . calBeginTime <$> getCurrentCalendarEntry theCalendar t
+      let (LocalTime nowDay _) = t
+      return $ entryDay == nowDay
+    currentEntry = fromMaybe (str "none") $ calendarWidget False <$> getCurrentCalendarEntry theCalendar t
+    nextEntry = fromMaybe (str "none") $ calendarWidget False <$> getNextCalendarEntry theCalendar t
+    nextEntryShort = fmap (str "\n" <=>) (calendarWidget True <$> getNextCalendarEntry theCalendar t)
+
+    calendarWidget short CalendarEntry{..} = box -- vBox [eventCountdown, str "\n", box]
+      where
+        timeUntilActive = (calBeginTime `addLocalTime` yearStart t) `diffLocalTime` t
+        eventCountdown = if timeUntilActive >= 0 then
+                          hBox [str $ "in " ++ showTime timeUntilActive,
+                                padLeft Max $ str $ "in " ++ showCosmicTime timeUntilActive]
+                        else
+                          hBox [str $ showTime (-timeUntilActive) ++ " ago",
+                                padLeft Max $ str $ showCosmicTime (-timeUntilActive) ++ " ago"]
+        years = fromRational $ toCosmicTime calBeginTime
+        box = vBox [
+          if currentEntryIsCurrent && not short
+          then str "\n"
+          else eventCountdown <=> str "\n",
+          hCenter $ txt calTitle,
+          hCenter $ txt calSubtitle,
+          str "\n",
+          hBox [
+            let cosmicSecondsAgo = nominalDiffTimeToSeconds (yearEnd cosmicCalendarT `diffLocalTime` cosmicCalendarT)
+                cosmicCalendarT = calBeginTime `addLocalTime` yearStart t
+            in vBox [
+              str $ formatTime defaultTimeLocale "%A, %B %e%n%Y-%m-%d %r" $ cosmicCalendarT,
+              -- TODO: Choose correct cosmic unit
+              str $ printf "%s cosmic second%s ago" (commasF' 1 cosmicSecondsAgo) (pluralize cosmicSecondsAgo)
+            ],
+            padLeft Max $ vBox [
+              str $ showLarge years ++ " years",
+              str $ printf "%s years ago" $ showLarge $ realToFrac (ageOfUniverseInYears - floor years)
+            ]
+          ],
+          -- str $ printf "%s years ago" (commas $ ageOfUniverseInYears - floor years),
+          if not short
+          then
+            str "\n" <=>
+            txtWrap calDescription
+          else
+            str ""
+          ]
+
+    strWhen b s = str $ if b then s else ""
+    countdownBox =
+      (borderWithLabel (str $ printf "Countdown %d" currentYear) $
+        vBox $
+        let secondsNow = 1 + toSeconds yearElapsed :: Int
+            secondsTotal = toSeconds yearLength
+        in
+          (str $ printf "Day %d of %d\nSecond %s of %s\n%s seconds remain"
+            dayNum
+            numDays
+            (commas secondsNow)
+            (commas secondsTotal)
+            (commas $ secondsTotal - secondsNow)
+          ) : remains
+        )
+    remains =
+        [
+          strWhen (hoursLeft >= 24) $
+          printf "%d day%s remain%s"
+          daysLeft
+          (pluralize daysLeft)
+          (pluralizeVerb daysLeft),
+
+          strWhen (hoursLeft < 24 && hoursLeft > 1) $
+          printf "%s hour%s remain%s"
+          (commasF 2 hoursLeft)
+          (pluralize $ (floor hoursLeft :: Integer))
+          (pluralizeVerb $ (floor hoursLeft :: Integer)),
+
+          strWhen (hoursLeft <= 1 && minutesLeft > 1) $
+          printf "%s minute%s remain%s"
+          (commasF 2 minutesLeft)
+          (pluralize $ (floor minutesLeft :: Integer))
+          (pluralizeVerb $ (floor minutesLeft :: Integer)),
+
+          strWhen (minutesLeft <= 1) $
+          printf "%s second%s remain%s"
+          (commasF' 1 secondsLeft)
+          (pluralize secondsLeft)
+          (pluralizeVerb secondsLeft)
+        ]
+
+    cosmicTimeBox =
+      (borderWithLabel (str "Cosmic Time") $
+       vBox [(str $ printf "%s years" (commas $ (floor cosmicYears :: Integer))),
+              str "\n",
+             (str $ printf "%s years ago" (commas $ (floor cosmicYearsAgo :: Integer)))
+            -- , (str $ printf "%s years ago" (showLarge $ (realToFrac cosmicYearsAgo)))
+            -- , (str $ printf "%s billion years ago" (commasF 9 $ cosmicYearsAgo / (1000*1000*1000)))
+            -- , (str $ printf "%s million years ago" (commasF 6 $ cosmicYearsAgo / (1000*1000)))
+            -- , (str $ printf "%s thousand years ago" (commasF 3 $ cosmicYearsAgo / 1000))
+            -- , (str $ printf "%s days ago" (commas $ (floor $ realToFrac cosmicYearsAgo * daysPerYear :: Integer)))
+            ])
+    currentTimeBox = (hCenter (borderWithLabel (str $ printf "Current time%s" (if isSimulated then " (SIMULATED)" else "" :: String)) $
+                               padLeftRight 3 $ (str (formatTime defaultTimeLocale "%A, %B %e%n%Y-%m-%d %r" t))))
+    cosmicYears    = realToFrac ageOfUniverseInYears * (realToFrac $ (yearElapsed // yearLength)) :: Rational
+    cosmicYearsAgo = realToFrac ageOfUniverseInYears * (realToFrac $ 1 - (yearElapsed // yearLength)) :: Rational
+    -- cosmicYearsAgo = if yearElapsed == yearLength
+    --                  then 0
+    --                  else realToFrac ageOfUniverseInYears * (realToFrac $ 1 - (yearElapsed // yearLength)) :: Rational
+    currentYear    = yearNumber t
+    dayNum         = dayNumOfYear t
+    numDays        = daysInYear t
+    -- yearLength     = fromIntegral numDays * nominalDay
+    yearLength     = yearEnd t `diffLocalTime` yearStart t
+    yearElapsed    = t `diffLocalTime` yearStart t
+
+    daysLeft       = numDays - dayNum
+    hoursLeft      = minutesLeft / 60
+    minutesLeft    = fromRational $ toRational secondsLeft / 60 :: Double
+    toSeconds      = floor . nominalDiffTimeToSeconds
+    secondsLeft    = nominalDiffTimeToSeconds (yearLength - yearElapsed)
+    x // y         = fromRational $ toRational x / toRational y :: Double
+    progressLabel  = printf "%.6F%%" (100 * (yearElapsed // yearLength))
+
+commasF' 1 n = if (floor (n * 10) `mod` 10 :: Int) == 0 then commasF 0 n `Text.append` "  " else commasF 1 n
+commasF' p n = commasF p n
+
+commasF', commasF :: RealFrac x => Int -> x -> Text
+commasF precision = prettyF cfg
+  where
+    cfg = PrettyCfg precision (Just ',') '.'
+
+commas :: Integral i => i -> Text
+commas = prettyI (Just ',') . fromIntegral
+
+nextTenthOfSecond :: ZonedTime -> ZonedTime
+nextTenthOfSecond (ZonedTime (LocalTime day (TimeOfDay h m s)) z) = (ZonedTime (LocalTime day (TimeOfDay h m s')) z)
+  where
+    s' = fromRational $ toRational (floor (s * 10) + 1 :: Integer) / 10
+
+nextWholeSecond :: ZonedTime -> ZonedTime
+nextWholeSecond (ZonedTime (LocalTime day (TimeOfDay h m s)) z) = (ZonedTime (LocalTime day (TimeOfDay h m s')) z)
+  where
+    s' = fromIntegral $ (floor s + 1 :: Int)
+
+diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime
+diffZonedTime = diffLocalTime `Prelude.on` zonedTimeToLocalTime
+
+isNewYearsEve :: LocalTime -> Bool
+isNewYearsEve t = dayNumOfYear t == daysInYear t
+
+queueNextEvent :: MonadIO m => Bool -> BChan CustomEvent -> m ZonedTime
+queueNextEvent hyper chan = liftIO $ do
+  now <- getZonedTime
+  void . forkIO $ do
+
+    let getNext = if hyper then nextTenthOfSecond else nextWholeSecond
+        next = getNext now
+        delay = next `diffZonedTime` now
+    threadDelay $ floor $ delay * 1000 * 1000
+    writeBChan chan $ TimeChanged next
+  return now
+
+isSimulatedTime :: St -> Bool
+isSimulatedTime st = st ^. stDisplayTime /= st ^. stClockTime
+
+nextCalendarEntryTime :: LocalTime -> LocalTime
+nextCalendarEntryTime t = fromMaybe t $ getNextCalendarEntry theCalendar t <&> (`addLocalTime` yearStart t) . calBeginTime
+
+previousCalendarEntryTime :: LocalTime -> LocalTime
+previousCalendarEntryTime t = fromMaybe t $ goBack t
+  where
+    goBack t = getPreviousCalendarEntry theCalendar t <&> (`addLocalTime` yearStart t) . calBeginTime
+
+handleEvent :: BChan CustomEvent -> St -> BrickEvent () CustomEvent -> EventM () (Next St)
+handleEvent chan st e =
+    case e of
+        VtyEvent (V.EvKey V.KEsc [])            -> halt st
+        VtyEvent (V.EvKey (V.KChar 'p') [])     -> cont $ st & stPaused %~ not
+        VtyEvent (V.EvKey (V.KFun 1) [])        -> cont $ st & stPaused %~ not
+
+        VtyEvent (V.EvKey V.KRight [MShift])    -> cont $ st & stDisplayTime %~ (addLocalTime (1))
+        VtyEvent (V.EvKey V.KLeft [MShift])     -> cont $ st & stDisplayTime %~ (addLocalTime (-1))
+
+        VtyEvent (V.EvKey V.KRight [MCtrl])     -> cont $ st & stDisplayTime %~ (addLocalTime (60))
+        VtyEvent (V.EvKey V.KLeft [MCtrl])      -> cont $ st & stDisplayTime %~ (addLocalTime (-60))
+
+        VtyEvent (V.EvKey V.KPageDown [MCtrl])  -> cont $ st & stDisplayTime %~ (addLocalTime (60 * 60))
+        VtyEvent (V.EvKey V.KPageUp [MCtrl])    -> cont $ st & stDisplayTime %~ (addLocalTime (-60 * 60))
+        VtyEvent (V.EvKey V.KPageDown [])       -> cont $ st & stDisplayTime %~ (addLocalTime lengthOfDay)
+        VtyEvent (V.EvKey V.KPageUp [])         -> cont $ st & stDisplayTime %~ (addLocalTime (-lengthOfDay))
+
+        VtyEvent (V.EvKey V.KHome [])           -> cont $ st & stDisplayTime .~ (st ^. stClockTime)
+        VtyEvent (V.EvKey V.KHome [MShift])     -> cont $ st & stDisplayTime .~ (yearStart $ st ^. stClockTime)
+        VtyEvent (V.EvKey V.KEnd [])            -> cont $ st & stDisplayTime .~ (newYearsEveLast10 $ st ^. stClockTime)
+        VtyEvent (V.EvKey V.KEnd [MShift])      -> cont $ st & stDisplayTime .~ (yearEnd $ st ^. stClockTime)
+        VtyEvent (V.EvKey V.KEnd [MCtrl])       -> cont $ st & stDisplayTime .~ (newYearsEveNoon $ st ^. stClockTime)
+
+        VtyEvent (V.EvKey V.KRight [])          -> cont $ st & stDisplayTime %~ nextCalendarEntryTime
+        VtyEvent (V.EvKey V.KLeft [])           -> cont $ st & stDisplayTime %~ previousCalendarEntryTime
+        VtyEvent (V.EvKey (V.KChar '.') [])     -> cont $ st & stDisplayTime %~ nextCalendarEntryTime
+        VtyEvent (V.EvKey (V.KChar ',') [])     -> cont $ st & stDisplayTime %~ previousCalendarEntryTime
+
+        VtyEvent (V.EvKey (V.KChar 'c') [])     -> cont $ st & stShowConversion %~ not
+        VtyEvent (V.EvKey (V.KFun 2) [])        -> cont $ st & stShowConversion %~ not
+
+        VtyEvent _                              -> cont st
+        AppEvent (TimeChanged now) -> do
+          let hyper = isNewYearsEve $ st ^. stDisplayTime
+          void $ queueNextEvent hyper chan
+          let oldTime = st ^. stClockTime
+          cont $ st & stClockTime .~ (zonedTimeToLocalTime now)
+                    & stDisplayTime %~ if st ^. stPaused then id else addLocalTime $ zonedTimeToLocalTime now `diffLocalTime` oldTime
+        _ -> cont st
+    where
+      cont s = do
+        continue $ s & stLastBrickEvent .~ (Just e)
+
+newYearsEveLast10 :: LocalTime -> LocalTime
+newYearsEveLast10 = addLocalTime (-11) . yearEnd
+
+newYearsEveNoon :: LocalTime -> LocalTime
+newYearsEveNoon (LocalTime d (TimeOfDay _ _ s)) = LocalTime d' t
+  where
+    (y, _) = toOrdinalDate d
+    d' = fromOrdinalDate y 366
+    t = TimeOfDay 12 0 s'
+    s' = s `mod'` 1 -- keep the fractional part so we still tick the display on the same schedule
+
+initialState :: LocalTime -> St
+initialState t =
+    St { _stLastBrickEvent = Nothing
+       , _stClockTime = t
+       , _stDisplayTime = t
+       , _stNextEvent = Nothing
+       , _stPaused = False
+       , _stShowConversion = False
+       }
+
+daysInYear :: LocalTime -> Int
+daysInYear (toGregorian . localDay -> (y, _, _)) = if isLeapYear y then 366 else 365
+
+theBaseAttr :: A.AttrName
+theBaseAttr = A.attrName "theBase"
+
+xDoneAttr, xToDoAttr :: A.AttrName
+xDoneAttr = theBaseAttr <> A.attrName "X:done"
+xToDoAttr = theBaseAttr <> A.attrName "X:remaining"
+
+yDoneAttr, yToDoAttr :: A.AttrName
+yDoneAttr = theBaseAttr <> A.attrName "Y:done"
+yToDoAttr = theBaseAttr <> A.attrName "Y:remaining"
+
+zDoneAttr, zToDoAttr :: A.AttrName
+zDoneAttr = theBaseAttr <> A.attrName "Z:done"
+zToDoAttr = theBaseAttr <> A.attrName "Z:remaining"
+
+theMap :: A.AttrMap
+theMap = A.attrMap V.defAttr
+         [ (theBaseAttr,               bg V.brightBlack)
+         , (xDoneAttr,                 V.black `on` V.white)
+         , (xToDoAttr,                 V.white `on` V.black)
+         , (yDoneAttr,                 V.magenta `on` V.yellow)
+         , (zDoneAttr,                 V.blue `on` V.green)
+         , (zToDoAttr,                 V.blue `on` V.red)
+         , (P.progressIncompleteAttr,  fg V.yellow)
+         ]
+
+theApp :: BChan CustomEvent -> App St CustomEvent ()
+theApp chan =
+    App { appDraw = drawUI
+        , appChooseCursor = showFirstCursor
+        , appHandleEvent = handleEvent chan
+        , appStartEvent = return
+        , appAttrMap = const theMap
+        }
+
+main :: IO ()
+main = do
+    chan <- newBChan 10
+
+    let buildVty = V.mkVty V.defaultConfig
+    initialVty <- buildVty
+    now <- queueNextEvent False chan
+    void $ customMain initialVty buildVty (Just chan) (theApp chan) (initialState $ zonedTimeToLocalTime now)