module Data.GPS
(
Distance
, Heading
, Speed
, Vector
, Trail
, north
, south
, east
, west
, radiusOfEarth
, restLocations
, closestDistance
, getRadianPair
, addVector
, divideArea
, convexHull
, module Data.Geo.GPX
) where
import Data.Ord (comparing)
import Data.List (sort, mapAccumL, minimumBy, maximumBy, sortBy)
import Data.Geo.GPX hiding (none, cmt)
import Text.XML.HXT.Arrow
import Text.XML.XSD.DateTime(DateTime, toUTCTime)
import Data.Time
import Data.Maybe (listToMaybe)
import Data.Fixed (mod')
type Distance = Double
type Heading = Double
type Speed = Double
type Vector = (Distance, Heading)
type Trail a = [a]
getUTCTime :: (Lat a, Lon a, Time a) => a -> Maybe UTCTime
getUTCTime = fmap toUTCTime . time
distance :: (Lat a, Lon a) => a -> a -> Distance
distance a b =
radiusOfEarth * acos( sin(lat1) * sin(lat2) + cos(lat1) * cos(lat2) * cos(lon2 lon1) )
where
(lat1, lon1) = getRadianPairD a
(lat2, lon2) = getRadianPairD b
heading :: (Lat a, Lon a) => a -> a -> Heading
heading a b =
atan2 (sin (diffLon) * cos (lat2))
(cos(lat1) * sin (lat2) sin(lat1) * cos lat2 * cos (diffLon))
where
(lat1, lon1) = getRadianPairD a
(lat2, lon2) = getRadianPairD b
diffLon = lon1 lon2
getVector :: (Lat a, Lon a) => a -> a -> Vector
getVector a b = (distance a b, heading a b)
speed :: (Lat loc, Lon loc, Time loc) => loc -> loc -> Maybe Speed
speed a b =
case (getUTCTime b, getUTCTime a) of
(Just x, Just y) -> Just $ realToFrac (diffUTCTime x y) / (distance a b)
_ -> Nothing
data TempTrail a = T (Trail a) a
radiusOfEarth :: Double
radiusOfEarth = 6378700
north :: Heading
north = 0
south :: Heading
south = pi
east :: Heading
east = (3 / 2) * pi
west :: Heading
west = pi / 2
toDecimal = (*) (180 / pi)
addVector :: (Lat c, Lon c) => Vector -> c -> c
addVector (d,h) p = setLon (longitudeType lon2) . setLat (latitudeType lat2) $ p
where
(lat,lon) = getRadianPairD p
lat2 = lat + (cos h) * (d / radiusOfEarth)
lon2 = lon + acos ( (cos (d/radiusOfEarth) sin lat * sin lat2) / (cos lat * cos lat2))
getRadianPairD :: (Lat c, Lon c) => c -> (Double,Double)
getRadianPairD = (\(a,b) -> (realToFrac a, realToFrac b)) . getRadianPair
getRadianPair :: (Lat p, Lon p) => p -> (LatitudeType, LongitudeType)
getRadianPair p = (t, g)
where
t = toRadians (lat p)
g = toRadians (lon p)
toRadians :: Floating f => f -> f
toRadians = (*) (pi / 180)
linearTime :: (Lat a, Lon a, Time a) => Trail a -> Trail 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
restLocations :: (Lat a, Lon a, Time a) => Distance -> NominalDiffTime -> Trail a -> [Trail a]
restLocations d s xs = go xs
where
go [] = []
go (a:as) =
let (lst, close, far) = takeWhileLast ((<= d) . distance a) as
in case lst of
Just x -> case (getUTCTime a, getUTCTime x) of
(Just a', Just x') ->
let d = diffUTCTime a' x'
in if d >= s then close : go far else go as
_ -> go as
Nothing -> go as
takeWhileLast :: (a -> Bool) -> [a] -> (Maybe a, [a], [a])
takeWhileLast p [] = (Nothing, [], [])
takeWhileLast p (x:xs)
| not (p x) = (Nothing, [], x:xs)
| otherwise = go x xs
where
go a [] = (Just a, [a], [])
go a (b:bs)
| p b = let (c,d,f) = go b bs in (c, a:d, f)
| otherwise = (Just a, [a], b:bs)
closestDistance :: (Lat a, Lon a) => Trail a -> Trail a -> Maybe Distance
closestDistance as bs = listToMaybe $ sort [distance a b | a <- as, b <- bs]
divideArea :: (Lat c, Lon c) => Distance -> Distance -> c -> c -> [[c]]
divideArea vDist hDist nw se =
let (top,left) = (lat nw, lon nw)
(btm,right) = (lat se, lon se)
columnOne = takeWhile ( (<= west) . heading se) . iterate (addVector (vDist, south)) $ nw
buildRow = takeWhile ((>= north) . heading se) . iterate (addVector (hDist, east))
in map buildRow columnOne
convexHull :: (Eq c, Lat c, Lon c) => [c] -> [c]
convexHull xs =
let first = southMost xs
in case first of
Nothing -> []
Just f ->
let sorted = sortBy (comparing ((`mod'` (2*pi)). (+ pi/2). heading 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)
data Turn = LeftTurn | RightTurn | Straight deriving (Eq, Ord, Show, Read, Enum)
turn :: (Lat c, Lon c) => c -> c -> c -> Turn
turn a b c =
let h1 = heading a b
h2 = heading b c
in case compare (h2 h1) 0 of
LT -> RightTurn
GT -> LeftTurn
EQ -> Straight
southMost :: (Lat c) => [c] -> Maybe c
southMost [] = Nothing
southMost cs = Just . minimumBy (comparing lat) $ cs