module Control.Wire.Prefab.Analyze
(
avg,
avgAll,
avgFps,
highPeak,
lowPeak,
peakBy,
collect,
diff,
firstSeen,
lastSeen
)
where
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Vector.Unboxed as Vu
import qualified Data.Vector.Unboxed.Mutable as Vum
import Control.Arrow
import Control.Monad.Fix
import Control.Monad.ST
import Control.Wire.Classes
import Control.Wire.Prefab.Clock
import Control.Wire.Types
import Data.Map (Map)
import Data.Monoid
import Data.Set (Set)
avg :: forall e v (>~). (Arrow (>~), Fractional v, Vu.Unbox v) => Int -> Wire e (>~) v v
avg n = mkPure $ \x -> (Right x, avg' (Vu.replicate n (x/d)) x 0)
where
avg' :: Vu.Vector v -> v -> Int -> Wire e (>~) v v
avg' samples' s' cur' =
mkPure $ \((/d) -> x) ->
let cur = let cur = succ cur' in if cur >= n then 0 else cur
x' = samples' Vu.! cur
samples =
x' `seq` runST $ do
s <- Vu.unsafeThaw samples'
Vum.write s cur x
Vu.unsafeFreeze s
s = s' x' + x
in cur `seq` s' `seq` (Right s, avg' samples s cur)
d :: v
d = realToFrac n
avgAll :: forall e v (>~). (Arrow (>~), Fractional v) => Wire e (>~) v v
avgAll = mkPure $ \x -> (Right x, avgAll' 1 x)
where
avgAll' :: v -> v -> Wire e (>~) v v
avgAll' n' a' =
mkPure $ \x ->
let n = n' + 1
a = a' a'/n + x/n
in a' `seq` (Right a, avgAll' n a)
avgFps ::
(ArrowChoice (>~), ArrowClock (>~), Fractional t, Time (>~) ~ t, Vu.Unbox t)
=> Int
-> Wire e (>~) a t
avgFps n = recip ^<< avg n <<< dtime
collect :: forall b e (>~). Ord b => Wire e (>~) b (Set b)
collect = collect' S.empty
where
collect' :: Set b -> Wire e (>~) b (Set b)
collect' ins' =
mkPure $ \x ->
let ins = S.insert x ins'
in (Right ins, collect' ins)
diff :: forall b e (>~). (Eq b, Monoid e) => Wire e (>~) b b
diff =
mkPure $ \x -> (Right x, diff' x)
where
diff' :: b -> Wire e (>~) b b
diff' x' =
mkPure $ \x ->
if x' == x
then (Left mempty, diff' x')
else (Right x', diff' x)
firstSeen ::
forall a e t (>~). (ArrowChoice (>~), ArrowClock (>~), Monoid e, Ord a, Time (>~) ~ t)
=> Wire e (>~) a t
firstSeen = firstSeen' M.empty
where
firstSeen' :: Map a t -> Wire e (>~) a t
firstSeen' xs' =
fix $ \again ->
mkGen $ proc x' -> do
case M.lookup x' xs' of
Just t -> returnA -< (Right t, again)
Nothing -> do
t <- arrTime -< ()
returnA -< (Right t, firstSeen' (M.insert x' t xs'))
highPeak :: Ord b => Wire e (>~) b b
highPeak = peakBy compare
lastSeen ::
forall a e t (>~). (ArrowClock (>~), Monoid e, Ord a, Time (>~) ~ t)
=> Wire e (>~) a t
lastSeen = lastSeen' M.empty
where
lastSeen' :: Map a t -> Wire e (>~) a t
lastSeen' xs' =
mkGen $ proc x' -> do
t <- arrTime -< ()
let xs = M.insert x' t xs'
returnA -< (maybe (Left mempty) Right $ M.lookup x' xs',
lastSeen' xs)
lowPeak :: Ord b => Wire e (>~) b b
lowPeak = peakBy (flip compare)
peakBy :: forall b e (>~). (b -> b -> Ordering) -> Wire e (>~) b b
peakBy comp = mkPure (Right &&& peakBy')
where
peakBy' :: b -> Wire e (>~) b b
peakBy' x'' =
mkPure $ \x' ->
Right &&& peakBy' $ if comp x' x'' == GT then x' else x''