summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPaulJohnson <>2018-04-16 07:54:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-04-16 07:54:00 (GMT)
commiteb9c19cee0a4355451e0f3e1d8b5ff39cab75011 (patch)
tree00f5144964637e6ed5e8d790ccf39cf7c66b469e
parent2651060f3b958c804869c7b6454bdbc4c07cd4ca (diff)
version 0.0.50.0.5
-rw-r--r--geodetics.cabal18
-rw-r--r--src/Geodetics/Ellipsoids.hs15
-rw-r--r--src/Geodetics/Geodetic.hs2
-rw-r--r--src/Geodetics/Grid.hs14
-rw-r--r--src/Geodetics/TransverseMercator.hs2
-rw-r--r--test/Main.hs21
6 files changed, 54 insertions, 18 deletions
diff --git a/geodetics.cabal b/geodetics.cabal
index df395cc..dbac9a4 100644
--- a/geodetics.cabal
+++ b/geodetics.cabal
@@ -1,5 +1,5 @@
name: geodetics
-version: 0.0.4
+version: 0.0.5
cabal-version: >= 1.10
build-type: Simple
author: Paul Johnson <paul@cogito.org.uk>
@@ -50,7 +50,7 @@ test-suite GeodeticTest
type: exitcode-stdio-1.0
main-is: Main.hs
x-uses-tf: true
- build-depends:
+ build-depends: geodetics,
base >= 4.6 && < 5,
HUnit >= 1.2,
dimensional >= 0.13,
@@ -58,12 +58,22 @@ test-suite GeodeticTest
test-framework >= 0.4.1,
test-framework-quickcheck2,
test-framework-hunit,
- array >= 0.4
+ array >= 0.4,
+ checkers
hs-source-dirs:
src,
test
ghc-options: -Wall -rtsopts
other-modules:
ArbitraryInstances,
- Main
+ Main,
+ Geodetics.Altitude,
+ Geodetics.Ellipsoids
+ Geodetics.Geodetic,
+ Geodetics.Grid,
+ Geodetics.LatLongParser,
+ Geodetics.Path,
+ Geodetics.Stereographic,
+ Geodetics.TransverseMercator,
+ Geodetics.UK
Default-Language: Haskell2010
diff --git a/src/Geodetics/Ellipsoids.hs b/src/Geodetics/Ellipsoids.hs
index 3127e5b..c4a1597 100644
--- a/src/Geodetics/Ellipsoids.hs
+++ b/src/Geodetics/Ellipsoids.hs
@@ -39,7 +39,8 @@ module Geodetics.Ellipsoids (
cross3
) where
-import Data.Monoid
+import Data.Monoid (Monoid)
+import Data.Semigroup (Semigroup, (<>))
import Numeric.Units.Dimensional
import Numeric.Units.Dimensional.Prelude
import Prelude () -- Numeric instances.
@@ -110,12 +111,14 @@ data Helmert = Helmert {
helmertScale :: Dimensionless Double, -- ^ Parts per million
rX, rY, rZ :: Dimensionless Double } deriving (Eq, Show)
-instance Monoid Helmert where
- mempty = Helmert (0 *~ meter) (0 *~ meter) (0 *~ meter) _1 _0 _0 _0
- mappend h1 h2 = Helmert (cX h1 + cX h2) (cY h1 + cY h2) (cZ h1 + cZ h2)
- (helmertScale h1 + helmertScale h2)
- (rX h1 + rX h2) (rY h1 + rY h2) (rZ h1 + rZ h2)
+instance Semigroup Helmert where
+ h1 <> h2 = Helmert (cX h1 + cX h2) (cY h1 + cY h2) (cZ h1 + cZ h2)
+ (helmertScale h1 + helmertScale h2)
+ (rX h1 + rX h2) (rY h1 + rY h2) (rZ h1 + rZ h2)
+instance Monoid Helmert where
+ mempty = Helmert (0 *~ meter) (0 *~ meter) (0 *~ meter) _0 _0 _0 _0
+ mappend = (<>)
-- | The inverse of a Helmert transformation.
inverseHelmert :: Helmert -> Helmert
diff --git a/src/Geodetics/Geodetic.hs b/src/Geodetics/Geodetic.hs
index 8055426..283a0ce 100644
--- a/src/Geodetics/Geodetic.hs
+++ b/src/Geodetics/Geodetic.hs
@@ -26,7 +26,7 @@ import Data.Monoid
import Geodetics.Altitude
import Geodetics.Ellipsoids
import Geodetics.LatLongParser
-import Numeric.Units.Dimensional.Prelude
+import Numeric.Units.Dimensional.Prelude hiding ((.))
import Text.ParserCombinators.ReadP
import qualified Prelude as P
diff --git a/src/Geodetics/Grid.hs b/src/Geodetics/Grid.hs
index 7162059..43d609b 100644
--- a/src/Geodetics/Grid.hs
+++ b/src/Geodetics/Grid.hs
@@ -23,10 +23,11 @@ module Geodetics.Grid (
import Data.Char
import Data.Function
-import Data.Monoid
+import Data.Monoid (Monoid)
+import Data.Semigroup (Semigroup, (<>))
import Geodetics.Altitude
import Geodetics.Geodetic
-import Numeric.Units.Dimensional.Prelude
+import Numeric.Units.Dimensional.Prelude hiding ((.))
import qualified Prelude as P
-- | A Grid is a two-dimensional projection of the ellipsoid onto a plane. Any given type of grid can
@@ -69,11 +70,14 @@ data GridOffset = GridOffset {
deltaEast, deltaNorth, deltaAltitude :: Length Double
} deriving (Eq, Show)
+instance Semigroup GridOffset where
+ g1 <> g2 = GridOffset (deltaEast g1 + deltaEast g2)
+ (deltaNorth g1 + deltaNorth g2)
+ (deltaAltitude g1 + deltaAltitude g2)
+
instance Monoid GridOffset where
mempty = GridOffset _0 _0 _0
- mappend g1 g2 = GridOffset (deltaEast g1 + deltaEast g2)
- (deltaNorth g1 + deltaNorth g2)
- (deltaAltitude g1 + deltaAltitude g2)
+ mappend = (<>)
-- | An offset defined by a distance and a bearing to the right of North.
--
diff --git a/src/Geodetics/TransverseMercator.hs b/src/Geodetics/TransverseMercator.hs
index 54aeb6b..7a14098 100644
--- a/src/Geodetics/TransverseMercator.hs
+++ b/src/Geodetics/TransverseMercator.hs
@@ -10,7 +10,7 @@ import Data.Monoid
import Geodetics.Ellipsoids
import Geodetics.Geodetic
import Geodetics.Grid
-import Numeric.Units.Dimensional.Prelude
+import Numeric.Units.Dimensional.Prelude hiding ((.))
import Prelude ()
-- | A Transverse Mercator projection gives an approximate mapping of the ellipsoid on to a 2-D grid. It models
diff --git a/test/Main.hs b/test/Main.hs
index cdfd0ba..d55d17e 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
@@ -12,6 +13,8 @@ import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2 (testProperty)
import qualified Test.HUnit as HU
import Test.QuickCheck
+import Test.QuickCheck.Checkers (EqProp, eq, (=-=), unbatch)
+import Test.QuickCheck.Classes (monoid)
import ArbitraryInstances
import Geodetics.Altitude
@@ -38,6 +41,20 @@ main = do
defaultMainWithOpts tests my_runner_opts
+instance EqProp GridOffset where
+ (GridOffset a b c) =-= (GridOffset a' b' c') =
+ eq True $ a ≈ a' && b ≈ b' && c ≈ c'
+ where x ≈ y = abs (x - y) < 0.00001 *~ meter
+
+instance EqProp Helmert where
+ (Helmert cX' cY' cZ' s rX' rY' rZ') =-= (Helmert cX'' cY'' cZ'' s' rX'' rY'' rZ'') =
+ eq True $ and [cX' ≈ cX'', cY' ≈ cY'', cZ' ≈ cZ'',
+ s ≈- s',
+ rX' ≈- rX'', rY' ≈- rY'', rZ' ≈- rZ'']
+
+ where x ≈ y = abs (x - y) < 0.00001 *~ meter
+ x ≈- y = abs (x - y) < (_1 / (_5 * _2) ** (_5))
+
tests :: [Test]
tests = [
testGroup "Geodetic" [
@@ -69,7 +86,9 @@ tests = [
testProperty "Ray Bisection" prop_rayBisect,
testProperty "Rhumb Continuity" prop_rhumbContinuity,
testProperty "Rhumb Intersection" prop_rhumbIntersect
- ]
+ ],
+ testGroup "GridOffset" $ map (uncurry testProperty) $ unbatch $ monoid (mempty :: GridOffset),
+ testGroup "Helmert" $ map (uncurry testProperty) $ unbatch $ monoid (mempty :: Helmert)
]