module Scope.Types (
Coordinate(..)
, ScreenX(..)
, ScreenY(..)
, CanvasX(..)
, CanvasY(..)
, DataX(..)
, DataY(..)
, Transform(..)
, mkTransform
, mkTSDataTransform
, unionBounds
, translateRange
, unionRange
, restrictRange
, restrictRange01
, zoomRange
, RGB
, DrawCmd(..)
, DrawLayer
, ScopeRender(..)
, ScopePlot(..)
, ScopeFile(..)
, Scope(..)
, scopeNew
, scopeClose
, scopeUpdate
, scopeModifyView
, View(..)
, Layer(..)
, LayerPlot(..)
, LayerMapFunc
, LayerFoldFunc
, ScopeLayer(..)
) where
import Control.Applicative ((<$>))
import Control.Monad.CatchIO
import Data.Iteratee (Enumeratee)
import Data.List (nub)
import Data.Offset
import Data.Maybe
import Data.Time.Clock
import Data.ZoomCache
import System.Posix
data Transform a = Transform { m :: Double, b :: a }
class Coordinate a where
fromDouble :: Double -> a
toDouble :: a -> Double
distance :: a -> a -> a
translate :: a -> a -> a
transform :: Transform a -> a -> a
newtype ScreenX = ScreenX Double deriving (Eq, Ord, Show)
newtype ScreenY = ScreenY Double deriving (Eq, Ord, Show)
newtype CanvasX = CanvasX Double deriving (Eq, Ord, Show)
newtype CanvasY = CanvasY Double deriving (Eq, Ord, Show)
newtype DataX = DataX Double deriving (Eq, Ord, Show)
newtype DataY = DataY Double deriving (Eq, Ord, Show)
instance Coordinate Double where
fromDouble = id
toDouble = id
distance x1 x2 = x2 x1
translate t x = x + t
transform Transform{..} x = m * x + b
instance Coordinate ScreenX where
fromDouble d = ScreenX d
toDouble (ScreenX d) = d
distance (ScreenX x1) (ScreenX x2) = ScreenX (distance x1 x2)
translate (ScreenX t) (ScreenX x) = ScreenX (translate t x)
transform (Transform m (ScreenX b)) (ScreenX x) = ScreenX (transform (Transform m b) x)
instance Coordinate CanvasX where
fromDouble d = CanvasX d
toDouble (CanvasX d) = d
distance (CanvasX x1) (CanvasX x2) = CanvasX (distance x1 x2)
translate (CanvasX t) (CanvasX x) = CanvasX (translate t x)
transform (Transform m (CanvasX b)) (CanvasX x) = CanvasX (transform (Transform m b) x)
instance Coordinate DataX where
fromDouble d = DataX d
toDouble (DataX d) = d
distance (DataX x1) (DataX x2) = DataX (distance x1 x2)
translate (DataX t) (DataX x) = DataX (translate t x)
transform (Transform m (DataX b)) (DataX x) = DataX (transform (Transform m b) x)
instance Coordinate TimeStamp where
fromDouble d = TS d
toDouble (TS d) = d
distance (TS x1) (TS x2) = TS (distance x1 x2)
translate (TS t) (TS x) = TS (translate t x)
transform (Transform m (TS b)) (TS x) = TS (transform (Transform m b) x)
instance Coordinate UTCTime where
fromDouble d = addUTCTime (fromRational . toRational $ d) utc0
toDouble u = fromRational . toRational $ diffUTCTime u utc0
distance u1 u2 = fromDouble (distance (toDouble u1) (toDouble u2))
translate t u = fromDouble (translate (toDouble t) (toDouble u))
transform (Transform m b) x = fromDouble (transform (Transform m (toDouble b)) (toDouble x))
utc0 :: UTCTime
utc0 = UTCTime (toEnum 0) (fromInteger 0)
unionBounds :: Ord a => Maybe (a, a) -> Maybe (a, a) -> Maybe (a, a)
unionBounds a Nothing = a
unionBounds Nothing b = b
unionBounds (Just r1) (Just r2) = Just (unionRange r1 r2)
translateRange :: Coordinate a => a -> (a, a) -> (a, a)
translateRange t (x1, x2) = (translate t x1, translate t x2)
unionRange :: Ord a => (a, a) -> (a, a) -> (a, a)
unionRange (a1, a2) (b1, b2) = (min a1 b1, max a2 b2)
restrictRange :: (Ord a, Coordinate a) => (a, a) -> (a, a) -> (a, a)
restrictRange (rangeX1, rangeX2) (x1, x2)
| w >= rW = (rangeX1, rangeX2)
| x1 < rangeX1 = (rangeX1, translate rangeX1 w)
| x2 > rangeX2 = (x1', rangeX2)
| otherwise = (x1, x2)
where
rW = distance rangeX1 rangeX2
w = distance x1 x2
x1' = distance w rangeX2
restrictRange01 :: (Ord a, Coordinate a) => (a, a) -> (a, a)
restrictRange01 = restrictRange (fromDouble 0.0, fromDouble 1.0)
zoomRange :: Coordinate a => CanvasX -> Double -> (a, a) -> (a, a)
zoomRange (CanvasX focus) mult (x1, x2) = (translate off1 x1, translate off2 x2)
where
off1 = fromDouble $ (oldW newW) * focus
off2 = fromDouble $ (newW oldW) * (1.0 focus)
oldW = toDouble $ distance x1 x2
newW = min 1.0 (oldW * mult)
mkTransform :: Coordinate a => (a, a) -> (a, a) -> Transform a
mkTransform (old1, old2) (new1, new2) = Transform m b
where
oldW = distance old1 old2
newW = distance new1 new2
m = toDouble oldW / toDouble newW
b = distance new1 old1
mkTSDataTransform :: (TimeStamp, TimeStamp) -> (TimeStamp, TimeStamp) -> Transform DataX
mkTSDataTransform (old1, old2) (new1, new2) = Transform m b
where
oldW = distance old1 old2
newW = distance new1 new2
m = toDouble oldW / toDouble newW
b = fromDouble $ toDouble (distance new1 old1) / toDouble newW
mkUTCDataTransform :: (UTCTime, UTCTime) -> (UTCTime, UTCTime) -> Transform DataX
mkUTCDataTransform (old1, old2) (new1, new2) = Transform m b
where
oldW = distance old1 old2
newW = distance new1 new2
m = toDouble oldW / toDouble newW
b = fromDouble $ toDouble (distance new1 old1) / toDouble newW
type RGB = (Double, Double, Double)
data DrawCmd =
SetRGB Double Double Double
| SetRGBA Double Double Double Double
| MoveTo (Double, Double)
| LineTo (Double, Double)
| FillPoly [(Double, Double)]
class (Functor m, MonadCatchIO m) => ScopeRender m where
renderCmds :: [DrawCmd] -> m ()
instance ScopeRender IO where
renderCmds = const (return ())
data ScopeFile = ScopeFile
{ filename :: FilePath
, fd :: Fd
, scopeCF :: CacheFile
}
type DrawLayer = [DrawCmd]
type LayerMapFunc a = Double -> Double -> a -> [DrawLayer]
type LayerFoldFunc a b = Double -> Double -> b -> a -> ([DrawLayer], b)
data LayerPlot a = LayerMap (LayerMapFunc a) [DrawLayer]
| forall b . LayerFold (LayerFoldFunc a b) [DrawLayer] b
data Layer a = Layer
{ layerFile :: ScopeFile
, layerTrackNo :: TrackNo
, layerBaseUTC :: Maybe UTCTime
, startTime :: TimeStamp
, endTime :: TimeStamp
, convEnee :: forall m . (Functor m, Monad m) => Enumeratee [Offset Block] [a] m ()
, plotter :: LayerPlot a
}
data ScopeLayer = forall a . Timestampable a => ScopeLayer (Layer a)
class ScopePlot a where
rawLayerPlot :: a -> RGB -> LayerPlot (TimeStamp, [a])
summaryLayerPlot :: a -> RGB -> LayerPlot [Summary a]
data Scope ui = Scope
{ view :: View ui
, bounds :: Maybe (TimeStamp, TimeStamp)
, utcBounds :: Maybe (UTCTime, UTCTime)
, layers :: [ScopeLayer]
}
data View ui = View
{ viewX1 :: DataX
, viewY1 :: Double
, viewX2 :: DataX
, viewY2 :: Double
, pointerX :: Maybe CanvasX
, dragDX :: Maybe DataX
, viewUI :: ui
}
scopeNew :: ui -> Scope ui
scopeNew ui = Scope {
view = viewInit ui
, bounds = Nothing
, utcBounds = Nothing
, layers = []
}
scopeClose :: Scope ui -> IO (Scope ui)
scopeClose scope = do
mapM_ closeFd . nub . map fd' . layers $ scope
return scope{bounds=Nothing, utcBounds=Nothing, layers=[]}
where
fd' (ScopeLayer l) = fd . layerFile $ l
scopeModifyView :: (View ui -> View ui) -> Scope ui -> Scope ui
scopeModifyView f scope = scope{ view = f (view scope) }
scopeTransform :: Transform DataX -> Scope ui -> Scope ui
scopeTransform tf = scopeModifyView (viewTransform tf)
viewInit :: ui -> View ui
viewInit = View (DataX 0.0) (1.0) (DataX 1.0) 1.0 Nothing Nothing
viewTransform :: Transform DataX -> View ui -> View ui
viewTransform tf v@View{..} = v {
viewX1 = transform tf viewX1
, viewX2 = transform tf viewX2
, dragDX = transform tf <$> dragDX
}
scopeUpdate :: Maybe (TimeStamp, TimeStamp)
-> Maybe (UTCTime, UTCTime)
-> Scope ui -> Scope ui
scopeUpdate newBounds Nothing scope =
(t scope) { bounds = mb , utcBounds = Nothing }
where
oldBounds = bounds scope
mb = unionBounds oldBounds newBounds
t = case oldBounds of
Just ob -> if oldBounds == mb
then id
else scopeTransform (mkTSDataTransform ob (fromJust mb))
_ -> id
scopeUpdate newBounds (Just newUTCBounds) scope
| (not . null . layers $ scope) && isNothing oldUTCBounds = scopeUpdate newBounds Nothing scope
| otherwise = (t scope) { bounds = mb , utcBounds = umb }
where
oldBounds = bounds scope
oldUTCBounds = utcBounds scope
mb = unionBounds oldBounds newBounds
umb = unionBounds oldUTCBounds (Just newUTCBounds)
t = case oldUTCBounds of
Just uob -> if oldUTCBounds == umb
then id
else scopeTransform (mkUTCDataTransform uob (fromJust umb))
_ -> id