gps 0.8.4 → 0.9

raw patch · 3 files changed

+124/−58 lines, 3 filesdep +data-lensdep ~GPXdep ~hxtdep ~xsdPVP ok

version bump matches the API change (PVP)

Dependencies added: data-lens

Dependency ranges changed: GPX, hxt, xsd

API changes (from Hackage documentation)

Files

• Data/GPS/Core.hs +94/−30
• Data/GPS/Trail.hs +25/−24
• gps.cabal +5/−4

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} module Data.GPS.Core        ( -- * Types          Distance@@ -6,6 +6,8 @@        , Speed        , Vector        , Trail+       , Circle+       , Arc          -- * Constants        , north        , south@@ -23,6 +25,9 @@        , getDMSPair        , divideArea        , interpolate+       , circleIntersectionPoints+       , intersectionArcsOf+       , maximumDistanceOfArc          -- * IO helpers        , writeGPX        , readGPX@@ -34,10 +39,13 @@  import Data.Time import Data.Maybe+import Data.List (sortBy)+import Data.Ord (comparing) import Control.Monad import Text.XML.HXT.Core import Text.XML.XSD.DateTime(DateTime,toUTCTime) import Data.Geo.GPX+import Data.Lens.Common  -- |Distances are expressed in meters type Distance = Double@@ -49,17 +57,23 @@ -- 	(3/2)pi	== East    == - (pi / 2) type Heading = Double -type Angle = Double -- |Speed is hard coded as meters per second type Speed = Double type Vector = (Distance, Heading) +-- | Genearlly a circle indicates a known area in which we are searching+-- (so a center point and maximum possible distance from that point)+type Circle a = (a, Distance)++-- | An arc is represented as a circle, starting heading and ending heading+type Arc a = (Circle a, Heading, Heading)+  type Trail a = [a] -getUTCTime :: (Time a) => a -> Maybe UTCTime-getUTCTime = fmap toUTCTime . time+getUTCTime :: (TimeL a) => a -> Maybe UTCTime+getUTCTime = fmap toUTCTime . (^. timeL) -distance :: (Lat a, Lon a, Lat b, Lon b) => a -> b -> Distance+distance :: (LatL a, LonL a, LatL b, LonL b) => a -> b -> Distance distance x y =   let (lat1,lon1) = getRadianPairD x       (lat2,lon2) = getRadianPairD y@@ -70,7 +84,7 @@   in radiusOfEarth * c  -- | Direction two points aim toward (0 = North, pi/2 = West, pi = South, 3pi/2 = East)-heading         :: (Lat a, Lon a, Lat b, Lon b) => a -> b -> Heading+heading         :: (LatL a, LonL a, LatL b, LonL b) => a -> b -> Heading heading a b = 	atan2	(sin (diffLon) * cos (lat2)) 		(cos(lat1) * sin (lat2) - sin(lat1) * cos lat2 * cos (diffLon))@@ -79,7 +93,7 @@   (lat2, lon2) = getRadianPairD b   diffLon = lon2 - lon1 -getVector :: (Lat a, Lon a, Lat b, Lon b) => a -> b -> Vector+getVector :: (LatL a, LonL a, LatL b, LonL b) => a -> b -> Vector getVector a b = (distance a b, heading a b)  -- |Given a vector and coordinate, computes a new coordinate.@@ -92,9 +106,10 @@ -- 	@heading == heading start dest@ -- 	 -- 	@dist    == distance start dest@-addVector :: (Lat c, Lon c) => Vector -> c -> c-addVector (d,h) p = setLon (longitudeType $ toDegrees lon2) -                  . setLat (latitudeType $ toDegrees lat2) $ p+addVector :: (LatL c, LonL c) => Vector -> c -> c+addVector (d,h) p = (lonL ^= longitude (toDegrees lon2))+                  . (latL ^= latitude  (toDegrees lat2))+                  $ p   where 	(lat,lon) = getRadianPairD p 	lat2 = asin (sin (lat) * cos (d / radiusOfEarth) + cos(lat) @@ -103,7 +118,7 @@                            (cos (d/radiusOfEarth) - sin lat * sin lat2)  -- | Speed in meters per second, only if a 'Time' was recorded for each waypoint.-speed :: (Lat loc, Lon loc, Time loc, Lat b, Lon b, Time b) => loc -> b -> Maybe Speed+speed :: (LatL loc, LonL loc, TimeL loc, LatL b, LonL b, TimeL b) => loc -> b -> Maybe Speed speed a b =    case (getUTCTime b, getUTCTime a) of     (Just x, Just y) -> @@ -115,7 +130,7 @@ radiusOfEarth :: Double radiusOfEarth = 6378700 --- |Circumference of earht (meters)+-- |Circumference of earth (meters) circumferenceOfEarth :: Double circumferenceOfEarth = radiusOfEarth * 2 * pi @@ -137,50 +152,96 @@  toDegrees = (*) (180 / pi) -getRadianPairD :: (Lat c, Lon c) => c -> (Double,Double)+getRadianPairD :: (LatL c, LonL c) => c -> (Double,Double) getRadianPairD = (\(a,b) -> (realToFrac a, realToFrac b)) . getRadianPair -getDMSPair :: (Lat c, Lon c) => c -> (LatitudeType, LongitudeType)-getDMSPair c = (lat c, lon c)+getDMSPair :: (LatL c, LonL c) => c -> (Latitude, Longitude)+getDMSPair c = (c ^. latL, c ^. lonL)  -- |Provides a lat/lon pair of doubles in radians-getRadianPair :: (Lat p, Lon p) => p -> (LatitudeType, LongitudeType)-getRadianPair p = (toRadians (lat p), toRadians (lon p))+getRadianPair :: (LatL p, LonL p) => p -> (Latitude, Longitude)+getRadianPair p = (toRadians (p ^. latL), toRadians (p ^. lonL))  toRadians :: Floating f => f -> f toRadians = (*) (pi / 180) --- | @interpolate c1 c2 w@ where 0 <= w <= 1 Gives a point on the line--- between c1 and c2 equal to @c1 when @w == 0@ (weighted linearly+-- | @interpolate c1 c2 w@ where @0 <= w <= 1@ Gives a point on the line+-- between c1 and c2 equal to c1 when @w == 0@ (weighted linearly -- toward c2).-interpolate :: (Lat a, Lon a) => a -> a -> Double -> a+interpolate :: (LatL a, LonL a) => a -> a -> Double -> a interpolate c1 c2 w   | w < 0 || w > 1 = error "Interpolate only works with a weight between zero and one"   | otherwise =    let (h,d) = (heading c1 c2, distance c1 c2)       v = (d * w, h)   in addVector v c1-     ++-- | Compute the points at which two circles intersect (assumes a flat plain).  If+-- the circles do not intersect or are identical then the result is @Nothing@.+circleIntersectionPoints :: (LatL a, LonL a) => (a, Distance) -> (a, Distance) -> Maybe (a,a)+circleIntersectionPoints (a,r1) (b,r2)+  | a ^. latL == b ^. latL && a ^. lonL == b ^. lonL && r1 == r2 = Nothing -- FIXME need approx eq+  | r1 + r2 < ab = Nothing+  | any isNaN (map (^. latL) pts) || any isNaN (map (^. lonL) pts) = Nothing+  | otherwise = Just (p1, p2)+  where+  ab = distance a b+  angABX = acos ( (r1^2 + ab^2 - r2^2) / (2 * r1 * ab) )+  ang1 = heading a b + angABX+  ang2 = heading a b - angABX+  p1 = addVector (r1, ang1) a+  p2 = addVector (r1, ang2) a+  pts = [p1,p2]++-- | Find the area in which all given circles intersect.  The resulting+-- area is described in terms of the bounding arcs.   All cirlces must+-- intersect at two points.+intersectionArcsOf :: (LatL a, LonL a) => [Circle a] -> [Arc a]+intersectionArcsOf cs =+  let isArcWithinCircle circ arc = maximumDistanceOfArc (fst circ) arc <= (snd circ)+      isArcWithinAllCircles arc = all ($ arc) (map isArcWithinCircle cs)+      -- getArcs :: Circle a -> Circle a -> [Arc a]+      getArcs c1 c2 = concatMap (buildArcsFromPoints c1 c2) . maybeToList $ circleIntersectionPoints c1 c2+      -- buildArcsFromPoints :: (a, a) -> [Arc a]+      buildArcsFromPoints c1 c2 (p1,p2) =+          let c1h1 = heading (fst c1) p1+              c1h2 = heading (fst c1) p2+              c2h1 = heading (fst c2) p1+              c2h2 = heading (fst c2) p2+          in [(c1,c1h1,c1h2), (c1,c1h2, c1h1), (c2,c2h1,c2h2), (c2,c2h2,c2h1)]+  in filter isArcWithinAllCircles . concatMap (uncurry getArcs) . choose2 $ cs++maximumDistanceOfArc :: (LatL a, LonL a) => a -> Arc a -> Distance+maximumDistanceOfArc pnt ((c,r), h1, h2) =+  let pcHeading = heading pnt c+  in if ((pcHeading < h1 || pcHeading > h2) && h1 < h2) || ((pcHeading > h2 && pcHeading < h1) && h1 > h2)+         then max (distance pnt (addVector (r,h1) c)) (distance pnt (addVector (r,h2) c))+         else distance pnt c + r++choose2 :: [a] -> [(a,a)]+choose2 [] = []+choose2 (x:xs) = map (x,) xs ++ choose2 xs+ -- |@divideArea vDist hDist nw se@ divides an area into a grid of equally -- spaced coordinates within the box drawn by the northwest point (nw) and -- southeast point (se).  Because this uses floating point there might be a -- different number of points in some rows (the last might be too far east based -- on a heading from the se point).-divideArea :: (Lat c, Lon c) => Distance -> Distance -> c -> c -> [[c]]+divideArea :: (LatL c, LonL c) => Distance -> Distance -> c -> c -> [[c]] divideArea vDist hDist nw se =-	let (top,left)  = (lat nw, lon nw)-	    (btm,right) = (lat se, lon se)+	let (top,left)  = (nw ^. latL, nw ^. lonL)+	    (btm,right) = (se ^. latL, se ^. lonL) 	    columnOne = takeWhile ( (<= west) . heading se) . iterate (addVector (vDist, south)) $ nw 	    buildRow  = takeWhile ((>= north) . heading se) . iterate (addVector (hDist, east)) 	in map buildRow columnOne  -- |Reads a GPX file (using the GPX library) by simply concatenating all the -- tracks, segments, and points ('trkpts', 'trksegs', 'trks') into a single 'Trail'.-readGPX :: FilePath -> IO (Trail WptType)-readGPX = liftM (concatMap trkpts . concatMap trksegs . concatMap trks) . readGpxFile+readGPX :: FilePath -> IO (Trail Wpt)+readGPX = liftM (concatMap (^. trkptsL). concatMap (^. trksegsL) . concatMap (^. trksL)) . readGpxFile -writeGPX :: FilePath -> Trail WptType -> IO ()-writeGPX fp ps = writeGpxFile fp $ gpx $ gpxType "1.0" "Haskell GPS Package (via the GPX package)" Nothing [] [] [trkType Nothing Nothing Nothing Nothing [] Nothing Nothing Nothing [trksegType ps Nothing]] Nothing+writeGPX :: FilePath -> Trail Wpt -> IO ()+writeGPX fp ps = writeGpxFile fp $ gpx "1.0" "Haskell GPS Package (via the GPX package)" Nothing [] [] [trk Nothing Nothing Nothing Nothing [] Nothing Nothing Nothing [trkseg ps Nothing]] Nothing  -- writeGpxFile should go in the GPX package writeGpxFile :: FilePath -> Gpx -> IO ()@@ -188,5 +249,8 @@  runX_ t = runX t >> return () -readGPXSegments :: FilePath -> IO [Trail WptType]-readGPXSegments = liftM (map (concatMap trkpts) . map trksegs . concatMap trks) . readGpxFile+readGPXSegments :: FilePath -> IO [Trail Wpt]+readGPXSegments = liftM (map (concatMap (^. trkptsL)) . map (^. trksegsL) . concatMap (^. trksL)) . readGpxFile++readGpxFile :: FilePath -> IO [Gpx]+readGpxFile = runX . xunpickleDocument (xpickle :: PU Gpx) [withRemoveWS yes, withValidate no]

@@ -56,6 +56,7 @@ import Data.Maybe import Data.Ord import Data.Time+import Data.Lens.Common  import Statistics.Function as F import Statistics.Sample@@ -81,12 +82,12 @@ -- | @avgSpeeds n points@ -- Average speed using a window of up to @n@ seconds and averaging by taking the -- Median ('AvgMedian').-avgSpeeds :: (Lat a, Lon a, Time a) => NominalDiffTime -> Trail a -> [(UTCTime, Speed)]+avgSpeeds :: (LatL a, LonL a, TimeL a) => NominalDiffTime -> Trail a -> [(UTCTime, Speed)] avgSpeeds = slidingAverageSpeed AvgHarmonicMean  -- | @slidingAverageSpeed m n@ Average speed using a moving window of up to @n@ seconds -- and an 'AvgMethod' of @m@.-slidingAverageSpeed :: (Lat a, Lon a, Time a) => +slidingAverageSpeed :: (LatL a, LonL a, TimeL a) =>                         AvgMethod a -> NominalDiffTime -> Trail a -> [(UTCTime, Speed)] slidingAverageSpeed _ _ [] = [] slidingAverageSpeed m minTime xs =@@ -174,7 +175,7 @@ -- and all others outside of the speed.  The "speed" from point p(i) -- to p(i+1) is associated with p(i) (execpt for the first speed -- value, which is associated with both the first and second point)-betweenSpeeds :: (Lat a, Lon a, Time a) => Double -> Double -> PointGrouping a+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]@@ -188,7 +189,7 @@  -- | A "rest point" means the coordinates remain within a given distance -- for at least a particular amount of time.-restLocations :: (Lat a, Lon a, Time a) => Distance -> NominalDiffTime -> PointGrouping a+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@@ -207,7 +208,7 @@       -- |chunking points into groups spanning at most the given time -- interval.-spansTime :: (Lat a, Lon a, Time a) => NominalDiffTime -> PointGrouping a+spansTime :: (LatL a, LonL a, TimeL a) => NominalDiffTime -> PointGrouping a spansTime n ps =   let times  = mkTimePair ps       chunk [] = []@@ -217,7 +218,7 @@   in map (Select . map fst) $ chunk times  -- | intersects the given groupings-intersectionOf :: (Lat a, Lon a, Time a) => [PointGrouping a] -> PointGrouping a+intersectionOf :: (LatL a, LonL a, TimeL a) => [PointGrouping a] -> PointGrouping a intersectionOf gs ps =   let groupings = map ($ ps) gs       -- chunk :: [[Selected [pnts]]] -> pnts -> [pnts]@@ -230,7 +231,7 @@   in chunk groupings ps  -- | Union all the groupings-unionOf :: (Lat a, Lon a, Time a) => [PointGrouping a] -> PointGrouping a+unionOf :: (LatL a, LonL a, TimeL a) => [PointGrouping a] -> PointGrouping a unionOf gs ps =   let groupings = map ($ ps) gs       chunk _ [] = []@@ -327,7 +328,7 @@  -- Extract the time from each coordinate.  If no time is available then -- the coordinate is dropped!-mkTimePair :: (Time a) => Trail a -> [(a,UTCTime)]+mkTimePair :: (TimeL a) => Trail a -> [(a,UTCTime)] mkTimePair xs =   let timesM = map (\x-> fmap (x,) $ getUTCTime x) xs   in concatMap maybeToList timesM@@ -337,7 +338,7 @@ -- The current implementation assumes the times of the input -- coordinates are available and all equal (Ex: all points are 5 -- seconds apart), the results will be poor if this is not the case!-bezierCurveAt :: (Lat a, Lon a, Time a) => [UTCTime] -> Trail a -> Trail a+bezierCurveAt :: (LatL a, LonL a, TimeL a) => [UTCTime] -> Trail a -> Trail a bezierCurveAt _ [] = [] bezierCurveAt selectedTimes xs =    let timesDef = mkTimePair xs@@ -354,9 +355,9 @@          then xs          else let curvePoints = (map (bezierPoint xs) queryTimes)                   newTimes = [addUTCTime t (snd top) | t <- diffTimes]-              in zipWith (setTime . Just . fromUTCTime) newTimes curvePoints+              in zipWith ((timeL ^=) . Just . fromUTCTime) newTimes curvePoints -bezierPoint :: (Lat a, Lon a) => [a] -> Double -> a+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"@@ -367,12 +368,12 @@ -- exponentially more expensive with the length of the segement being -- transformed - it is not advisable to perform this operation on -- trail segements with more than ten points!-bezierCurve ::  (Lat a, Lon a, Time a) => [Selected (Trail a)] -> Trail a+bezierCurve ::  (LatL a, LonL a, TimeL a) => [Selected (Trail a)] -> Trail a bezierCurve = concatMap (onSelected (bezierCurveAt []) Prelude.id)  -- |Filters out any points that go backward in time (thus must not be -- valid if this is a trail)-linearTime :: (Lon a, Lat a, Time a) => [a] -> [a]+linearTime :: (LonL a, LatL a, TimeL a) => [a] -> [a] linearTime [] = [] linearTime (p:ps) = go (getUTCTime p) ps   where@@ -382,21 +383,21 @@ -- |Returns the closest distance between two trails (or Nothing if a -- trail is empty).  Inefficient implementation: -- O( (n * m) * log (n * m) )-closestDistance :: (Lat a, Lon a) => Trail a -> Trail a -> Maybe Distance+closestDistance :: (LatL a, LonL a) => Trail a -> Trail a -> Maybe Distance closestDistance as bs = listToMaybe $ L.sort [distance a b | a <- as, b <- bs]  -- | Find the total distance traveled-totalDistance :: (Lat a, Lon a) => [a] -> Distance+totalDistance :: (LatL a, LonL a) => [a] -> Distance totalDistance as = sum $ zipWith distance as (drop 1 as) -totalTime :: Time a => Trail a -> NominalDiffTime+totalTime :: TimeL a => Trail a -> NominalDiffTime totalTime [] = 0 totalTime xs@(x:_) = fromMaybe 0 $ liftM2 diffUTCTime (getUTCTime x) (getUTCTime $ last xs)  -- | Uses Grahams scan to compute the convex hull of the given points. -- This operation requires sorting of the points, so don't try it unless -- you have notably more memory than the list of points will consume.-convexHull :: (Eq c, Lat c, Lon c) => [c] -> [c]+convexHull :: (Eq c, LatL c, LonL c) => [c] -> [c] convexHull xs = 	let first = southMost xs 	in case first of@@ -416,12 +417,12 @@ 		Straight  -> grahamScan (x:p2:p1:ps) xs 		_	  -> grahamScan (p1:ps) (x:xs) -eastZeroHeading :: (Lat c, Lon c) => c -> c -> Heading+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 :: (Lat c, Lon c) => c -> c -> c -> Turn+turn :: (LatL c, LonL c) => c -> c -> c -> Turn turn a b c = 	let h1 = eastZeroHeading a b 	    h2 = eastZeroHeading b c@@ -429,9 +430,9 @@ 	in if d >= 0 && d < pi then LeftTurn else RightTurn  -- | Find the southmost point-southMost :: (Lat c) => [c] -> Maybe c+southMost :: (LatL c) => [c] -> Maybe c southMost []  = Nothing-southMost cs = Just . minimumBy (comparing lat) $ cs+southMost cs = Just . minimumBy (comparing (^. latL)) $ cs  ---------- COMPOSIT OPERATIONS --------------- -- These operations are simply implemented using the previously@@ -439,10 +440,10 @@ -- users or as instructional examples. ------------------------------------------ -smoothRests :: (Lat a, Lon a, Time a) => Trail a -> Trail a+smoothRests :: (LatL a, LonL a, TimeL a) => Trail a -> Trail a smoothRests = bezierCurve . refineGrouping (everyNPoints 8) . restLocations 30 60 -smoothSome :: (Lat a, Lon a, Time a) => Trail a -> Trail a+smoothSome :: (LatL a, LonL a, TimeL a) => Trail a -> Trail a smoothSome = gSmoothSome 7  gSmoothSome n = bezierCurve . everyNPoints n@@ -452,7 +453,7 @@       (h,t) = splitAt k ps'   in h ++ gSmoothSome n t -smoothMore :: (Lat a, Lon a, Time a) => Trail a -> Trail a+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

@@ -1,10 +1,10 @@ name:		gps-version:	0.8.4+version:	0.9 license:	BSD3 license-file:	LICENSE author:		Thomas DuBuisson <thomas.dubuisson@gmail.com> maintainer:	Thomas DuBuisson-description:	Useful for manipulating GPS coordinages (in various forms), building paths, and performing basic computations.  NOTE: Version range 0.8.* won't strictly follow PVP - I will be adding additional functions in minor releases 0.8.x.+description:	Useful for manipulating GPS coordinages (in various forms), building paths, and performing basic computations. synopsis:	For manipulating GPS coordinates and trails. category:	Data stability:	stable@@ -16,8 +16,9 @@ Library   Build-Depends: base >= 3 && < 6,                    pretty >= 1.0 , prettyclass >= 1.0,-                   time >= 1.1, GPX >= 0.5, hxt >= 9.1, xsd >= 0.3,-                   vector >= 0.7, statistics >= 0.9+                   time >= 1.1, GPX >= 0.6 && < 0.7+                 , hxt >= 9.1 && < 9.2, xsd >= 0.3 && < 0.4,+                   vector >= 0.7, statistics >= 0.9, data-lens >= 2.0 && < 2.1   hs-source-dirs:   exposed-modules: Data.GPS   other-modules: Data.GPS.Core Data.GPS.Trail