implement time warp

1 files changed, 26 insertions, 16 deletions

diff --git a/countdown.hs b/countdown.hs
index ffe7af0..57788c5 100755
--- a/countdown.hs
+++ b/countdown.hs
@@ -75,8 +75,9 @@ data CustomEvent = TimeChanged UTCTime deriving Show
 
 data St =
     St { _stLastBrickEvent :: Maybe (BrickEvent () CustomEvent)
-       , _stCurrentTime :: UTCTime
-       , _stNextEvent :: Maybe UTCTime
+       , _stClockTime      :: UTCTime
+       , _stDisplayTime    :: UTCTime
+       , _stNextEvent      :: Maybe UTCTime
        }
 
 makeLenses ''St
@@ -117,7 +118,7 @@ drawUI st = [a]
         <=>
         (str "\n")
         <=>
-        (countdownWidget $ utcToZonedTime zone $ st ^. stCurrentTime)
+        (countdownWidget $ utcToZonedTime zone $ st ^. stDisplayTime)
 
 countdownWidget :: ZonedTime -> Widget n
 countdownWidget t =
@@ -158,27 +159,41 @@ countdownWidget t =
     yearElapsed    = (zonedTimeToLocalTime t) `diffLocalTime` (zonedTimeToLocalTime $ yearStart t)
 
     daysLeft       = numDays - dayNum
-    secondsLeft    = toSeconds $ yearLength - yearElapsed
-    toSeconds dt   = nominalDiffTimeToSeconds dt `div'` 1 :: Int
+    secondsLeft    = toSeconds $ yearLength - yearElapsed :: Int
+    toSeconds      = floor . nominalDiffTimeToSeconds
     x // y         = fromRational $ toRational x / toRational y :: Double
     progressLabel  = printf "%.6F%%" (100 * (yearElapsed // yearLength))
 
 commas :: Integral i => i -> Text
 commas = prettyI (Just ',') . fromIntegral
 
+microsecondsUntil :: Integral i => UTCTime -> UTCTime -> i
+microsecondsUntil now later = floor $ nominalDiffTimeToSeconds $ (later `diffUTCTime` now) * 1000 * 1000
+
+nextWholeSecond :: UTCTime -> UTCTime
+nextWholeSecond (UTCTime day dayTime) = (UTCTime day dayTime')
+  where
+    dayTime' = secondsToDiffTime $ floor dayTime + 1
+
+threadDelayUntil :: UTCTime -> UTCTime -> IO ()
+threadDelayUntil now t = threadDelay $ microsecondsUntil now t
+
 queueNextEvent :: MonadIO m => BChan CustomEvent -> UTCTime -> m ()
 queueNextEvent chan now = liftIO . void . forkIO $ do
-  threadDelay $ microsecondsUntilNextSecond now
+  threadDelayUntil now (nextWholeSecond now)
   getCurrentTime >>= writeBChan chan . TimeChanged
 
 handleEvent :: BChan CustomEvent -> St -> BrickEvent () CustomEvent -> EventM () (Next St)
 handleEvent chan st e =
     case e of
-        VtyEvent (V.EvKey V.KEsc []) -> halt st
-        VtyEvent _ -> cont st
+        VtyEvent (V.EvKey V.KEsc [])      -> halt st
+        VtyEvent (V.EvKey V.KPageUp [])   -> cont $ st & stDisplayTime %~ (addUTCTime lengthOfDay)
+        VtyEvent (V.EvKey V.KPageDown []) -> cont $ st & stDisplayTime %~ (addUTCTime (-lengthOfDay))
+        VtyEvent _                        -> cont st
         AppEvent (TimeChanged now) -> do
           queueNextEvent chan now
-          cont $ st & stCurrentTime .~ now
+          let oldTime = st ^. stClockTime
+          cont $ st & stClockTime .~ now & stDisplayTime %~ (addUTCTime (now `diffUTCTime` oldTime))
         _ -> cont st
     where
       cont s = do
@@ -187,7 +202,8 @@ handleEvent chan st e =
 initialState :: UTCTime -> St
 initialState t =
     St { _stLastBrickEvent = Nothing
-       , _stCurrentTime = t
+       , _stClockTime = t
+       , _stDisplayTime = t
        , _stNextEvent = Nothing
        }
 
@@ -232,12 +248,6 @@ theApp chan =
 zone :: TimeZone
 zone = unsafePerformIO getCurrentTimeZone
 
-microsecondsUntilNextSecond :: Integral i => UTCTime -> i
-microsecondsUntilNextSecond now = (1000 * 1000 * remainingInCurrentSecond) `div'` 1
-  where
-    todSecNow = todSec $ localTimeOfDay $ utcToLocalTime zone now
-    remainingInCurrentSecond = 1 - (todSecNow `mod'` 1)
-
 main :: IO ()
 main = do
     chan <- newBChan 10