module Data.GPS.Trail
(
AvgMethod(..)
, Selected(..)
, PointGrouping
, TransformGrouping
, isSelected
, isNotSelected
, onSelected
, selLength
, totalDistance
, totalTime
, avgSpeeds
, slidingAverageSpeed
, closestDistance
, convexHull
, bezierCurveAt
, bezierCurve
, linearTime
, filterPoints
, betweenSpeeds
, restLocations
, spansTime
, everyNPoints
, intersectionOf
, invertSelection
, firstGrouping
, lastGrouping
, unionOf
, refineGrouping
, (/\), (\/)
, smoothRests
, smoothSome
, smoothMore
, bezierPoint
) where
import Text.Show.Functions ()
import Data.GPS.Core hiding (fix)
import Text.XML.XSD.DateTime (fromUTCTime)
import Control.Arrow (first, second)
import Control.Monad
import Data.Fixed (mod')
import Data.Function (on,fix)
import Data.List as L
import Data.Maybe
import Data.Ord
import Data.Time
import Data.Lens.Common
import Statistics.Function as F
import Statistics.Sample
import qualified Data.Vector.Unboxed as V
takeWhileEnd :: (a -> Bool) -> [a] -> (Maybe a, [a],[a])
takeWhileEnd p xs = go xs Nothing
where
go [] e = (e, [], [])
go (a:as) e
| p a = let (e',xs,zs) = go as (Just a) in (e',a:xs,zs)
| otherwise = (e,[], a:as)
data AvgMethod c
= AvgMean
| AvgHarmonicMean
| AvgGeometricMean
| AvgMedian
| AvgEndPoints
| AvgMinOf [AvgMethod c]
| AvgWith ([c] -> Speed)
avgSpeeds :: (LatL a, LonL a, TimeL a) => NominalDiffTime -> Trail a -> [(UTCTime, Speed)]
avgSpeeds = slidingAverageSpeed AvgHarmonicMean
slidingAverageSpeed :: (LatL a, LonL a, TimeL a) =>
AvgMethod a -> NominalDiffTime -> Trail a -> [(UTCTime, Speed)]
slidingAverageSpeed _ _ [] = []
slidingAverageSpeed m minTime xs =
let pts = map unSelect (spansTime minTime xs)
spds = map (getAvg m) pts
times = map getAvgTimes pts
in concatMap maybeToList $ zipWith (\t s -> fmap (,s) t) times spds
where
getTimeDiff a b = on (liftM2 diffUTCTime) getUTCTime a b
getAvg _ [] = 0
getAvg _ [x] = 0
getAvg m cs =
let ss = getSpeedsV cs
in case m of
AvgMean -> mean ss
AvgHarmonicMean -> harmonicMean ss
AvgGeometricMean -> geometricMean ss
AvgMedian ->
let ss' = F.sort $ getSpeedsV cs
len = V.length ss'
mid = len `div` 2
in if V.length ss' < 3
then mean ss'
else if odd len then ss' V.! mid else mean (V.slice mid 2 ss')
AvgEndPoints -> fromMaybe 0 $ speed (head cs) (last cs)
AvgMinOf as -> minimum $ map (flip getAvg cs) as
AvgWith f -> f cs
getAvgTimes [] = Nothing
getAvgTimes [x] = getUTCTime x
getAvgTimes ps = getAvgTime (head ps) (last ps)
getAvgTime a b = liftM2 addUTCTime (getTimeDiff b a) (getUTCTime a)
getSpeedsV = V.fromList . getSpeeds
getSpeeds zs = concatMap maybeToList $ zipWith speed zs (drop 1 zs)
type PointGrouping c = Trail c -> [Selected (Trail c)]
type TransformGrouping c = [Selected (Trail c)] -> [Selected (Trail c)]
data Selected a = Select {unSelect :: a} | NotSelect {unSelect :: a}
deriving (Eq, Ord, Show)
isSelected :: Selected a -> Bool
isSelected (Select _) = True
isSelected _ = False
isNotSelected :: Selected a -> Bool
isNotSelected = not . isSelected
selLength :: Selected [a] -> Int
selLength = length . unSelect
onSelected :: (a -> b) -> (a -> b) -> Selected a -> b
onSelected f _ (Select a) = f a
onSelected _ g (NotSelect a) = g a
instance Functor Selected where
fmap f (Select x) = Select $ f x
fmap f (NotSelect x) = NotSelect $ f x
dropExact :: Int -> [Selected [a]] -> [Selected [a]]
dropExact i [] = []
dropExact i (x:xs) =
case compare (selLength x) i of
EQ -> xs
LT -> dropExact (i selLength x) xs
GT -> fmap (drop i) x : xs
betweenSpeeds :: (LatL a, LonL a, TimeL a) => Double -> Double -> PointGrouping a
betweenSpeeds low hi ps =
let spds = concatMap maybeToList $ zipWith speed ps (drop 1 ps)
psSpds = [(p,s) | p <- ps, s <- maybeToList (listToMaybe spds) ++ spds]
inRange x = x >= low && x <= hi
chunk [] = []
chunk xs@(x:_) =
let op p = if inRange (snd x) then first Select . span p else first NotSelect . break p
(r,rest) = op (inRange . snd) xs
in r : chunk xs
in map (fmap (map fst)) $ chunk psSpds
restLocations :: (LatL a, LonL a, TimeL a) => Distance -> NominalDiffTime -> PointGrouping a
restLocations d s ps =
let consToFirst x [] = [NotSelect [x]]
consToFirst x (a:as) = (fmap (x:) a) : as
go [] [] = []
go [] nonRests = [NotSelect $ reverse nonRests]
go (a:as) nonRests =
case takeWhileEnd ((<=) d . distance a) as of
(Just l, close, far) ->
case (getUTCTime a, getUTCTime l) of
(Just t1, Just t2) ->
let diff = diffUTCTime t2 t1
in if diff >= s then NotSelect (reverse nonRests) : Select (a:close) : go far [] else go as (a:nonRests)
_ -> consToFirst a $ go as nonRests
_ -> consToFirst a $ go as nonRests
in go ps []
spansTime :: (LatL a, LonL a, TimeL a) => NominalDiffTime -> PointGrouping a
spansTime n ps =
let times = mkTimePair ps
chunk [] = []
chunk xs@(x:_) =
let (good,rest) = span ((<= addUTCTime n (snd x)) . snd) xs
in if null good then [xs] else good : chunk rest
in map (Select . map fst) $ chunk times
intersectionOf :: (LatL a, LonL a, TimeL a) => [PointGrouping a] -> PointGrouping a
intersectionOf gs ps =
let groupings = map ($ ps) gs
chunk _ [] = []
chunk ggs xs =
let minLen = max 1 . minimum . concatMap (take 1) $ map (map selLength) ggs
sel = if all isSelected (concatMap (take 1) ggs) then Select else NotSelect
(c,rest) = splitAt minLen xs
in sel c : chunk (filter (not . null) $ map (dropExact minLen) ggs) rest
in chunk groupings ps
unionOf :: (LatL a, LonL a, TimeL a) => [PointGrouping a] -> PointGrouping a
unionOf gs ps =
let groupings = map ($ ps) gs
chunk _ [] = []
chunk ggs xs =
let getSegs = concatMap (take 1)
segs = getSegs ggs
len =
if any isSelected segs
then max 1 . maximum . getSegs . map (map selLength) . map (filter isSelected) $ ggs
else max 1 . minimum . getSegs . map (map selLength) $ ggs
sel = if any isSelected segs then Select else NotSelect
(c,rest) = splitAt len xs
in sel c : chunk (filter (not . null) $ map (dropExact len) ggs) rest
in chunk groupings ps
(/\) :: [Selected (Trail a)] -> TransformGrouping a
(/\) xs [] = []
(/\) [] ys = []
(/\) xsL@(Select x:xs) ysL@(Select y:ys) =
let z = if length x < length y then x else y
xs' = selListDrop (length z) xsL
ys' = selListDrop (length z) ysL
in Select z : (xs' /\ ys')
(/\) xs (NotSelect y:ys) = NotSelect y : (selListDrop (length y) xs /\ ys)
(/\) (NotSelect x:xs) ys = NotSelect x : (xs /\ selListDrop (length x) ys)
(\/) :: [Selected (Trail a)] -> TransformGrouping a
(\/) xs [] = xs
(\/) [] ys = ys
(\/) (Select x:xs) (Select y : ys) =
let xLen = length x
yLen = length y
in if xLen < yLen
then (Select y :) (selListDrop (yLen xLen) xs \/ ys)
else (Select x :) (xs \/ selListDrop (xLen yLen) ys)
(\/) (Select x:xs) ys = Select x : selListDrop (length x) ys
(\/) xs (Select y:ys) = Select y : selListDrop (length y) xs
(\/) xsL@(NotSelect x:xs) ysL@(NotSelect y:ys) =
let xLen = length x
yLen = length y
in if xLen < yLen
then (NotSelect x:) (xs \/ selListDrop xLen ysL)
else (NotSelect y:) (selListDrop yLen xsL \/ ys)
selListTake :: Int -> [Selected [a]] -> [Selected [a]]
selListTake 0 _ = []
selListTake n [] = []
selListTake n (x:xs) =
let x' = take n (unSelect x)
in fmap (const x') x : selListTake (n length x') xs
selListDrop :: Int -> [Selected [a]] -> [Selected [a]]
selListDrop 0 xs = xs
selListDrop n [] = []
selListDrop n (x:xs) =
let x' = drop n (unSelect x)
in fmap (const x') x : selListDrop (n (selLength x length x')) xs
invertSelection :: TransformGrouping a
invertSelection = map (onSelected NotSelect Select)
firstGrouping :: TransformGrouping a
firstGrouping ps = take 1 ps ++ map (NotSelect . unSelect) (drop 1 ps)
lastGrouping :: TransformGrouping a
lastGrouping ps = let ps' = reverse ps in reverse $ take 1 ps' ++ map (NotSelect . unSelect) (drop 1 ps')
everyNPoints :: Int -> PointGrouping a
everyNPoints n ps
| n <= 0 = [NotSelect ps]
| otherwise = go ps
where
go [] = []
go xs = let (h,t) = splitAt n xs in Select h : go t
refineGrouping :: PointGrouping a -> TransformGrouping a
refineGrouping b = concatMap (onSelected b (\x -> [NotSelect x]))
filterPoints :: PointGrouping a -> Trail a -> Trail a
filterPoints g = concatMap unSelect . filter isSelected . g
mkTimePair :: (TimeL a) => Trail a -> [(a,UTCTime)]
mkTimePair xs =
let timesM = map (\x-> fmap (x,) $ getUTCTime x) xs
in concatMap maybeToList timesM
bezierCurveAt :: (LatL a, LonL a, TimeL a) => [UTCTime] -> Trail a -> Trail a
bezierCurveAt _ [] = []
bezierCurveAt selectedTimes xs =
let timesDef = mkTimePair xs
end = last timesDef
top = head timesDef
totalTime = diffUTCTime (snd end) (snd top)
times = if null selectedTimes then map snd timesDef else selectedTimes
diffTimes = [diffUTCTime t (snd top) / totalTime | t <- times]
queryTimes = map realToFrac diffTimes
in if totalTime <= 0 || any (\x -> x < 0 || x > 1) queryTimes
then xs
else
if null timesDef || any (\x -> x < 0 || x > 1) queryTimes
then xs
else let curvePoints = (map (bezierPoint xs) queryTimes)
newTimes = [addUTCTime t (snd top) | t <- diffTimes]
in zipWith ((timeL ^=) . Just . fromUTCTime) newTimes curvePoints
bezierPoint :: (LatL a, LonL a) => [a] -> Double -> a
bezierPoint pnts t = go pnts
where
go [] = error "GPS Package: Can not create a bezier point from an empty list"
go [p] = p
go ps = interpolate (go (init ps)) (go (tail ps)) t
bezierCurve :: (LatL a, LonL a, TimeL a) => [Selected (Trail a)] -> Trail a
bezierCurve = concatMap (onSelected (bezierCurveAt []) Prelude.id)
linearTime :: (LonL a, LatL a, TimeL a) => [a] -> [a]
linearTime [] = []
linearTime (p:ps) = go (getUTCTime p) ps
where
go _ [] = []
go t (p:ps) = if getUTCTime p < t then go t ps else p : go (getUTCTime p) ps
closestDistance :: (LatL a, LonL a) => Trail a -> Trail a -> Maybe Distance
closestDistance as bs = listToMaybe $ L.sort [distance a b | a <- as, b <- bs]
totalDistance :: (LatL a, LonL a) => [a] -> Distance
totalDistance as = sum $ zipWith distance as (drop 1 as)
totalTime :: TimeL a => Trail a -> NominalDiffTime
totalTime [] = 0
totalTime xs@(x:_) = fromMaybe 0 $ liftM2 diffUTCTime (getUTCTime x) (getUTCTime $ last xs)
convexHull :: (Eq c, LatL c, LonL c) => [c] -> [c]
convexHull xs =
let first = southMost xs
in case first of
Nothing -> []
Just f ->
let sorted = L.sortBy (comparing (eastZeroHeading f)) (filter (/= f) xs)
in case sorted of
(a:b:cs) -> grahamScan (b:a:f:[]) cs
cs -> f : cs
where
grahamScan [] _ = []
grahamScan ps [] = ps
grahamScan (x:[]) _ = [x]
grahamScan (p2:p1:ps) (x:xs) =
case turn p1 p2 x of
LeftTurn -> grahamScan (x:p2:p1:ps) xs
Straight -> grahamScan (x:p2:p1:ps) xs
_ -> grahamScan (p1:ps) (x:xs)
eastZeroHeading :: (LatL c, LonL c) => c -> c -> Heading
eastZeroHeading s = (`mod'` (2*pi)) . (+ pi/2) . heading s
data Turn = LeftTurn | RightTurn | Straight deriving (Eq, Ord, Show, Read, Enum)
turn :: (LatL c, LonL c) => c -> c -> c -> Turn
turn a b c =
let h1 = eastZeroHeading a b
h2 = eastZeroHeading b c
d = h2 h1
in if d >= 0 && d < pi then LeftTurn else RightTurn
southMost :: (LatL c) => [c] -> Maybe c
southMost [] = Nothing
southMost cs = Just . minimumBy (comparing (^. latL)) $ cs
smoothRests :: (LatL a, LonL a, TimeL a) => Trail a -> Trail a
smoothRests = bezierCurve . refineGrouping (everyNPoints 8) . restLocations 30 60
smoothSome :: (LatL a, LonL a, TimeL a) => Trail a -> Trail a
smoothSome = gSmoothSome 7
gSmoothSome n = bezierCurve . everyNPoints n
gSmoothMore n k ps =
let ps' = gSmoothSome n ps
(h,t) = splitAt k ps'
in h ++ gSmoothSome n t
smoothMore :: (LatL a, LonL a, TimeL a) => Trail a -> Trail a
smoothMore
= gSmoothMore 7 3 . gSmoothMore 3 1 . gSmoothMore 5 2
. gSmoothMore 3 1 . gSmoothMore 5 2 . gSmoothMore 7 3
slidingWindow :: Int -> Int -> ([a] -> [a]) -> [a] -> [a]
slidingWindow width step f trail = go trail
where
go [] = []
go xs =
let (window,e) = splitAt width xs
(hT,eT) = splitAt step (f window)
in hT ++ go (eT ++ e)