{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}

module Geodetics.PolarStereographic (
  Pole (..),
  PolarStereographic (trueOrigin, falseOrigin, polarEllipsoid, gridScale),
  mkGridPolarStereographic,
  UpsGrid,
  upsNorth,
  upsSouth,
  fromUpsGridReference,
  parseUpsGridReference,
  toUpsGridReference
) where

import Control.Monad
import Data.Char
import Geodetics.Ellipsoids
import Geodetics.Geodetic
import Geodetics.Grid
import Text.Parsec
import Text.Parsec.Error
import Text.Read (readMaybe)
import Text.Printf

-- | Polar stereographic grids are defined for true origins at the north and south poles.
data Pole = NorthPole | SouthPole deriving (Int -> Pole -> ShowS
[Pole] -> ShowS
Pole -> String
(Int -> Pole -> ShowS)
-> (Pole -> String) -> ([Pole] -> ShowS) -> Show Pole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pole -> ShowS
showsPrec :: Int -> Pole -> ShowS
$cshow :: Pole -> String
show :: Pole -> String
$cshowList :: [Pole] -> ShowS
showList :: [Pole] -> ShowS
Show, Eq Pole
Eq Pole =>
(Pole -> Pole -> Ordering)
-> (Pole -> Pole -> Bool)
-> (Pole -> Pole -> Bool)
-> (Pole -> Pole -> Bool)
-> (Pole -> Pole -> Bool)
-> (Pole -> Pole -> Pole)
-> (Pole -> Pole -> Pole)
-> Ord Pole
Pole -> Pole -> Bool
Pole -> Pole -> Ordering
Pole -> Pole -> Pole
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pole -> Pole -> Ordering
compare :: Pole -> Pole -> Ordering
$c< :: Pole -> Pole -> Bool
< :: Pole -> Pole -> Bool
$c<= :: Pole -> Pole -> Bool
<= :: Pole -> Pole -> Bool
$c> :: Pole -> Pole -> Bool
> :: Pole -> Pole -> Bool
$c>= :: Pole -> Pole -> Bool
>= :: Pole -> Pole -> Bool
$cmax :: Pole -> Pole -> Pole
max :: Pole -> Pole -> Pole
$cmin :: Pole -> Pole -> Pole
min :: Pole -> Pole -> Pole
Ord, Pole -> Pole -> Bool
(Pole -> Pole -> Bool) -> (Pole -> Pole -> Bool) -> Eq Pole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pole -> Pole -> Bool
== :: Pole -> Pole -> Bool
$c/= :: Pole -> Pole -> Bool
/= :: Pole -> Pole -> Bool
Eq, Int -> Pole
Pole -> Int
Pole -> [Pole]
Pole -> Pole
Pole -> Pole -> [Pole]
Pole -> Pole -> Pole -> [Pole]
(Pole -> Pole)
-> (Pole -> Pole)
-> (Int -> Pole)
-> (Pole -> Int)
-> (Pole -> [Pole])
-> (Pole -> Pole -> [Pole])
-> (Pole -> Pole -> [Pole])
-> (Pole -> Pole -> Pole -> [Pole])
-> Enum Pole
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Pole -> Pole
succ :: Pole -> Pole
$cpred :: Pole -> Pole
pred :: Pole -> Pole
$ctoEnum :: Int -> Pole
toEnum :: Int -> Pole
$cfromEnum :: Pole -> Int
fromEnum :: Pole -> Int
$cenumFrom :: Pole -> [Pole]
enumFrom :: Pole -> [Pole]
$cenumFromThen :: Pole -> Pole -> [Pole]
enumFromThen :: Pole -> Pole -> [Pole]
$cenumFromTo :: Pole -> Pole -> [Pole]
enumFromTo :: Pole -> Pole -> [Pole]
$cenumFromThenTo :: Pole -> Pole -> Pole -> [Pole]
enumFromThenTo :: Pole -> Pole -> Pole -> [Pole]
Enum, Pole
Pole -> Pole -> Bounded Pole
forall a. a -> a -> Bounded a
$cminBound :: Pole
minBound :: Pole
$cmaxBound :: Pole
maxBound :: Pole
Bounded)


{- | Polar Stereographic Grids

Formulae are taken from
/The Universal Grids: Univerersal Transverse Mercator (UTM) and Universal Polar Stereographic (UPS)/
DMA Technical Manual 8358.2, Defense Mapping Agency, Fairfax, VA. https://apps.dtic.mil/sti/tr/pdf/ADA266497.pdf

When working with polar grids all directions are relative to the grid rather than the actual pole.
So in the Arctic \"North\" on the Universal Polar Stereographic grid means towards the Bering Sea
rather than towards the North Pole.
-}
data PolarStereographic e = PolarStereographic {
  forall e. PolarStereographic e -> Pole
trueOrigin :: Pole,
  forall e. PolarStereographic e -> GridOffset
falseOrigin :: GridOffset,
    -- ^ The negation of the grid position of the true origin. Used to avoid negative coordinates over the area
    -- of interest. The altitude gives a vertical offset from the ellipsoid.
  forall e. PolarStereographic e -> e
polarEllipsoid :: e,
    -- ^ The ellipsoid for the projection. Arguments passed to `toGrid` *must* use this ellipsoid.
    -- The type system cannot verify this for `LocalEllipsoid`.
  forall e. PolarStereographic e -> Double
gridScale :: Double,
    -- ^ The scaling factor applied at the pole. This balances the distortion between the center
    -- and edges of the projection.

  -- Remaining elements are memoised parameters computed from the ellipsoid.
  forall e. PolarStereographic e -> Double
gridA, forall e. PolarStereographic e -> Double
gridB, forall e. PolarStereographic e -> Double
gridC, forall e. PolarStereographic e -> Double
gridD, forall e. PolarStereographic e -> Double
gridC0 :: !Double
} deriving (Int -> PolarStereographic e -> ShowS
[PolarStereographic e] -> ShowS
PolarStereographic e -> String
(Int -> PolarStereographic e -> ShowS)
-> (PolarStereographic e -> String)
-> ([PolarStereographic e] -> ShowS)
-> Show (PolarStereographic e)
forall e. Show e => Int -> PolarStereographic e -> ShowS
forall e. Show e => [PolarStereographic e] -> ShowS
forall e. Show e => PolarStereographic e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> PolarStereographic e -> ShowS
showsPrec :: Int -> PolarStereographic e -> ShowS
$cshow :: forall e. Show e => PolarStereographic e -> String
show :: PolarStereographic e -> String
$cshowList :: forall e. Show e => [PolarStereographic e] -> ShowS
showList :: [PolarStereographic e] -> ShowS
Show)

instance (Eq e) => Eq (PolarStereographic e) where
  PolarStereographic e
g1 == :: PolarStereographic e -> PolarStereographic e -> Bool
== PolarStereographic e
g2 =
    PolarStereographic e -> Pole
forall e. PolarStereographic e -> Pole
trueOrigin PolarStereographic e
g1 Pole -> Pole -> Bool
forall a. Eq a => a -> a -> Bool
== PolarStereographic e -> Pole
forall e. PolarStereographic e -> Pole
trueOrigin PolarStereographic e
g2 Bool -> Bool -> Bool
&&
    PolarStereographic e -> GridOffset
forall e. PolarStereographic e -> GridOffset
falseOrigin PolarStereographic e
g1 GridOffset -> GridOffset -> Bool
forall a. Eq a => a -> a -> Bool
== PolarStereographic e -> GridOffset
forall e. PolarStereographic e -> GridOffset
falseOrigin PolarStereographic e
g2 Bool -> Bool -> Bool
&&
    PolarStereographic e -> e
forall e. PolarStereographic e -> e
polarEllipsoid PolarStereographic e
g1 e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== PolarStereographic e -> e
forall e. PolarStereographic e -> e
polarEllipsoid PolarStereographic e
g2 Bool -> Bool -> Bool
&&
    PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridScale PolarStereographic e
g1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridScale PolarStereographic e
g2

instance (Ellipsoid e) => GridClass (PolarStereographic e) e where
  fromGrid :: GridPoint (PolarStereographic e) -> Geodetic e
fromGrid GridPoint (PolarStereographic e)
p = Double -> Double -> Double -> e -> Geodetic e
forall e. Double -> Double -> Double -> e -> Geodetic e
Geodetic Double
lat Double
long (GridPoint (PolarStereographic e) -> Double
forall r. GridPoint r -> Double
altGP GridPoint (PolarStereographic e)
p) (PolarStereographic e -> e
forall e. PolarStereographic e -> e
polarEllipsoid PolarStereographic e
gb)
    where
      gridZero :: GridPoint (PolarStereographic e)
gridZero = Double
-> Double
-> Double
-> PolarStereographic e
-> GridPoint (PolarStereographic e)
forall r. Double -> Double -> Double -> r -> GridPoint r
GridPoint Double
0 Double
0 Double
0 PolarStereographic e
gb
      gb :: PolarStereographic e
gb = GridPoint (PolarStereographic e) -> PolarStereographic e
forall r. GridPoint r -> r
gridBasis GridPoint (PolarStereographic e)
p
      p' :: GridOffset
p' = GridPoint (PolarStereographic e)
gridZero GridPoint (PolarStereographic e)
-> GridPoint (PolarStereographic e) -> GridOffset
forall g. GridPoint g -> GridPoint g -> GridOffset
`gridOffset` (PolarStereographic e -> GridOffset
forall e. PolarStereographic e -> GridOffset
falseOrigin PolarStereographic e
gb GridOffset
-> GridPoint (PolarStereographic e)
-> GridPoint (PolarStereographic e)
forall g. GridOffset -> GridPoint g -> GridPoint g
`applyOffset` GridPoint (PolarStereographic e)
p)
      radius :: Double
radius = GridOffset -> Double
offsetDistance GridOffset
p'
      isoColat :: Double
isoColat = Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
atan (Double
radius Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridScale PolarStereographic e
gb Double -> Double -> Double
forall a. Num a => a -> a -> a
* PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridC0 PolarStereographic e
gb))
      isoLat :: Double
isoLat = Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
isoColat
      lat1 :: Double
lat1 = Double
isoLat Double -> Double -> Double
forall a. Num a => a -> a -> a
+
        PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridA PolarStereographic e
gb Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
isoLat) Double -> Double -> Double
forall a. Num a => a -> a -> a
+
        PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridB PolarStereographic e
gb Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin (Double
4Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
isoLat) Double -> Double -> Double
forall a. Num a => a -> a -> a
+
        PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridC PolarStereographic e
gb Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin (Double
6Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
isoLat) Double -> Double -> Double
forall a. Num a => a -> a -> a
+
        PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridD PolarStereographic e
gb Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin (Double
8Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
isoLat)
      lat :: Double
lat = case PolarStereographic e -> Pole
forall e. PolarStereographic e -> Pole
trueOrigin PolarStereographic e
gb of
        Pole
NorthPole -> Double
lat1
        Pole
SouthPole -> Double -> Double
forall a. Num a => a -> a
negate Double
lat1
      long :: Double
long = case PolarStereographic e -> Pole
forall e. PolarStereographic e -> Pole
trueOrigin PolarStereographic e
gb of
        Pole
NorthPole -> GridOffset -> Double
offsetBearing GridOffset
p' { deltaNorth = negate $ deltaNorth p'}
        Pole
SouthPole -> GridOffset -> Double
offsetBearing GridOffset
p'

  toGrid :: PolarStereographic e
-> Geodetic e -> GridPoint (PolarStereographic e)
toGrid PolarStereographic e
r Geodetic e
geo = GridOffset -> GridOffset
offsetNegate (PolarStereographic e -> GridOffset
forall e. PolarStereographic e -> GridOffset
falseOrigin PolarStereographic e
r) GridOffset
-> GridPoint (PolarStereographic e)
-> GridPoint (PolarStereographic e)
forall g. GridOffset -> GridPoint g -> GridPoint g
`applyOffset` Double
-> Double
-> Double
-> PolarStereographic e
-> GridPoint (PolarStereographic e)
forall r. Double -> Double -> Double -> r -> GridPoint r
GridPoint Double
east Double
north Double
0 PolarStereographic e
r
    where
      absLat :: Double
absLat = Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Geodetic e -> Double
forall e. Geodetic e -> Double
latitude Geodetic e
geo
      e :: Double
e = Double -> Double
forall a. Floating a => a -> a
sqrt (e -> Double
forall e. Ellipsoid e => e -> Double
eccentricity2 (e -> Double) -> e -> Double
forall a b. (a -> b) -> a -> b
$ PolarStereographic e -> e
forall e. PolarStereographic e -> e
polarEllipsoid PolarStereographic e
r)
      eSinLat :: Double
eSinLat = Double
e Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
absLat
      tz2 :: Double
tz2 = ((Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
eSinLat)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/(Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
eSinLat))Double -> Double -> Double
forall a. Floating a => a -> a -> a
**(Double
eDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
tan (Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
absLat Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
      radius :: Double
radius = PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridScale PolarStereographic e
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* PolarStereographic e -> Double
forall e. PolarStereographic e -> Double
gridC0 PolarStereographic e
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
tz2
      north :: Double
north = case PolarStereographic e -> Pole
forall e. PolarStereographic e -> Pole
trueOrigin PolarStereographic e
r of
        Pole
NorthPole -> Double -> Double
forall a. Num a => a -> a
negate (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
radius Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos (Geodetic e -> Double
forall e. Geodetic e -> Double
longitude Geodetic e
geo)
        Pole
SouthPole -> Double
radius Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos (Geodetic e -> Double
forall e. Geodetic e -> Double
longitude Geodetic e
geo)
      east :: Double
east = Double
radius Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin (Geodetic e -> Double
forall e. Geodetic e -> Double
longitude Geodetic e
geo)
  gridEllipsoid :: PolarStereographic e -> e
gridEllipsoid = PolarStereographic e -> e
forall e. PolarStereographic e -> e
polarEllipsoid


mkGridPolarStereographic :: (Ellipsoid e) =>
  Pole          -- ^ True origin at north or south pole.
  -> e          -- ^ The ellipsoid used for the projection.
  -> GridOffset -- ^ Vector from true origin to the false origin.
  -> Double     -- ^ Scale factor.
  -> PolarStereographic e
mkGridPolarStereographic :: forall e.
Ellipsoid e =>
Pole -> e -> GridOffset -> Double -> PolarStereographic e
mkGridPolarStereographic Pole
pole e
ellip GridOffset
offset Double
scale =
  PolarStereographic {
    trueOrigin :: Pole
trueOrigin = Pole
pole,
    falseOrigin :: GridOffset
falseOrigin = GridOffset
offset,
    polarEllipsoid :: e
polarEllipsoid = e
ellip,
    gridScale :: Double
gridScale = Double
scale,
    gridA :: Double
gridA = Double
e2Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
5Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
24)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e4 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
e6Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
12 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
13Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
360)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e8,
    gridB :: Double
gridB = (Double
7Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
48)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e4 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
29Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
240)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e6 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
811Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
11520)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e8,
    gridC :: Double
gridC = (Double
7Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
120)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e6 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
81Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1120)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e8,
    gridD :: Double
gridD = (Double
4279Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
161280)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e8,
    gridC0 :: Double
gridC0 = (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* e -> Double
forall e. Ellipsoid e => e -> Double
majorRadius e
ellip Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
sqrt (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
e2)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* ((Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
e1)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/(Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
e1))Double -> Double -> Double
forall a. Floating a => a -> a -> a
**(Double
e1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
  }
  where
    e1 :: Double
e1 = Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ e -> Double
forall e. Ellipsoid e => e -> Double
eccentricity2 e
ellip
    e2 :: Double
e2 = e -> Double
forall e. Ellipsoid e => e -> Double
eccentricity2 e
ellip
    e4 :: Double
e4 = Double
e2Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Int
_2
    e6 :: Double
e6 = Double
e2Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Int
_3
    e8 :: Double
e8 = Double
e2Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Int
_4


-- | The Universal Polar Stereographic (UPS) grids for north and south poles.
type UpsGrid = PolarStereographic WGS84


-- | UPS grid for the North Pole.
upsNorth :: UpsGrid
upsNorth :: UpsGrid
upsNorth = Pole -> WGS84 -> GridOffset -> Double -> UpsGrid
forall e.
Ellipsoid e =>
Pole -> e -> GridOffset -> Double -> PolarStereographic e
mkGridPolarStereographic
  Pole
NorthPole
  WGS84
WGS84
  (GridOffset { deltaEast :: Double
deltaEast = -(Double
2000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer), deltaNorth :: Double
deltaNorth = -(Double
2000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer), deltaAltitude :: Double
deltaAltitude = Double
0 })
  Double
0.994  -- Scale factor


-- | UPS grid for the South Pole.
upsSouth :: UpsGrid
upsSouth :: UpsGrid
upsSouth = Pole -> WGS84 -> GridOffset -> Double -> UpsGrid
forall e.
Ellipsoid e =>
Pole -> e -> GridOffset -> Double -> PolarStereographic e
mkGridPolarStereographic
  Pole
SouthPole
  WGS84
WGS84
  (GridOffset { deltaEast :: Double
deltaEast = -(Double
2000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer), deltaNorth :: Double
deltaNorth = -(Double
2000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer), deltaAltitude :: Double
deltaAltitude = Double
0 })
  Double
0.994   -- Scale factor


-- | Convert a grid reference into a UPS grid location.
--
-- There doesn't appear to be any conventional representation for polar grid references,
-- so this is an attempt to cover as many bases as possible. It takes an Easting followed
-- by a Northing with spaces in between. Both can have optional units of m or km,
-- and be optionally followed by an \"N\" or \"E\" as appropriate.
--
-- The choice of pole is provided in an extra argument rather than within the string because humans
-- will normally assume this from the context and so not provide it.
--
-- If the string cannot be parsed then one or more error messages are returned.
fromUpsGridReference :: Pole -> String -> Either [String] (GridPoint UpsGrid)
fromUpsGridReference :: Pole -> String -> Either [String] (GridPoint UpsGrid)
fromUpsGridReference Pole
pole String
str = case Parsec String () (GridPoint UpsGrid)
-> String -> String -> Either ParseError (GridPoint UpsGrid)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Pole -> Parsec String () (GridPoint UpsGrid)
forall s (m :: * -> *) u.
Stream s m Char =>
Pole -> ParsecT s u m (GridPoint UpsGrid)
parseUpsGridReference Pole
pole) String
"" String
str of
    Left ParseError
err -> [String] -> Either [String] (GridPoint UpsGrid)
forall a b. a -> Either a b
Left ([String] -> Either [String] (GridPoint UpsGrid))
-> [String] -> Either [String] (GridPoint UpsGrid)
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
-> String -> String -> String -> String -> [Message] -> String
showErrorMessages
      String
"or" String
"unknown parse error" String
"expecting" String
"unexpected" String
"end of input"
      (ParseError -> [Message]
errorMessages ParseError
err)
    Right GridPoint UpsGrid
r -> GridPoint UpsGrid -> Either [String] (GridPoint UpsGrid)
forall a b. b -> Either a b
Right GridPoint UpsGrid
r


parseUpsGridReference :: Stream s m Char => Pole -> ParsecT s u m (GridPoint UpsGrid)
parseUpsGridReference :: forall s (m :: * -> *) u.
Stream s m Char =>
Pole -> ParsecT s u m (GridPoint UpsGrid)
parseUpsGridReference Pole
pole = do
      ParsecT s u m ()
forall {u}. ParsecT s u m ()
spaces1
      (Double
eastings1, Maybe GridUnit
eastUnit) <- ParsecT s u m (Double, Maybe GridUnit)
forall {u}. ParsecT s u m (Double, Maybe GridUnit)
readDistance
      ParsecT s u m ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
      ParsecT s u m Char -> ParsecT s u m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (String -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"Ee" ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"E")
      ParsecT s u m ()
forall {u}. ParsecT s u m ()
spaces1
      (Double
northings1, Maybe GridUnit
northUnit) <- ParsecT s u m (Double, Maybe GridUnit)
forall {u}. ParsecT s u m (Double, Maybe GridUnit)
readDistance
      Bool -> ParsecT s u m () -> ParsecT s u m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe GridUnit
eastUnit Maybe GridUnit -> Maybe GridUnit -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe GridUnit
northUnit) (ParsecT s u m () -> ParsecT s u m ())
-> ParsecT s u m () -> ParsecT s u m ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT s u m ()
forall a. String -> ParsecT s u m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Northings and Eastings units don't match."
      ParsecT s u m ()
forall {u}. ParsecT s u m ()
spaces1
      ParsecT s u m Char -> ParsecT s u m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (String -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"Nn" ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"N")
      ParsecT s u m ()
forall {u}. ParsecT s u m ()
spaces1
      ParsecT s u m ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
      GridPoint UpsGrid -> ParsecT s u m (GridPoint UpsGrid)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GridPoint UpsGrid -> ParsecT s u m (GridPoint UpsGrid))
-> GridPoint UpsGrid -> ParsecT s u m (GridPoint UpsGrid)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> UpsGrid -> GridPoint UpsGrid
forall r. Double -> Double -> Double -> r -> GridPoint r
GridPoint Double
eastings1 Double
northings1 Double
0 (UpsGrid -> GridPoint UpsGrid) -> UpsGrid -> GridPoint UpsGrid
forall a b. (a -> b) -> a -> b
$
        case Pole
pole of
          Pole
NorthPole -> UpsGrid
upsNorth
          Pole
SouthPole -> UpsGrid
upsSouth
  where
    readDistance :: ParsecT s u m (Double, Maybe GridUnit)
readDistance = do  -- Returns (distance in meters, unit from input)
      String
digits <- ParsecT s u m Char -> ParsecT s u m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT s u m Char -> ParsecT s u m Char -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"number")
      ParsecT s u m ()
forall {u}. ParsecT s u m ()
spaces1
      Bool -> ParsecT s u m () -> ParsecT s u m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
digits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20) (ParsecT s u m () -> ParsecT s u m ())
-> ParsecT s u m () -> ParsecT s u m ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT s u m ()
forall a. String -> ParsecT s u m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Too many digits."
      (Double
multiplier, Maybe GridUnit
unit) <- do
        Maybe String
unit <- ParsecT s u m String -> ParsecT s u m (Maybe String)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (String -> ParsecT s u m String
forall {s} {m :: * -> *} {u}.
Stream s m Char =>
String -> ParsecT s u m String
string1' String
"m" ParsecT s u m String
-> ParsecT s u m String -> ParsecT s u m String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT s u m String
forall {s} {m :: * -> *} {u}.
Stream s m Char =>
String -> ParsecT s u m String
string1' String
"km" ParsecT s u m String -> String -> ParsecT s u m String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"units (m or km)")
        case Maybe String
unit of
          Just String
"km" -> (Double, Maybe GridUnit) -> ParsecT s u m (Double, Maybe GridUnit)
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
1000, GridUnit -> Maybe GridUnit
forall a. a -> Maybe a
Just GridUnit
GridKilometers)
          Just String
_    -> (Double, Maybe GridUnit) -> ParsecT s u m (Double, Maybe GridUnit)
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
1, GridUnit -> Maybe GridUnit
forall a. a -> Maybe a
Just GridUnit
GridMeters)
          Maybe String
Nothing   -> (Double, Maybe GridUnit) -> ParsecT s u m (Double, Maybe GridUnit)
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
1, Maybe GridUnit
forall a. Maybe a
Nothing)
      case String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe String
digits of
        Just Double
d -> (Double, Maybe GridUnit) -> ParsecT s u m (Double, Maybe GridUnit)
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
multiplier, Maybe GridUnit
unit)
        Maybe Double
Nothing -> String -> ParsecT s u m (Double, Maybe GridUnit)
forall a. String -> ParsecT s u m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT s u m (Double, Maybe GridUnit))
-> String -> ParsecT s u m (Double, Maybe GridUnit)
forall a b. (a -> b) -> a -> b
$ String
"Cannot read number: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
digits
    string1' :: String -> ParsecT s u m String
string1' String
target = ParsecT s u m String -> ParsecT s u m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s u m String -> ParsecT s u m String)
-> ParsecT s u m String -> ParsecT s u m String
forall a b. (a -> b) -> a -> b
$ do  -- Case-insensitive version of string'
      String
cs <- Int -> ParsecT s u m Char -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
target) ParsecT s u m Char
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken
      if (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
target String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cs then String -> ParsecT s u m String
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
cs else String -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
String -> ParsecT s u m a
unexpected String
cs
    spaces1 :: ParsecT s u m ()
spaces1 = ParsecT s u m String -> ParsecT s u m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT s u m String -> ParsecT s u m ())
-> ParsecT s u m String -> ParsecT s u m ()
forall a b. (a -> b) -> a -> b
$ ParsecT s u m Char -> ParsecT s u m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ' ParsecT s u m Char -> String -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"space")  -- Other white space not permitted.


toUpsGridReference :: 
  Maybe GridUnit  -- ^ Include explicit units in the output. @Nothing@ means meters without units.
  -> Bool  -- ^ Include \"E\" and \"N\" in the output.
  -> Int  -- ^ Digits of resolution. 0 = 1m resolution, 1 = 10m, 2 = 100m etc. (-2) = 1cm.
  -> GridPoint UpsGrid
  -> String
toUpsGridReference :: Maybe GridUnit -> Bool -> Int -> GridPoint UpsGrid -> String
toUpsGridReference Maybe GridUnit
unit Bool
letters Int
res GridPoint UpsGrid
gp =
  Double -> String
forall {b}. PrintfType b => Double -> b
dist (GridPoint UpsGrid -> Double
forall r. GridPoint r -> Double
eastings GridPoint UpsGrid
gp)  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if Bool
letters then String
"E " else String
" ") String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    Double -> String
forall {b}. PrintfType b => Double -> b
dist (GridPoint UpsGrid -> Double
forall r. GridPoint r -> Double
northings GridPoint UpsGrid
gp) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (if Bool
letters then String
"N" else String
"")
  where
    res1 :: Double
    res1 :: Double
res1 = Double
10 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
res   -- Resolution in meters.
    floorRes :: Double -> Double
    floorRes :: Double -> Double
floorRes Double
d = Double
res1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
dDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
res1) :: Integer)
    dist :: Double -> b
dist Double
d = case Maybe GridUnit
unit of
      Maybe GridUnit
Nothing            -> String -> Int -> Double -> b
forall r. PrintfType r => String -> r
printf String
"%.*f" (-Int
res) (Double -> b) -> Double -> b
forall a b. (a -> b) -> a -> b
$ Double -> Double
floorRes Double
d
      Just GridUnit
GridMeters     -> String -> Int -> Double -> b
forall r. PrintfType r => String -> r
printf String
"%.*fm" (-Int
res) (Double -> b) -> Double -> b
forall a b. (a -> b) -> a -> b
$ Double -> Double
floorRes Double
d
      Just GridUnit
GridKilometers -> String -> Int -> Double -> b
forall r. PrintfType r => String -> r
printf String
"%.*fkm" (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
res) (Double -> b) -> Double -> b
forall a b. (a -> b) -> a -> b
$ Double -> Double
floorRes Double
d Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000