diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,31 @@ +Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation +(CSIRO) ABN 41 687 119 230. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of QFPL nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +0.0.1 + +* This change log starts. +* The initial version of geodetic-types. diff --git a/geodetic-types.cabal b/geodetic-types.cabal new file mode 100644 --- /dev/null +++ b/geodetic-types.cabal @@ -0,0 +1,45 @@ +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: geodetic-types +version: 0.0.1 +synopsis: Types for geodetic operations +description: + <> + . + Geodetic types. +license: BSD3 +license-file: LICENCE +author: Queensland Functional Programming Lab +maintainer: Queensland Functional Programming Lab +copyright: Copyright (C) 2018 Commonwealth Scientific and Industrial Research Organisation (CSIRO) +category: Geodgraphy +build-type: Simple +extra-source-files: changelog.md +cabal-version: >=1.10 +homepage: https://github.com/qfpl/geodetic-types +bug-reports: https://github.com/qfpl/geodetic-types/issues +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 + +source-repository head + type: git + location: git@github.com:qfpl/geodetic-types.git + +library + exposed-modules: Geodetics.Types + , Geodetics.Types.Altitude + , Geodetics.Types.Ellipsoid + , Geodetics.Types.Helmert + , Geodetics.Types.Latitude + , Geodetics.Types.Longitude + , Geodetics.Types.TRF + + build-depends: base >= 4.8 && < 4.12 + , lens >= 4.15 && < 4.18 + , dimensional >= 1 && < 1.2 + , semigroups >= 0.9 && < 0.19 + + hs-source-dirs: src + + default-language: Haskell2010 + + ghc-options: -Wall diff --git a/src/Geodetics/Types.hs b/src/Geodetics/Types.hs new file mode 100644 --- /dev/null +++ b/src/Geodetics/Types.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Geodetics.Types( + module T +) where + +import Geodetics.Types.Altitude as T +import Geodetics.Types.Ellipsoid as T +import Geodetics.Types.Helmert as T +import Geodetics.Types.Latitude as T +import Geodetics.Types.Longitude as T +import Geodetics.Types.TRF as T diff --git a/src/Geodetics/Types/Altitude.hs b/src/Geodetics/Types/Altitude.hs new file mode 100644 --- /dev/null +++ b/src/Geodetics/Types/Altitude.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +module Geodetics.Types.Altitude( + Altitude(..) +, HasAltitude(..) +, AsAltitude(..) +, ManyAltitude(..) +, GetAltitude(..) +, SetAltitude(..) +, FoldAltitude(..) +, IsAltitude(..) +, groundPosition +) where + +import Control.Category((.), id) +import Control.Lens(Lens', Prism', Traversal', Getter, Setter', Fold, Iso', Wrapped(_Wrapped'), Unwrapped, iso, prism, set) +import Data.Either(Either(Right)) +import Data.Eq(Eq) +import Data.Functor(fmap) +import Data.Ord(Ord) +import Numeric.Units.Dimensional.Prelude(Length, _0) +import Prelude(Double, Show) + +newtype Altitude = + Altitude + (Length Double) + deriving (Eq, Ord, Show) + +instance Wrapped Altitude where + type Unwrapped Altitude = + Length Double + _Wrapped' = + iso + (\(Altitude x) -> x) + Altitude + +class HasAltitude a where + altitude :: + Lens' a Altitude + altitudeLength :: + Lens' a (Length Double) + {-# INLINE altitudeLength #-} + altitudeLength = + altitude . altitudeLength + +instance HasAltitude Altitude where + altitude = + id + altitudeLength k (Altitude x) = + fmap Altitude (k x) + +class ManyAltitude a => AsAltitude a where + _Altitude :: + Prism' a Altitude + _AltitudeFields :: + Prism' a (Length Double) + _AltitudeFields = + _Altitude . _AltitudeFields + +instance AsAltitude Altitude where + _Altitude = + id + _AltitudeFields = + prism + Altitude + (\(Altitude x) -> Right x) + +class (FoldAltitude a, SetAltitude a) => ManyAltitude a where + _ManyAltitude :: + Traversal' a Altitude + +instance ManyAltitude Altitude where + _ManyAltitude = + id + +class FoldAltitude a => GetAltitude a where + _GetAltitude :: + Getter a Altitude + +instance GetAltitude Altitude where + _GetAltitude = + id + +class SetAltitude a where + _SetAltitude :: + Setter' a Altitude + +instance SetAltitude Altitude where + _SetAltitude = + id + +class FoldAltitude a where + _FoldAltitude :: + Fold a Altitude + +instance FoldAltitude Altitude where + _FoldAltitude = + id + +class (HasAltitude a, AsAltitude a) => IsAltitude a where + _IsAltitude :: + Iso' a Altitude + +instance IsAltitude Altitude where + _IsAltitude = + id +groundPosition :: + HasAltitude a => + a + -> a +groundPosition = + set altitude (Altitude _0) diff --git a/src/Geodetics/Types/Ellipsoid.hs b/src/Geodetics/Types/Ellipsoid.hs new file mode 100644 --- /dev/null +++ b/src/Geodetics/Types/Ellipsoid.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Geodetics.Types.Ellipsoid( + Ellipsoid(..) +, HasEllipsoid(..) +, AsEllipsoid(..) +, ManyEllipsoid(..) +, GetEllipsoid(..) +, SetEllipsoid(..) +, FoldEllipsoid(..) +, IsEllipsoid(..) +, _GRS80 +, _GRS67 +, _Ans +, _WGS72 +, _AU1965 +, _Krasovsky1940 +, _International1924 +, _Hayford1909 +, _Airy1830 +, _Everest1830 +, _Clarke1858 +, _Clarke1880 +) where + +import Control.Category((.), id) +import Control.Lens(Lens', Prism', Traversal', Getter, Setter', Fold, Iso', prism) +import Data.Either(Either(Right)) +import Data.Eq(Eq) +import Data.Ord(Ord) +import Data.Functor(fmap) +import Data.Tuple(uncurry) +import Numeric.Units.Dimensional.Prelude(Length, Dimensionless, (*~), meter, one) +import Prelude(Double, Show) + +data Ellipsoid = + Ellipsoid + (Length Double) -- majorRadius + (Dimensionless Double) -- flatR + deriving (Eq, Ord, Show) + +class (GetEllipsoid a, ManyEllipsoid a) => HasEllipsoid a where + ellipsoid :: + Lens' a Ellipsoid + majorRadius :: + Lens' a (Length Double) + {-# INLINE majorRadius #-} + flatR :: + Lens' a (Dimensionless Double) + {-# INLINE flatR #-} + majorRadius = + ellipsoid . majorRadius + flatR = + ellipsoid . flatR + +instance HasEllipsoid Ellipsoid where + ellipsoid = + id + majorRadius k (Ellipsoid r f) = + fmap (\r' -> Ellipsoid r' f) (k r) + {-# INLINE majorRadius #-} + flatR k (Ellipsoid r f) = + fmap (\f' -> Ellipsoid r f') (k f) + {-# INLINE flatR #-} + +class ManyEllipsoid a => AsEllipsoid a where + _Ellipsoid :: + Prism' a Ellipsoid + _EllipsoidFields :: + Prism' a (Length Double, Dimensionless Double) + _EllipsoidFields = + _Ellipsoid . _EllipsoidFields + +instance AsEllipsoid Ellipsoid where + _Ellipsoid = + id + _EllipsoidFields = + prism + (uncurry Ellipsoid) + (\(Ellipsoid r f) -> Right (r, f)) + +class (FoldEllipsoid a, SetEllipsoid a) => ManyEllipsoid a where + _ManyEllipsoid :: + Traversal' a Ellipsoid + +instance ManyEllipsoid Ellipsoid where + _ManyEllipsoid = + id + +class FoldEllipsoid a => GetEllipsoid a where + _GetEllipsoid :: + Getter a Ellipsoid + +instance GetEllipsoid Ellipsoid where + _GetEllipsoid = + id + +class SetEllipsoid a where + _SetEllipsoid :: + Setter' a Ellipsoid + +instance SetEllipsoid Ellipsoid where + _SetEllipsoid = + id + +class FoldEllipsoid a where + _FoldEllipsoid :: + Fold a Ellipsoid + +instance FoldEllipsoid Ellipsoid where + _FoldEllipsoid = + id + +class (HasEllipsoid a, AsEllipsoid a) => IsEllipsoid a where + _IsEllipsoid :: + Iso' a Ellipsoid + +instance IsEllipsoid Ellipsoid where + _IsEllipsoid = + id + +_GRS80 :: + Ellipsoid +_GRS80 = + Ellipsoid + (6378137.0 *~ meter) + (294.25722100882711 *~ one) + +_GRS67 :: + Ellipsoid +_GRS67 = + Ellipsoid + (6378160 *~ meter) + (298.25 *~ one) + +_Ans :: + Ellipsoid +_Ans = + Ellipsoid + (6378160 *~ meter) + (298.25 *~ one) + +_WGS72 :: + Ellipsoid +_WGS72 = + Ellipsoid + (6378135 *~ meter) + (298.26 *~ one) + +_AU1965 :: + Ellipsoid +_AU1965 = + Ellipsoid + (6378160 *~ meter) + (298.25 *~ one) + +_Krasovsky1940 :: + Ellipsoid +_Krasovsky1940 = + Ellipsoid + (6378245 *~ meter) + (298.3 *~ one) + +_International1924 :: + Ellipsoid +_International1924 = + Ellipsoid + (6378388 *~ meter) + (297 *~ one) + +_Hayford1909 :: + Ellipsoid +_Hayford1909 = + Ellipsoid + (6378388 *~ meter) + (297 *~ one) + +_Airy1830 :: + Ellipsoid +_Airy1830 = + Ellipsoid + (6377563.4 *~ meter) + (299.32 *~ one) + +_Everest1830 :: + Ellipsoid +_Everest1830 = + Ellipsoid + (6377276.3 *~ meter) + (300.8 *~ one) + +_Clarke1858 :: + Ellipsoid +_Clarke1858 = + Ellipsoid + (6378293.645 *~ meter) + (294.26 *~ one) + +_Clarke1880 :: + Ellipsoid +_Clarke1880 = + Ellipsoid + (6378249.145 *~ meter) + (293.465 *~ one) diff --git a/src/Geodetics/Types/Helmert.hs b/src/Geodetics/Types/Helmert.hs new file mode 100644 --- /dev/null +++ b/src/Geodetics/Types/Helmert.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Geodetics.Types.Helmert( + Helmert(..) +, HasHelmert(..) +, AsHelmert(..) +, ManyHelmert(..) +, GetHelmert(..) +, SetHelmert(..) +, FoldHelmert(..) +, IsHelmert(..) +, translations +, rotations +) where + +import Control.Applicative((<*>)) +import Control.Category((.), id) +import Control.Lens(Lens', Prism', Traversal', Getter, Setter', Fold, Iso', prism, (^.)) +import Data.Either(Either(Right)) +import Data.Eq(Eq) +import Data.Ord(Ord) +import Data.Functor(fmap, (<$>)) +import Data.Monoid(Monoid(mempty, mappend)) +import Data.Semigroup(Semigroup((<>))) +import Numeric.Units.Dimensional.Prelude(Length, Dimensionless, (+), (*~), meter, _0) +import Prelude(Double, Show) + +-- | The 7 parameter Helmert transformation. The monoid instance allows composition. +data Helmert = + Helmert + (Length Double) + (Length Double) + (Length Double) + (Dimensionless Double) -- Parts per million + (Dimensionless Double) + (Dimensionless Double) + (Dimensionless Double) + deriving (Eq, Ord, Show) + +class HasHelmert a where + helmert :: + Lens' a Helmert + cX :: + Lens' a (Length Double) + {-# INLINE cX #-} + cY :: + Lens' a (Length Double) + {-# INLINE cY #-} + cZ :: + Lens' a (Length Double) + {-# INLINE cZ #-} + helmertScale :: + Lens' a (Dimensionless Double) + {-# INLINE helmertScale #-} + rX :: + Lens' a (Dimensionless Double) + {-# INLINE rX #-} + rY :: + Lens' a (Dimensionless Double) + {-# INLINE rY #-} + rZ :: + Lens' a (Dimensionless Double) + {-# INLINE rZ #-} + cX = + helmert . cX + cY = + helmert . cY + cZ = + helmert . cZ + helmertScale = + helmert . helmertScale + rX = + helmert . rX + rY = + helmert . rY + rZ = + helmert . rZ + +instance HasHelmert Helmert where + {-# INLINE cX #-} + {-# INLINE cY #-} + {-# INLINE cZ #-} + {-# INLINE helmertScale #-} + {-# INLINE rX #-} + {-# INLINE rY #-} + {-# INLINE rZ #-} + helmert = + id + cX k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + fmap (\x -> Helmert x cY' cZ' helmertScale' rX' rY' rZ') (k cX') + cY k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + fmap (\x -> Helmert cX' x cZ' helmertScale' rX' rY' rZ') (k cY') + cZ k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + fmap (\x -> Helmert cX' cY' x helmertScale' rX' rY' rZ') (k cZ') + helmertScale k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + fmap (\x -> Helmert cX' cY' cZ' x rX' rY' rZ') (k helmertScale') + rX k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + fmap (\x -> Helmert cX' cY' cZ' helmertScale' x rY' rZ') (k rX') + rY k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + fmap (\x -> Helmert cX' cY' cZ' helmertScale' rX' x rZ') (k rY') + rZ k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + fmap (\x -> Helmert cX' cY' cZ' helmertScale' rX' rY' x) (k rZ') + +class ManyHelmert a => AsHelmert a where + _Helmert :: + Prism' a Helmert + + _HelmertFields :: + Prism' a (Length Double, Length Double, Length Double, Dimensionless Double, Dimensionless Double, Dimensionless Double, Dimensionless Double) + _HelmertFields = + _Helmert . _HelmertFields + +instance AsHelmert Helmert where + _Helmert = + id + + _HelmertFields = + prism + (\(cX', cY', cZ', helmertScale', rX', rY', rZ') -> Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') + (\(Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') -> Right (cX', cY', cZ', helmertScale', rX', rY', rZ')) + +class (FoldHelmert a, SetHelmert a) => ManyHelmert a where + _ManyHelmert :: + Traversal' a Helmert + +instance ManyHelmert Helmert where + _ManyHelmert = + id + +class FoldHelmert a => GetHelmert a where + _GetHelmert :: + Getter a Helmert + +instance GetHelmert Helmert where + _GetHelmert = + id + +class SetHelmert a where + _SetHelmert :: + Setter' a Helmert + +instance SetHelmert Helmert where + _SetHelmert = + id + +class FoldHelmert a where + _FoldHelmert :: + Fold a Helmert + +instance FoldHelmert Helmert where + _FoldHelmert = + id + +class (HasHelmert a, AsHelmert a) => IsHelmert a where + _IsHelmert :: + Iso' a Helmert + +instance IsHelmert Helmert where + _IsHelmert = + id + +instance Semigroup Helmert where + h1 <> h2 = + let p x = + h1 ^. x + h2 ^. x + in Helmert + (p cX) + (p cY) + (p cZ) + (p helmertScale) + (p rX) + (p rY) + (p rZ) + +instance Monoid Helmert where + mempty = + Helmert + (0 *~ meter) + (0 *~ meter) + (0 *~ meter) + _0 + _0 + _0 + _0 + mappend = + (<>) + +translations :: + Traversal' + Helmert + (Length Double) +translations k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + (\cX'' cY'' cZ'' -> Helmert cX'' cY'' cZ'' helmertScale' rX' rY' rZ') <$> + k cX' <*> + k cY' <*> + k cZ' + +rotations :: + Traversal' + Helmert + (Dimensionless Double) +rotations k (Helmert cX' cY' cZ' helmertScale' rX' rY' rZ') = + Helmert cX' cY' cZ' helmertScale' <$> + k rX' <*> + k rY' <*> + k rZ' diff --git a/src/Geodetics/Types/Latitude.hs b/src/Geodetics/Types/Latitude.hs new file mode 100644 --- /dev/null +++ b/src/Geodetics/Types/Latitude.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +module Geodetics.Types.Latitude( + Latitude(..) +, HasLatitude(..) +, AsLatitude(..) +, ManyLatitude(..) +, GetLatitude(..) +, SetLatitude(..) +, FoldLatitude(..) +, IsLatitude(..) +) where + +import Control.Category((.), id) +import Control.Lens(Lens', Prism', Traversal', Getter, Setter', Fold, Iso', Wrapped(_Wrapped'), Unwrapped, iso, prism) +import Data.Either(Either(Right)) +import Data.Eq(Eq) +import Data.Functor(fmap) +import Data.Ord(Ord) +import Numeric.Units.Dimensional.Prelude(Angle) +import Prelude(Double, Show) + +newtype Latitude = + Latitude + (Angle Double) + deriving (Eq, Ord, Show) + +instance Wrapped Latitude where + type Unwrapped Latitude = + Angle Double + _Wrapped' = + iso + (\(Latitude x) -> x) + Latitude + +class HasLatitude a where + latitude :: + Lens' a Latitude + latitudeAngle :: + Lens' a (Angle Double) + {-# INLINE latitudeAngle #-} + latitudeAngle = + latitude . latitudeAngle + +instance HasLatitude Latitude where + latitude = + id + latitudeAngle k (Latitude x) = + fmap Latitude (k x) + +class ManyLatitude a => AsLatitude a where + _Latitude :: + Prism' a Latitude + _LatitudeFields :: + Prism' a (Angle Double) + _LatitudeFields = + _Latitude . _LatitudeFields + +instance AsLatitude Latitude where + _Latitude = + id + _LatitudeFields = + prism + Latitude + (\(Latitude x) -> Right x) + +class (FoldLatitude a, SetLatitude a) => ManyLatitude a where + _ManyLatitude :: + Traversal' a Latitude + +instance ManyLatitude Latitude where + _ManyLatitude = + id + +class FoldLatitude a => GetLatitude a where + _GetLatitude :: + Getter a Latitude + +instance GetLatitude Latitude where + _GetLatitude = + id + +class SetLatitude a where + _SetLatitude :: + Setter' a Latitude + +instance SetLatitude Latitude where + _SetLatitude = + id + +class FoldLatitude a where + _FoldLatitude :: + Fold a Latitude + +instance FoldLatitude Latitude where + _FoldLatitude = + id + +class (HasLatitude a, AsLatitude a) => IsLatitude a where + _IsLatitude :: + Iso' a Latitude + +instance IsLatitude Latitude where + _IsLatitude = + id diff --git a/src/Geodetics/Types/Longitude.hs b/src/Geodetics/Types/Longitude.hs new file mode 100644 --- /dev/null +++ b/src/Geodetics/Types/Longitude.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +module Geodetics.Types.Longitude( + Longitude(..) +, HasLongitude(..) +, AsLongitude(..) +, ManyLongitude(..) +, GetLongitude(..) +, SetLongitude(..) +, FoldLongitude(..) +, IsLongitude(..) +) where + +import Control.Category((.), id) +import Control.Lens(Lens', Prism', Traversal', Getter, Setter', Fold, Iso', Wrapped(_Wrapped'), Unwrapped, iso, prism) +import Data.Either(Either(Right)) +import Data.Eq(Eq) +import Data.Functor(fmap) +import Data.Ord(Ord) +import Numeric.Units.Dimensional.Prelude(Angle) +import Prelude(Double, Show) + +newtype Longitude = + Longitude + (Angle Double) + deriving (Eq, Ord, Show) + +instance Wrapped Longitude where + type Unwrapped Longitude = + Angle Double + _Wrapped' = + iso + (\(Longitude x) -> x) + Longitude + +class HasLongitude a where + longitude :: + Lens' a Longitude + longitudeAngle :: + Lens' a (Angle Double) + {-# INLINE longitudeAngle #-} + longitudeAngle = + longitude . longitudeAngle + +instance HasLongitude Longitude where + longitude = + id + longitudeAngle k (Longitude x) = + fmap Longitude (k x) + +class ManyLongitude a => AsLongitude a where + _Longitude :: + Prism' a Longitude + _LongitudeFields :: + Prism' a (Angle Double) + _LongitudeFields = + _Longitude . _LongitudeFields + +instance AsLongitude Longitude where + _Longitude = + id + _LongitudeFields = + prism + Longitude + (\(Longitude x) -> Right x) + +class (FoldLongitude a, SetLongitude a) => ManyLongitude a where + _ManyLongitude :: + Traversal' a Longitude + +instance ManyLongitude Longitude where + _ManyLongitude = + id + +class FoldLongitude a => GetLongitude a where + _GetLongitude :: + Getter a Longitude + +instance GetLongitude Longitude where + _GetLongitude = + id + +class SetLongitude a where + _SetLongitude :: + Setter' a Longitude + +instance SetLongitude Longitude where + _SetLongitude = + id + +class FoldLongitude a where + _FoldLongitude :: + Fold a Longitude + +instance FoldLongitude Longitude where + _FoldLongitude = + id + +class (HasLongitude a, AsLongitude a) => IsLongitude a where + _IsLongitude :: + Iso' a Longitude + +instance IsLongitude Longitude where + _IsLongitude = + id diff --git a/src/Geodetics/Types/TRF.hs b/src/Geodetics/Types/TRF.hs new file mode 100644 --- /dev/null +++ b/src/Geodetics/Types/TRF.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Geodetics.Types.TRF( + TRF(..) +, HasTRF(..) +, AsTRF(..) +, ManyTRF(..) +, GetTRF(..) +, SetTRF(..) +, FoldTRF(..) +, IsTRF(..) +, _WGS84 +, _OSGB36 +, _Clarke1866 +, _Bessel1841 +) where + +import Control.Category((.), id) +import Control.Lens(Lens', Prism', Traversal', Getter, Setter', Fold, Iso', prism) +import Data.Either(Either(Right)) +import Data.Eq(Eq) +import Data.Monoid(mempty) +import Data.Ord(Ord) +import Data.Functor(fmap) +import Data.Tuple(uncurry) +import Geodetics.Types.Ellipsoid(Ellipsoid(Ellipsoid), HasEllipsoid(ellipsoid), GetEllipsoid(_GetEllipsoid), ManyEllipsoid(_ManyEllipsoid), FoldEllipsoid(_FoldEllipsoid), SetEllipsoid(_SetEllipsoid)) +import Geodetics.Types.Helmert(Helmert(Helmert), HasHelmert(helmert), GetHelmert(_GetHelmert), ManyHelmert(_ManyHelmert), FoldHelmert(_FoldHelmert), SetHelmert(_SetHelmert)) +import Numeric.Units.Dimensional.Prelude((*~), meter, one, arcsecond) +import Prelude(Show) + +data TRF = + TRF + Ellipsoid + Helmert + deriving (Eq, Ord, Show) + +instance HasEllipsoid TRF where + ellipsoid k (TRF e h) = + fmap (\e' -> TRF e' h) (k e) + +instance GetEllipsoid TRF where + _GetEllipsoid = + ellipsoid + +instance ManyEllipsoid TRF where + _ManyEllipsoid = + ellipsoid + +instance FoldEllipsoid TRF where + _FoldEllipsoid = + ellipsoid + +instance SetEllipsoid TRF where + _SetEllipsoid = + ellipsoid + +instance HasHelmert TRF where + helmert k (TRF e h) = + fmap (\h' -> TRF e h') (k h) + +instance GetHelmert TRF where + _GetHelmert = + helmert + +instance ManyHelmert TRF where + _ManyHelmert = + helmert + +instance FoldHelmert TRF where + _FoldHelmert = + helmert + +instance SetHelmert TRF where + _SetHelmert = + helmert + +class (GetTRF a, ManyTRF a, HasEllipsoid a) => HasTRF a where + trf :: + Lens' a TRF + +instance HasTRF TRF where + trf = + id + +class ManyTRF a => AsTRF a where + _TRF :: + Prism' a TRF + _TRFFields :: + Prism' a (Ellipsoid, Helmert) + _TRFFields = + _TRF . _TRFFields + +instance AsTRF TRF where + _TRF = + id + _TRFFields = + prism + (uncurry TRF) + (\(TRF e h) -> Right (e, h)) + +class (FoldTRF a, SetTRF a) => ManyTRF a where + _ManyTRF :: + Traversal' a TRF + +instance ManyTRF TRF where + _ManyTRF = + id + +class FoldTRF a => GetTRF a where + _GetTRF :: + Getter a TRF + +instance GetTRF TRF where + _GetTRF = + id + +class SetTRF a where + _SetTRF :: + Setter' a TRF + +instance SetTRF TRF where + _SetTRF = + id + +class FoldTRF a where + _FoldTRF :: + Fold a TRF + +instance FoldTRF TRF where + _FoldTRF = + id + +class (HasTRF a, AsTRF a) => IsTRF a where + _IsTRF :: + Iso' a TRF + +instance IsTRF TRF where + _IsTRF = + id + +_WGS84 :: + TRF +_WGS84 = + TRF + ( + Ellipsoid + (6378137.0 *~ meter) + (298.257223563 *~ one) + ) + mempty + +_OSGB36 :: + TRF +_OSGB36 = + TRF + ( + Ellipsoid + (6377563.396 *~ meter) + (299.3249646 *~ one) + ) + ( + Helmert + (446.448 *~ meter) + ((-125.157) *~ meter) + (542.06 *~ meter) + ((-20.4894) *~ one) + (0.1502 *~ arcsecond) + (0.247 *~ arcsecond) + (0.8421 *~ arcsecond) + ) + +_Clarke1866 :: + TRF +_Clarke1866 = + TRF + ( + Ellipsoid + (6378206.4 *~ meter) + (294.978698214 *~ one) + ) + ( + Helmert + ((-8) *~ meter) + (160 *~ meter) + (176 *~ meter) + (0 *~ one) + (0 *~ arcsecond) + (0 *~ arcsecond) + (0 *~ arcsecond) + ) + +_Bessel1841 :: + TRF +_Bessel1841 = + TRF + ( + Ellipsoid + (6377397.155 *~ meter) + (299.1528153513233 *~ one) + ) + ( + Helmert + (582 *~ meter) + (105 *~ meter) + (414 *~ meter) + (8.3 *~ one) + (1.04 *~ arcsecond) + (0.35 *~ arcsecond) + (3.08 *~ arcsecond) + )