{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Clock.Realtime.Millisecond where
import Control.Arrow
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import GHC.TypeLits
import Data.Time.Clock
import Data.Vector.Sized (Vector, fromList)
import Data.Automaton (arrM)
import FRP.Rhine.Clock
import FRP.Rhine.Clock.FixedStep
import FRP.Rhine.Clock.Proxy
import FRP.Rhine.Clock.Unschedule
import FRP.Rhine.ResamplingBuffer
import FRP.Rhine.ResamplingBuffer.Collect
import FRP.Rhine.ResamplingBuffer.Util
newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool)
instance Clock IO (Millisecond n) where
type Time (Millisecond n) = UTCTime
type Tag (Millisecond n) = Bool
initClock :: Millisecond n
-> RunningClockInit IO (Time (Millisecond n)) (Tag (Millisecond n))
initClock (Millisecond RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
cl) = RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
-> RunningClockInit
IO
(Time
(RescaledClockS
IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool))
(Tag
(RescaledClockS
IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool))
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
cl
instance GetClockProxy (Millisecond n)
waitClock :: (KnownNat n) => Millisecond n
waitClock :: forall (n :: Nat). KnownNat n => Millisecond n
waitClock = RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
-> Millisecond n
forall (n :: Nat).
RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
-> Millisecond n
Millisecond (RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
-> Millisecond n)
-> RescaledClockS
IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
-> Millisecond n
forall a b. (a -> b) -> a -> b
$ UnscheduleClock IO (FixedStep n)
-> (Time (UnscheduleClock IO (FixedStep n))
-> IO
(Automaton
IO
(Time (UnscheduleClock IO (FixedStep n)),
Tag (UnscheduleClock IO (FixedStep n)))
(UTCTime, Bool),
UTCTime))
-> RescaledClockS
IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
forall (m :: Type -> Type) cl time tag.
cl -> RescalingSInit m cl time tag -> RescaledClockS m cl time tag
RescaledClockS (FixedStep n -> UnscheduleClock IO (FixedStep n)
forall cl. cl -> UnscheduleClock IO cl
unyieldClock FixedStep n
forall (n :: Nat). KnownNat n => FixedStep n
FixedStep) ((Time (UnscheduleClock IO (FixedStep n))
-> IO
(Automaton
IO
(Time (UnscheduleClock IO (FixedStep n)),
Tag (UnscheduleClock IO (FixedStep n)))
(UTCTime, Bool),
UTCTime))
-> RescaledClockS
IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool)
-> (Time (UnscheduleClock IO (FixedStep n))
-> IO
(Automaton
IO
(Time (UnscheduleClock IO (FixedStep n)),
Tag (UnscheduleClock IO (FixedStep n)))
(UTCTime, Bool),
UTCTime))
-> RescaledClockS
IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
forall a b. (a -> b) -> a -> b
$ \Time (UnscheduleClock IO (FixedStep n))
_ -> do
UTCTime
initTime <- IO UTCTime -> IO UTCTime
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let
runningClock :: Automaton IO (Integer, ()) (UTCTime, Bool)
runningClock = ((Integer, ()) -> IO (UTCTime, Bool))
-> Automaton IO (Integer, ()) (UTCTime, Bool)
forall (m :: Type -> Type) a b.
Functor m =>
(a -> m b) -> Automaton m a b
arrM (((Integer, ()) -> IO (UTCTime, Bool))
-> Automaton IO (Integer, ()) (UTCTime, Bool))
-> ((Integer, ()) -> IO (UTCTime, Bool))
-> Automaton IO (Integer, ()) (UTCTime, Bool)
forall a b. (a -> b) -> a -> b
$ \(Integer
n, ()) -> IO (UTCTime, Bool) -> IO (UTCTime, Bool)
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Bool) -> IO (UTCTime, Bool))
-> IO (UTCTime, Bool) -> IO (UTCTime, Bool)
forall a b. (a -> b) -> a -> b
$ do
UTCTime
beforeSleep <- IO UTCTime
getCurrentTime
let
diff :: Double
diff :: Double
diff = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall a b. (a -> b) -> a -> b
$ UTCTime
beforeSleep UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
initTime
remaining :: Int
remaining = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
diff Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000)
Int -> IO ()
threadDelay Int
remaining
UTCTime
now <- IO UTCTime
getCurrentTime
(UTCTime, Bool) -> IO (UTCTime, Bool)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
now, Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
(Automaton IO (Integer, ()) (UTCTime, Bool), UTCTime)
-> IO (Automaton IO (Integer, ()) (UTCTime, Bool), UTCTime)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Automaton IO (Integer, ()) (UTCTime, Bool)
runningClock, UTCTime
initTime)
downsampleMillisecond ::
(KnownNat n, Monad m) =>
ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a (Vector n a)
downsampleMillisecond :: forall (n :: Nat) (m :: Type -> Type) (k :: Nat) a.
(KnownNat n, Monad m) =>
ResamplingBuffer
m (Millisecond k) (Millisecond (n * k)) a (Vector n a)
downsampleMillisecond = ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a [a]
forall (m :: Type -> Type) cl1 cl2 a.
Monad m =>
ResamplingBuffer m cl1 cl2 a [a]
collect ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a [a]
-> ClSF m (Millisecond (n * k)) [a] (Vector n a)
-> ResamplingBuffer
m (Millisecond k) (Millisecond (n * k)) a (Vector n a)
forall (m :: Type -> Type) cl1 cl2 a b c.
Monad m =>
ResamplingBuffer m cl1 cl2 a b
-> ClSF m cl2 b c -> ResamplingBuffer m cl1 cl2 a c
>>-^ ([a] -> Vector n a)
-> ClSF m (Millisecond (n * k)) [a] (Vector n a)
forall b c.
(b -> c)
-> Automaton (ReaderT (TimeInfo (Millisecond (n * k))) m) b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ([a] -> Maybe (Vector n a)
forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
fromList ([a] -> Maybe (Vector n a))
-> (Maybe (Vector n a) -> Vector n a) -> [a] -> Vector n a
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Maybe (Vector n a) -> Vector n a
forall {a}. Maybe a -> a
assumeSize)
where
assumeSize :: Maybe a -> a
assumeSize =
a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (a -> Maybe a -> a) -> a -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"downsampleMillisecond: Internal error. Please report this as a bug: https://github.com/turion/rhine/issues"