diff options
Diffstat (limited to 'src/countdown.hs')
-rwxr-xr-x | src/countdown.hs | 523 |
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 @@ | |||
1 | #!/usr/bin/env stack | ||
2 | {- stack script --resolver lts-19.23 --install-ghc -} | ||
3 | {-# OPTIONS_GHC | ||
4 | -Wall | ||
5 | -Wno-unused-imports | ||
6 | -Wno-unused-top-binds | ||
7 | -Wno-name-shadowing | ||
8 | #-} | ||
9 | {-# language NoImplicitPrelude #-} | ||
10 | {-# language RecordWildCards #-} | ||
11 | {-# language FlexibleContexts #-} | ||
12 | {-# language TemplateHaskell #-} | ||
13 | {-# language ViewPatterns #-} | ||
14 | {-# language OverloadedStrings #-} | ||
15 | import Rebase.Prelude hiding (toList, on, (<+>), Max) | ||
16 | import qualified Rebase.Prelude as Prelude | ||
17 | import Control.Lens hiding ((<|)) | ||
18 | import Data.Foldable (toList) | ||
19 | import Data.Ratio | ||
20 | import Text.Printf | ||
21 | import Graphics.Vty | ||
22 | import Data.Time.LocalTime | ||
23 | import Control.Monad.RWS | ||
24 | import Data.Time.Calendar.OrdinalDate | ||
25 | import qualified Data.Text as Text | ||
26 | import Data.Text.Format.Numbers | ||
27 | import Rebase.Data.Map.Strict (Map) | ||
28 | import qualified Rebase.Data.Map.Strict as Map | ||
29 | |||
30 | import Brick | ||
31 | import Brick.Types | ||
32 | import Data.Text (unpack) | ||
33 | import Control.Lens | ||
34 | import Control.Monad (void, forever) | ||
35 | import Control.Concurrent (threadDelay, forkIO) | ||
36 | import qualified Graphics.Vty as V | ||
37 | import Brick.Widgets.ProgressBar as P | ||
38 | import Brick.BChan | ||
39 | import Brick.Widgets.Center | ||
40 | import Brick.Widgets.Border | ||
41 | import Brick.Main | ||
42 | ( App(..) | ||
43 | , showFirstCursor | ||
44 | , customMain | ||
45 | , continue | ||
46 | , halt | ||
47 | ) | ||
48 | import Brick.AttrMap | ||
49 | ( attrMap | ||
50 | ) | ||
51 | import Brick.Types | ||
52 | ( Widget | ||
53 | , Next | ||
54 | , EventM | ||
55 | , BrickEvent(..) | ||
56 | ) | ||
57 | import Brick.Widgets.Core | ||
58 | ( (<=>) | ||
59 | , str | ||
60 | ) | ||
61 | import Brick.AttrMap as A | ||
62 | import Brick.Util (fg, bg, on, clamp) | ||
63 | import Brick.Widgets.Core | ||
64 | import Brick.Widgets.Table | ||
65 | |||
66 | import CosmicCalendar | ||
67 | import CosmicCalendarEvents | ||
68 | |||
69 | data CustomEvent = TimeChanged ZonedTime deriving Show | ||
70 | |||
71 | data St = | ||
72 | St { _stLastBrickEvent :: Maybe (BrickEvent () CustomEvent) | ||
73 | , _stClockTime :: LocalTime | ||
74 | , _stDisplayTime :: LocalTime | ||
75 | , _stNextEvent :: Maybe UTCTime | ||
76 | , _stPaused :: Bool | ||
77 | , _stShowConversion :: Bool | ||
78 | } | ||
79 | |||
80 | makeLenses ''St | ||
81 | |||
82 | yearNumber :: LocalTime -> Integer | ||
83 | yearNumber (LocalTime t _) = y | ||
84 | where | ||
85 | (y, _, _) = toGregorian t | ||
86 | |||
87 | yearEnd :: LocalTime -> LocalTime | ||
88 | yearEnd (LocalTime d _) = LocalTime d' t' | ||
89 | where | ||
90 | d' = fromGregorian (y + 1) 1 1 | ||
91 | t' = TimeOfDay 0 0 0 | ||
92 | (y, _, _) = toGregorian d | ||
93 | |||
94 | |||
95 | dayNumOfYear :: LocalTime -> Int | ||
96 | dayNumOfYear = snd . toOrdinalDate . localDay | ||
97 | |||
98 | pluralize :: (Num n, Eq n) => n -> String | ||
99 | pluralize 1 = "" | ||
100 | pluralize _ = "s" | ||
101 | |||
102 | pluralizeVerb :: (Num n, Eq n) => n -> String | ||
103 | pluralizeVerb 1 = "s" | ||
104 | pluralizeVerb _ = "" | ||
105 | |||
106 | drawUI :: St -> [Widget ()] | ||
107 | drawUI st = [a] | ||
108 | where | ||
109 | a = vBox [ | ||
110 | -- (str $ "Last event: " <> (show $ st ^. stLastBrickEvent)), | ||
111 | -- (str "\n"), | ||
112 | (str "\n"), | ||
113 | (countdownWidget (st ^. stShowConversion) (isSimulatedTime st) $ st ^. stDisplayTime) | ||
114 | ] | ||
115 | |||
116 | showTime' :: Bool -> NominalDiffTime -> String | ||
117 | showTime' True 1 = printf "%-3s second" ("1" :: Text) | ||
118 | showTime' True t | t < 60 = printf "%.1f seconds" (realToFrac t :: Float) | ||
119 | showTime' _ t = showTime t | ||
120 | |||
121 | showTime :: NominalDiffTime -> String | ||
122 | showTime t | t < 1 = printf "%.3f seconds" (realToFrac t :: Float) | ||
123 | showTime t | t == 1 = "1 second" | ||
124 | -- showTime t | t < 10 = formatTime defaultTimeLocale "%2Es seconds" t -- BUG! Doesn't respect <width> parameter at all! | ||
125 | showTime t | t < 60 = printf "%.1f seconds" (realToFrac t :: Float) | ||
126 | showTime t | t == 60 = formatTime defaultTimeLocale "%M minute" t | ||
127 | showTime t | t < 60*2 = formatTime defaultTimeLocale "%M minute %Ss" t | ||
128 | showTime t | t < 60*10 = formatTime defaultTimeLocale "%M minutes %Ss" t | ||
129 | showTime t | t < 60*60 = formatTime defaultTimeLocale "%M minutes" t | ||
130 | showTime t | t == 60*60 = "1 hour" | ||
131 | showTime t | t < 60*60*2 = formatTime defaultTimeLocale "%H hour %Mm" t | ||
132 | showTime t | t < 60*60*24 = formatTime defaultTimeLocale "%H hours %Mm" t | ||
133 | showTime t | t == 60*60*24 = formatTime defaultTimeLocale "%d day" t | ||
134 | showTime t | t < 60*60*24*2 = formatTime defaultTimeLocale "%d day %Hh" t | ||
135 | showTime t | t == 60*60*24*7 = formatTime defaultTimeLocale "%d days" t | ||
136 | showTime t | t < 60*60*24*10 = formatTime defaultTimeLocale "%d days %Hh" t | ||
137 | showTime t = formatTime defaultTimeLocale "%d days" t | ||
138 | -- showTime _ t = formatTime defaultTimeLocale "%w weeks %D days" t | ||
139 | |||
140 | yearsToCosmicTime :: Integral i => i -> NominalDiffTime | ||
141 | yearsToCosmicTime = (/ (realToFrac ageOfUniverseInYears)) . (* lengthOfYear) . realToFrac | ||
142 | |||
143 | showCosmicYears :: Integer -> Widget n | ||
144 | showCosmicYears = str . showTime . yearsToCosmicTime | ||
145 | |||
146 | toCosmicTime :: NominalDiffTime -> Rational | ||
147 | toCosmicTime t = realToFrac ageOfUniverseInYears * (realToFrac $ t // yearLength) :: Rational | ||
148 | where | ||
149 | yearLength = daysPerYear * nominalDay | ||
150 | x // y = fromRational $ toRational x / toRational y :: Double | ||
151 | |||
152 | showCosmicTime :: NominalDiffTime -> String | ||
153 | showCosmicTime n = showLarge (fromRational $ toCosmicTime n) ++ " years" | ||
154 | |||
155 | conversionTableRowFromCosmicSeconds :: NominalDiffTime -> [Widget n] | ||
156 | conversionTableRowFromCosmicSeconds n = [cosmicTime, realTime] | ||
157 | where | ||
158 | realTime = str $ showCosmicTime n | ||
159 | cosmicTime = str $ showTime n | ||
160 | |||
161 | cosmicConversion' :: Widget n | ||
162 | cosmicConversion' = renderTable $ | ||
163 | table | ||
164 | [ | ||
165 | conversionTableRowFromCosmicSeconds $ 30 * 24 * 60 * 60, | ||
166 | conversionTableRowFromCosmicSeconds $ 7 * 24 * 60 * 60, | ||
167 | conversionTableRowFromCosmicSeconds $ 24 * 60 * 60, | ||
168 | conversionTableRowFromCosmicSeconds $ 60 * 60, | ||
169 | conversionTableRowFromCosmicSeconds $ 60, | ||
170 | conversionTableRowFromCosmicSeconds $ 1 | ||
171 | ] | ||
172 | |||
173 | cosmicConversion :: Widget n | ||
174 | cosmicConversion = renderTable $ | ||
175 | table | ||
176 | [ | ||
177 | [str "1 billion years" , showCosmicYears $ 1000 * 1000 * 1000], | ||
178 | [str "100 million years" , showCosmicYears $ 100 * 1000 * 1000], | ||
179 | [str "10 million years" , showCosmicYears $ 10 * 1000 * 1000], | ||
180 | [str "1 million years" , showCosmicYears $ 1000 * 1000], | ||
181 | [str "100 thousand years" , showCosmicYears $ 100 * 1000], | ||
182 | [str "10 thousand years" , showCosmicYears $ 10 * 1000], | ||
183 | [str "1 thousand years" , showCosmicYears 1000], | ||
184 | [str "100 years" , showCosmicYears 100], | ||
185 | [str "10 years" , showCosmicYears 10], | ||
186 | [str "1 year" , showCosmicYears 1] | ||
187 | ] | ||
188 | |||
189 | showLarge :: Double -> String | ||
190 | showLarge n | n >= 10 * 1000 * 1000 * 1000 = printf "%.0f billion" (n / (1000 * 1000 * 1000)) | ||
191 | showLarge n | n >= 1000 * 1000 * 1000 = printf "%.1f billion" (n / (1000 * 1000 * 1000)) | ||
192 | showLarge n | n >= 10 * 1000 * 1000 = printf "%.0f million" (n / (1000 * 1000)) | ||
193 | showLarge n | n >= 1000 * 1000 = printf "%.1f million" (n / (1000 * 1000)) | ||
194 | showLarge n | n >= 10 * 1000 = printf "%.0f thousand" (n / 1000) | ||
195 | showLarge n | n >= 10 = unpack $ commasF 0 n | ||
196 | showLarge n = printf "%.3f" n | ||
197 | |||
198 | countdownWidget :: Bool -> Bool -> LocalTime -> Widget n | ||
199 | countdownWidget showConversion isSimulated t = | ||
200 | (border $ vBox [ | ||
201 | (hCenter $ hBox | ||
202 | [ countdownBox | ||
203 | , currentTimeBox | ||
204 | , cosmicTimeBox | ||
205 | ]) | ||
206 | , | ||
207 | str "\n" | ||
208 | , | ||
209 | (borderWithLabel (str progressLabel) $ | ||
210 | updateAttrMap | ||
211 | (A.mapAttrName yDoneAttr P.progressCompleteAttr . | ||
212 | A.mapAttrName yToDoAttr P.progressIncompleteAttr) $ | ||
213 | progressBar Nothing (realToFrac $ yearElapsed // yearLength)) | ||
214 | ]) | ||
215 | <=> | ||
216 | str "\n" | ||
217 | <=> | ||
218 | hCenter (hBox [ | ||
219 | -- TODO: accumulate all entries on today's date into one vBox | ||
220 | if currentEntryIsCurrent then | ||
221 | (borderWithLabel (txt "Now on the Cosmic Calendar") currentEntry) <=> | ||
222 | (fromMaybe (str "") $ fmap (borderWithLabel (txt "Next on the Cosmic Calendar")) nextEntryShort) | ||
223 | else | ||
224 | borderWithLabel (txt "Next on the Cosmic Calendar") nextEntry, | ||
225 | -- vBox [ cosmicCalendarCurrent, txt "\n", cosmicCalendarNext ], | ||
226 | if showConversion | ||
227 | then | ||
228 | str " " <=> borderWithLabel (str "Cosmic Conversion") (hBox [cosmicConversion, cosmicConversion']) | ||
229 | else | ||
230 | str "" | ||
231 | ]) | ||
232 | where | ||
233 | -- TODO: We want to display "today" or "now" on the cosmic calendar; | ||
234 | -- We want to display what happened previously on the cosmic calendar | ||
235 | -- We want to say how long ago the previous happening was relative to today's date and today's place on the cosmic calendar | ||
236 | -- (E.g., if it's 1AM Jan 1, then we say the big bang was 1 hour ago and 1.6 million years ago) | ||
237 | -- We want to say similar for how long until the next happening | ||
238 | -- We also _may_ want to say the same thing for the current happening, depending on if it's an instant or a stage | ||
239 | -- If it's a stage, we want to say how long it lasts; how long since it started, and how long until it ends | ||
240 | |||
241 | currentEntryIsCurrent = fromMaybe True $ do | ||
242 | (LocalTime entryDay _) <- (`addLocalTime` yearStart t) . calBeginTime <$> getCurrentCalendarEntry theCalendar t | ||
243 | let (LocalTime nowDay _) = t | ||
244 | return $ entryDay == nowDay | ||
245 | currentEntry = fromMaybe (str "none") $ calendarWidget False <$> getCurrentCalendarEntry theCalendar t | ||
246 | nextEntry = fromMaybe (str "none") $ calendarWidget False <$> getNextCalendarEntry theCalendar t | ||
247 | nextEntryShort = fmap (str "\n" <=>) (calendarWidget True <$> getNextCalendarEntry theCalendar t) | ||
248 | |||
249 | calendarWidget short CalendarEntry{..} = box -- vBox [eventCountdown, str "\n", box] | ||
250 | where | ||
251 | timeUntilActive = (calBeginTime `addLocalTime` yearStart t) `diffLocalTime` t | ||
252 | eventCountdown = if timeUntilActive >= 0 then | ||
253 | hBox [str $ "in " ++ showTime timeUntilActive, | ||
254 | padLeft Max $ str $ "in " ++ showCosmicTime timeUntilActive] | ||
255 | else | ||
256 | hBox [str $ showTime (-timeUntilActive) ++ " ago", | ||
257 | padLeft Max $ str $ showCosmicTime (-timeUntilActive) ++ " ago"] | ||
258 | years = fromRational $ toCosmicTime calBeginTime | ||
259 | box = vBox [ | ||
260 | if currentEntryIsCurrent && not short | ||
261 | then str "\n" | ||
262 | else eventCountdown <=> str "\n", | ||
263 | hCenter $ txt calTitle, | ||
264 | hCenter $ txt calSubtitle, | ||
265 | str "\n", | ||
266 | hBox [ | ||
267 | let cosmicSecondsAgo = nominalDiffTimeToSeconds (yearEnd cosmicCalendarT `diffLocalTime` cosmicCalendarT) | ||
268 | cosmicCalendarT = calBeginTime `addLocalTime` yearStart t | ||
269 | in vBox [ | ||
270 | str $ formatTime defaultTimeLocale "%A, %B %e%n%Y-%m-%d %r" $ cosmicCalendarT, | ||
271 | -- TODO: Choose correct cosmic unit | ||
272 | str $ printf "%s cosmic second%s ago" (commasF' 1 cosmicSecondsAgo) (pluralize cosmicSecondsAgo) | ||
273 | ], | ||
274 | padLeft Max $ vBox [ | ||
275 | str $ showLarge years ++ " years", | ||
276 | str $ printf "%s years ago" $ showLarge $ realToFrac (ageOfUniverseInYears - floor years) | ||
277 | ] | ||
278 | ], | ||
279 | -- str $ printf "%s years ago" (commas $ ageOfUniverseInYears - floor years), | ||
280 | if not short | ||
281 | then | ||
282 | str "\n" <=> | ||
283 | txtWrap calDescription | ||
284 | else | ||
285 | str "" | ||
286 | ] | ||
287 | |||
288 | strWhen b s = str $ if b then s else "" | ||
289 | countdownBox = | ||
290 | (borderWithLabel (str $ printf "Countdown %d" currentYear) $ | ||
291 | vBox $ | ||
292 | let secondsNow = 1 + toSeconds yearElapsed :: Int | ||
293 | secondsTotal = toSeconds yearLength | ||
294 | in | ||
295 | (str $ printf "Day %d of %d\nSecond %s of %s\n%s seconds remain" | ||
296 | dayNum | ||
297 | numDays | ||
298 | (commas secondsNow) | ||
299 | (commas secondsTotal) | ||
300 | (commas $ secondsTotal - secondsNow) | ||
301 | ) : remains | ||
302 | ) | ||
303 | remains = | ||
304 | [ | ||
305 | strWhen (hoursLeft >= 24) $ | ||
306 | printf "%d day%s remain%s" | ||
307 | daysLeft | ||
308 | (pluralize daysLeft) | ||
309 | (pluralizeVerb daysLeft), | ||
310 | |||
311 | strWhen (hoursLeft < 24 && hoursLeft > 1) $ | ||
312 | printf "%s hour%s remain%s" | ||
313 | (commasF 2 hoursLeft) | ||
314 | (pluralize $ (floor hoursLeft :: Integer)) | ||
315 | (pluralizeVerb $ (floor hoursLeft :: Integer)), | ||
316 | |||
317 | strWhen (hoursLeft <= 1 && minutesLeft > 1) $ | ||
318 | printf "%s minute%s remain%s" | ||
319 | (commasF 2 minutesLeft) | ||
320 | (pluralize $ (floor minutesLeft :: Integer)) | ||
321 | (pluralizeVerb $ (floor minutesLeft :: Integer)), | ||
322 | |||
323 | strWhen (minutesLeft <= 1) $ | ||
324 | printf "%s second%s remain%s" | ||
325 | (commasF' 1 secondsLeft) | ||
326 | (pluralize secondsLeft) | ||
327 | (pluralizeVerb secondsLeft) | ||
328 | ] | ||
329 | |||
330 | cosmicTimeBox = | ||
331 | (borderWithLabel (str "Cosmic Time") $ | ||
332 | vBox [(str $ printf "%s years" (commas $ (floor cosmicYears :: Integer))), | ||
333 | str "\n", | ||
334 | (str $ printf "%s years ago" (commas $ (floor cosmicYearsAgo :: Integer))) | ||
335 | -- , (str $ printf "%s years ago" (showLarge $ (realToFrac cosmicYearsAgo))) | ||
336 | -- , (str $ printf "%s billion years ago" (commasF 9 $ cosmicYearsAgo / (1000*1000*1000))) | ||
337 | -- , (str $ printf "%s million years ago" (commasF 6 $ cosmicYearsAgo / (1000*1000))) | ||
338 | -- , (str $ printf "%s thousand years ago" (commasF 3 $ cosmicYearsAgo / 1000)) | ||
339 | -- , (str $ printf "%s days ago" (commas $ (floor $ realToFrac cosmicYearsAgo * daysPerYear :: Integer))) | ||
340 | ]) | ||
341 | currentTimeBox = (hCenter (borderWithLabel (str $ printf "Current time%s" (if isSimulated then " (SIMULATED)" else "" :: String)) $ | ||
342 | padLeftRight 3 $ (str (formatTime defaultTimeLocale "%A, %B %e%n%Y-%m-%d %r" t)))) | ||
343 | cosmicYears = realToFrac ageOfUniverseInYears * (realToFrac $ (yearElapsed // yearLength)) :: Rational | ||
344 | cosmicYearsAgo = realToFrac ageOfUniverseInYears * (realToFrac $ 1 - (yearElapsed // yearLength)) :: Rational | ||
345 | -- cosmicYearsAgo = if yearElapsed == yearLength | ||
346 | -- then 0 | ||
347 | -- else realToFrac ageOfUniverseInYears * (realToFrac $ 1 - (yearElapsed // yearLength)) :: Rational | ||
348 | currentYear = yearNumber t | ||
349 | dayNum = dayNumOfYear t | ||
350 | numDays = daysInYear t | ||
351 | -- yearLength = fromIntegral numDays * nominalDay | ||
352 | yearLength = yearEnd t `diffLocalTime` yearStart t | ||
353 | yearElapsed = t `diffLocalTime` yearStart t | ||
354 | |||
355 | daysLeft = numDays - dayNum | ||
356 | hoursLeft = minutesLeft / 60 | ||
357 | minutesLeft = fromRational $ toRational secondsLeft / 60 :: Double | ||
358 | toSeconds = floor . nominalDiffTimeToSeconds | ||
359 | secondsLeft = nominalDiffTimeToSeconds (yearLength - yearElapsed) | ||
360 | x // y = fromRational $ toRational x / toRational y :: Double | ||
361 | progressLabel = printf "%.6F%%" (100 * (yearElapsed // yearLength)) | ||
362 | |||
363 | commasF' 1 n = if (floor (n * 10) `mod` 10 :: Int) == 0 then commasF 0 n `Text.append` " " else commasF 1 n | ||
364 | commasF' p n = commasF p n | ||
365 | |||
366 | commasF', commasF :: RealFrac x => Int -> x -> Text | ||
367 | commasF precision = prettyF cfg | ||
368 | where | ||
369 | cfg = PrettyCfg precision (Just ',') '.' | ||
370 | |||
371 | commas :: Integral i => i -> Text | ||
372 | commas = prettyI (Just ',') . fromIntegral | ||
373 | |||
374 | nextTenthOfSecond :: ZonedTime -> ZonedTime | ||
375 | nextTenthOfSecond (ZonedTime (LocalTime day (TimeOfDay h m s)) z) = (ZonedTime (LocalTime day (TimeOfDay h m s')) z) | ||
376 | where | ||
377 | s' = fromRational $ toRational (floor (s * 10) + 1 :: Integer) / 10 | ||
378 | |||
379 | nextWholeSecond :: ZonedTime -> ZonedTime | ||
380 | nextWholeSecond (ZonedTime (LocalTime day (TimeOfDay h m s)) z) = (ZonedTime (LocalTime day (TimeOfDay h m s')) z) | ||
381 | where | ||
382 | s' = fromIntegral $ (floor s + 1 :: Int) | ||
383 | |||
384 | diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime | ||
385 | diffZonedTime = diffLocalTime `Prelude.on` zonedTimeToLocalTime | ||
386 | |||
387 | isNewYearsEve :: LocalTime -> Bool | ||
388 | isNewYearsEve t = dayNumOfYear t == daysInYear t | ||
389 | |||
390 | queueNextEvent :: MonadIO m => Bool -> BChan CustomEvent -> m ZonedTime | ||
391 | queueNextEvent hyper chan = liftIO $ do | ||
392 | now <- getZonedTime | ||
393 | void . forkIO $ do | ||
394 | |||
395 | let getNext = if hyper then nextTenthOfSecond else nextWholeSecond | ||
396 | next = getNext now | ||
397 | delay = next `diffZonedTime` now | ||
398 | threadDelay $ floor $ delay * 1000 * 1000 | ||
399 | writeBChan chan $ TimeChanged next | ||
400 | return now | ||
401 | |||
402 | isSimulatedTime :: St -> Bool | ||
403 | isSimulatedTime st = st ^. stDisplayTime /= st ^. stClockTime | ||
404 | |||
405 | nextCalendarEntryTime :: LocalTime -> LocalTime | ||
406 | nextCalendarEntryTime t = fromMaybe t $ getNextCalendarEntry theCalendar t <&> (`addLocalTime` yearStart t) . calBeginTime | ||
407 | |||
408 | previousCalendarEntryTime :: LocalTime -> LocalTime | ||
409 | previousCalendarEntryTime t = fromMaybe t $ goBack t | ||
410 | where | ||
411 | goBack t = getPreviousCalendarEntry theCalendar t <&> (`addLocalTime` yearStart t) . calBeginTime | ||
412 | |||
413 | handleEvent :: BChan CustomEvent -> St -> BrickEvent () CustomEvent -> EventM () (Next St) | ||
414 | handleEvent chan st e = | ||
415 | case e of | ||
416 | VtyEvent (V.EvKey V.KEsc []) -> halt st | ||
417 | VtyEvent (V.EvKey (V.KChar 'p') []) -> cont $ st & stPaused %~ not | ||
418 | VtyEvent (V.EvKey (V.KFun 1) []) -> cont $ st & stPaused %~ not | ||
419 | |||
420 | VtyEvent (V.EvKey V.KRight [MShift]) -> cont $ st & stDisplayTime %~ (addLocalTime (1)) | ||
421 | VtyEvent (V.EvKey V.KLeft [MShift]) -> cont $ st & stDisplayTime %~ (addLocalTime (-1)) | ||
422 | |||
423 | VtyEvent (V.EvKey V.KRight [MCtrl]) -> cont $ st & stDisplayTime %~ (addLocalTime (60)) | ||
424 | VtyEvent (V.EvKey V.KLeft [MCtrl]) -> cont $ st & stDisplayTime %~ (addLocalTime (-60)) | ||
425 | |||
426 | VtyEvent (V.EvKey V.KPageDown [MCtrl]) -> cont $ st & stDisplayTime %~ (addLocalTime (60 * 60)) | ||
427 | VtyEvent (V.EvKey V.KPageUp [MCtrl]) -> cont $ st & stDisplayTime %~ (addLocalTime (-60 * 60)) | ||
428 | VtyEvent (V.EvKey V.KPageDown []) -> cont $ st & stDisplayTime %~ (addLocalTime lengthOfDay) | ||
429 | VtyEvent (V.EvKey V.KPageUp []) -> cont $ st & stDisplayTime %~ (addLocalTime (-lengthOfDay)) | ||
430 | |||
431 | VtyEvent (V.EvKey V.KHome []) -> cont $ st & stDisplayTime .~ (st ^. stClockTime) | ||
432 | VtyEvent (V.EvKey V.KHome [MShift]) -> cont $ st & stDisplayTime .~ (yearStart $ st ^. stClockTime) | ||
433 | VtyEvent (V.EvKey V.KEnd []) -> cont $ st & stDisplayTime .~ (newYearsEveLast10 $ st ^. stClockTime) | ||
434 | VtyEvent (V.EvKey V.KEnd [MShift]) -> cont $ st & stDisplayTime .~ (yearEnd $ st ^. stClockTime) | ||
435 | VtyEvent (V.EvKey V.KEnd [MCtrl]) -> cont $ st & stDisplayTime .~ (newYearsEveNoon $ st ^. stClockTime) | ||
436 | |||
437 | VtyEvent (V.EvKey V.KRight []) -> cont $ st & stDisplayTime %~ nextCalendarEntryTime | ||
438 | VtyEvent (V.EvKey V.KLeft []) -> cont $ st & stDisplayTime %~ previousCalendarEntryTime | ||
439 | VtyEvent (V.EvKey (V.KChar '.') []) -> cont $ st & stDisplayTime %~ nextCalendarEntryTime | ||
440 | VtyEvent (V.EvKey (V.KChar ',') []) -> cont $ st & stDisplayTime %~ previousCalendarEntryTime | ||
441 | |||
442 | VtyEvent (V.EvKey (V.KChar 'c') []) -> cont $ st & stShowConversion %~ not | ||
443 | VtyEvent (V.EvKey (V.KFun 2) []) -> cont $ st & stShowConversion %~ not | ||
444 | |||
445 | VtyEvent _ -> cont st | ||
446 | AppEvent (TimeChanged now) -> do | ||
447 | let hyper = isNewYearsEve $ st ^. stDisplayTime | ||
448 | void $ queueNextEvent hyper chan | ||
449 | let oldTime = st ^. stClockTime | ||
450 | cont $ st & stClockTime .~ (zonedTimeToLocalTime now) | ||
451 | & stDisplayTime %~ if st ^. stPaused then id else addLocalTime $ zonedTimeToLocalTime now `diffLocalTime` oldTime | ||
452 | _ -> cont st | ||
453 | where | ||
454 | cont s = do | ||
455 | continue $ s & stLastBrickEvent .~ (Just e) | ||
456 | |||
457 | newYearsEveLast10 :: LocalTime -> LocalTime | ||
458 | newYearsEveLast10 = addLocalTime (-11) . yearEnd | ||
459 | |||
460 | newYearsEveNoon :: LocalTime -> LocalTime | ||
461 | newYearsEveNoon (LocalTime d (TimeOfDay _ _ s)) = LocalTime d' t | ||
462 | where | ||
463 | (y, _) = toOrdinalDate d | ||
464 | d' = fromOrdinalDate y 366 | ||
465 | t = TimeOfDay 12 0 s' | ||
466 | s' = s `mod'` 1 -- keep the fractional part so we still tick the display on the same schedule | ||
467 | |||
468 | initialState :: LocalTime -> St | ||
469 | initialState t = | ||
470 | St { _stLastBrickEvent = Nothing | ||
471 | , _stClockTime = t | ||
472 | , _stDisplayTime = t | ||
473 | , _stNextEvent = Nothing | ||
474 | , _stPaused = False | ||
475 | , _stShowConversion = False | ||
476 | } | ||
477 | |||
478 | daysInYear :: LocalTime -> Int | ||
479 | daysInYear (toGregorian . localDay -> (y, _, _)) = if isLeapYear y then 366 else 365 | ||
480 | |||
481 | theBaseAttr :: A.AttrName | ||
482 | theBaseAttr = A.attrName "theBase" | ||
483 | |||
484 | xDoneAttr, xToDoAttr :: A.AttrName | ||
485 | xDoneAttr = theBaseAttr <> A.attrName "X:done" | ||
486 | xToDoAttr = theBaseAttr <> A.attrName "X:remaining" | ||
487 | |||
488 | yDoneAttr, yToDoAttr :: A.AttrName | ||
489 | yDoneAttr = theBaseAttr <> A.attrName "Y:done" | ||
490 | yToDoAttr = theBaseAttr <> A.attrName "Y:remaining" | ||
491 | |||
492 | zDoneAttr, zToDoAttr :: A.AttrName | ||
493 | zDoneAttr = theBaseAttr <> A.attrName "Z:done" | ||
494 | zToDoAttr = theBaseAttr <> A.attrName "Z:remaining" | ||
495 | |||
496 | theMap :: A.AttrMap | ||
497 | theMap = A.attrMap V.defAttr | ||
498 | [ (theBaseAttr, bg V.brightBlack) | ||
499 | , (xDoneAttr, V.black `on` V.white) | ||
500 | , (xToDoAttr, V.white `on` V.black) | ||
501 | , (yDoneAttr, V.magenta `on` V.yellow) | ||
502 | , (zDoneAttr, V.blue `on` V.green) | ||
503 | , (zToDoAttr, V.blue `on` V.red) | ||
504 | , (P.progressIncompleteAttr, fg V.yellow) | ||
505 | ] | ||
506 | |||
507 | theApp :: BChan CustomEvent -> App St CustomEvent () | ||
508 | theApp chan = | ||
509 | App { appDraw = drawUI | ||
510 | , appChooseCursor = showFirstCursor | ||
511 | , appHandleEvent = handleEvent chan | ||
512 | , appStartEvent = return | ||
513 | , appAttrMap = const theMap | ||
514 | } | ||
515 | |||
516 | main :: IO () | ||
517 | main = do | ||
518 | chan <- newBChan 10 | ||
519 | |||
520 | let buildVty = V.mkVty V.defaultConfig | ||
521 | initialVty <- buildVty | ||
522 | now <- queueNextEvent False chan | ||
523 | void $ customMain initialVty buildVty (Just chan) (theApp chan) (initialState $ zonedTimeToLocalTime now) | ||