#!/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 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)