Merge branch 'master' of [email protected]:PaulJohnson/geodetics

geodetics.cabal

@@ -58,7 +58,8 @@ 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

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 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 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)
-
+   mappend = (<>)
 
 -- | The inverse of a Helmert transformation.
 inverseHelmert :: Helmert -> Helmert

src/Geodetics/Grid.hs

@@ -23,7 +23,8 @@ 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 hiding ((.))
@@ -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.
 --

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)
    ]