1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
-- |
-- Module: FRP.Netwire.Utils.Timeline
-- Copyright: (c) 2013 Ertugrul Soeylemez
-- License: BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
{-# LANGUAGE DeriveDataTypeable #-}
module FRP.Netwire.Utils.Timeline
( -- * Time lines for statistics wires
Timeline,
-- * Constructing time lines
insert,
singleton,
union,
-- * Linear sampling
linAvg,
linCutL,
linCutR,
linLookup,
-- * Staircase sampling
scAvg,
scCutL,
scCutR,
scLookup
)
where
import Control.Applicative
import Data.Data
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
-- | A time line is a non-empty set of samples together with time
-- information.
newtype Timeline t a =
Timeline {
timeline :: Map t a
}
deriving (Data, Eq, Ord, Read, Show, Typeable)
instance Functor (Timeline t) where
fmap f (Timeline m) = Timeline (M.map f m)
-- | Insert the given data point.
insert :: (Ord t) => t -> a -> Timeline t a -> Timeline t a
insert t x (Timeline m) = Timeline (M.insert t x m)
-- | Linearly interpolate the points in the time line, integrate the
-- given time interval of the graph, divide by the interval length.
linAvg ::
(Fractional a, Fractional t, Real t)
=> t -> t -> Timeline t a -> a
linAvg t0 t1
| t0 > t1 = const (error "linAvg: Invalid interval")
| t0 == t1 = linLookup t0
linAvg t0 t1 = avg 0 . M.assocs . timeline . linCutR t1 . linCutL t0
where
avg a' ((t', y1) : xs@((t, y2) : _)) =
let dt = realToFrac (t - t')
a = a' + dt*(y1 + y2)/2
in a `seq` avg a xs
avg a' _ = a' / realToFrac (t1 - t0)
-- | Cut the timeline at the given point in time @t@, such that all
-- samples up to but not including @t@ are forgotten. The most recent
-- sample before @t@ is moved and interpolated accordingly.
linCutL ::
(Fractional a, Fractional t, Real t)
=> t -> Timeline t a -> Timeline t a
linCutL t tl@(Timeline m) =
Timeline $
case M.splitLookup t m of
(_, Just x, mr) -> M.insert t x mr
(_, _, mr) -> M.insert t (linLookup t tl) mr
-- | Cut the timeline at the given point in time @t@, such that all
-- samples later than @t@ are forgotten. The most recent sample after
-- @t@ is moved and interpolated accordingly.
linCutR ::
(Fractional a, Fractional t, Real t)
=> t -> Timeline t a -> Timeline t a
linCutR t tl@(Timeline m) =
Timeline $
case M.splitLookup t m of
(ml, Just x, _) -> M.insert t x ml
(ml, _, _) -> M.insert t (linLookup t tl) ml
-- | Look up with linear sampling.
linLookup :: (Fractional a, Fractional t, Real t) => t -> Timeline t a -> a
linLookup t (Timeline m) =
case M.splitLookup t m of
(_, Just x, _) -> x
(ml, _, mr) ->
case (fst <$> M.maxViewWithKey ml, fst <$> M.minViewWithKey mr) of
(Just (t1, x1), Just (t2, x2)) ->
let f = realToFrac ((t - t1) / (t2 - t1))
in x1*(1 - f) + x2*f
(Just (_, x), _) -> x
(_, Just (_, x)) -> x
_ -> error "linLookup: BUG: querying empty Timeline"
-- | Integrate the given time interval of the staircase, divide by the
-- interval length.
scAvg :: (Fractional a, Real t) => t -> t -> Timeline t a -> a
scAvg t0 t1
| t0 > t1 = const (error "scAvg: Invalid interval")
| t0 == t1 = scLookup t0
scAvg t0 t1 = avg 0 . M.assocs . timeline . scCutR t1 . scCutL t0
where
avg a' ((t', y) : xs@((t, _) : _)) =
let dt = realToFrac (t - t')
a = a' + dt*y
in a `seq` avg a xs
avg a' _ = a' / realToFrac (t1 - t0)
-- | Cut the timeline at the given point in time @t@, such that all
-- samples up to but not including @t@ are forgotten. The most recent
-- sample before @t@ is moved accordingly.
scCutL :: (Ord t) => t -> Timeline t a -> Timeline t a
scCutL t tl@(Timeline m) =
Timeline $
case M.splitLookup t m of
(_, Just x, mr) -> M.insert t x mr
(_, _, mr) -> M.insert t (scLookup t tl) mr
-- | Cut the timeline at the given point in time @t@, such that all
-- samples later than @t@ are forgotten. The earliest sample after @t@
-- is moved accordingly.
scCutR :: (Ord t) => t -> Timeline t a -> Timeline t a
scCutR t tl@(Timeline m) =
Timeline $
case M.splitLookup t m of
(ml, Just x, _) -> M.insert t x ml
(ml, _, _) -> M.insert t (scLookup t tl) ml
-- | Look up on staircase.
scLookup :: (Ord t) => t -> Timeline t a -> a
scLookup t (Timeline m) =
case (M.lookupLE t m, M.lookupGE t m) of
(Just (_, x), _) -> x
(_, Just (_, x)) -> x
_ -> error "linLookup: BUG: querying empty Timeline"
-- | Singleton timeline with the given point.
singleton :: t -> a -> Timeline t a
singleton t = Timeline . M.singleton t
-- | Union of two time lines. Right-biased.
union :: (Ord t) => Timeline t a -> Timeline t a -> Timeline t a
union (Timeline m1) (Timeline m2) = Timeline (M.union m2 m1)
|
