{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores    #-}
{-# LANGUAGE FlexibleContexts #-}

{- | Universal Transverse Mercator (UTM)

The UTM grid system covers the whole world between 84°N and 80°S. It divides the world into 
grid zones of 6° longitude by 8° latitude. Each zone has a 2 digit number for longitude and
a letter for latitude. This regular system has two exceptions:

* North of Norway the zones 32X, 34X and 36X are not used, with 31X, 33X, 35X and 37X being
  wider instead.

* Zone 32V is widened to cover the south-western end of Norway.

There are two notations for writing UTM grid positions:

* The UTM standard: Zone number, N or S for hemisphere, and then northings and eastings
  relative to the equator.

* The Military Grid Reference System (MGRS): Zone number, latitude band letter, a
  2 letter code for the 100km square within the zone, and then northings and eastings within
  that square.

In this library each UTM longitude zone has two grids, one for the northern hemisphere and
one for the south.

For more details see

* https://en.wikipedia.org/wiki/Universal_Transverse_Mercator_coordinate_system.

* THE UNIVERSAL GRIDS: Universal Transverse Mercator (UTM) and Universal Polar Stereographic (UPS).
  DMA Technical Manual. AD-A226497. https://apps.dtic.mil/sti/tr/pdf/ADA266497.pdf
-}
module Geodetics.UTM (
  UtmHemisphere (..),
  UtmZoneNumber,
  utmZoneNumber,
  UtmZone (utmHemisphere, utmZoneNum, utmProjection),
  utmZone,
  mkUtmZone,
  mkUtmZoneUnsafe,
  fromUtmGridReference,
  parseUtmGridReference,
  toUtmGridReference
) where

import Control.Monad (guard, void, when, unless)
import Data.Char
import Data.List
import Geodetics.Ellipsoids
import Geodetics.Geodetic
import Geodetics.Grid
import Geodetics.TransverseMercator
import Text.Parsec
import Text.Parsec.Error
import Text.Printf
import Text.Read



-- | In UTM the northern and southern hemispheres have different false origins.
data UtmHemisphere = UtmNorth | UtmSouth deriving UtmHemisphere -> UtmHemisphere -> Bool
(UtmHemisphere -> UtmHemisphere -> Bool)
-> (UtmHemisphere -> UtmHemisphere -> Bool) -> Eq UtmHemisphere
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UtmHemisphere -> UtmHemisphere -> Bool
== :: UtmHemisphere -> UtmHemisphere -> Bool
$c/= :: UtmHemisphere -> UtmHemisphere -> Bool
/= :: UtmHemisphere -> UtmHemisphere -> Bool
Eq

instance Show UtmHemisphere where
  show :: UtmHemisphere -> String
show UtmHemisphere
UtmNorth = String
"N"
  show UtmHemisphere
UtmSouth = String
"S"


-- | A UTM Zone number. Must be between 1 and 60.
type UtmZoneNumber = Int


-- | A UTM Zone, representing a band of typically 6 degrees of latitude between the equator and one of
-- the poles. The projection *must* match the hemisphere and zone.
data UtmZone = UtmZone {
  UtmZone -> UtmHemisphere
utmHemisphere :: UtmHemisphere,
  UtmZone -> Int
utmZoneNum :: UtmZoneNumber,
  UtmZone -> GridTM WGS84
utmProjection :: GridTM WGS84
} deriving (Int -> UtmZone -> ShowS
[UtmZone] -> ShowS
UtmZone -> String
(Int -> UtmZone -> ShowS)
-> (UtmZone -> String) -> ([UtmZone] -> ShowS) -> Show UtmZone
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UtmZone -> ShowS
showsPrec :: Int -> UtmZone -> ShowS
$cshow :: UtmZone -> String
show :: UtmZone -> String
$cshowList :: [UtmZone] -> ShowS
showList :: [UtmZone] -> ShowS
Show)

instance Eq UtmZone where
  UtmZone
z1 == :: UtmZone -> UtmZone -> Bool
== UtmZone
z2  = UtmZone -> UtmHemisphere
utmHemisphere UtmZone
z1 UtmHemisphere -> UtmHemisphere -> Bool
forall a. Eq a => a -> a -> Bool
== UtmZone -> UtmHemisphere
utmHemisphere UtmZone
z2 Bool -> Bool -> Bool
&& UtmZone -> Int
utmZoneNum UtmZone
z1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== UtmZone -> Int
utmZoneNum UtmZone
z2

instance GridClass UtmZone WGS84 where
  fromGrid :: GridPoint UtmZone -> Geodetic WGS84
fromGrid GridPoint UtmZone
p = GridPoint (GridTM WGS84) -> Geodetic WGS84
forall r e. GridClass r e => GridPoint r -> Geodetic e
fromGrid (GridPoint (GridTM WGS84) -> Geodetic WGS84)
-> GridPoint (GridTM WGS84) -> Geodetic WGS84
forall a b. (a -> b) -> a -> b
$ GridTM WGS84 -> GridPoint UtmZone -> GridPoint (GridTM WGS84)
forall b a. b -> GridPoint a -> GridPoint b
unsafeGridCoerce (UtmZone -> GridTM WGS84
utmProjection (UtmZone -> GridTM WGS84) -> UtmZone -> GridTM WGS84
forall a b. (a -> b) -> a -> b
$ GridPoint UtmZone -> UtmZone
forall r. GridPoint r -> r
gridBasis GridPoint UtmZone
p) GridPoint UtmZone
p
  toGrid :: UtmZone -> Geodetic WGS84 -> GridPoint UtmZone
toGrid UtmZone
grid = UtmZone -> GridPoint (GridTM WGS84) -> GridPoint UtmZone
forall b a. b -> GridPoint a -> GridPoint b
unsafeGridCoerce UtmZone
grid (GridPoint (GridTM WGS84) -> GridPoint UtmZone)
-> (Geodetic WGS84 -> GridPoint (GridTM WGS84))
-> Geodetic WGS84
-> GridPoint UtmZone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GridTM WGS84 -> Geodetic WGS84 -> GridPoint (GridTM WGS84)
forall r e. GridClass r e => r -> Geodetic e -> GridPoint r
toGrid (UtmZone -> GridTM WGS84
utmProjection UtmZone
grid)
  gridEllipsoid :: UtmZone -> WGS84
gridEllipsoid UtmZone
_ = WGS84
WGS84


-- Internal data type representing a "rectangle" of latitude/longitude with an exceptional zone number.
data UtmException = UtmE {
  UtmException -> (Int, Int)
uteSW :: (Int, Int),  -- South west corner in integer degrees (lat, long), inclusive.
  UtmException -> (Int, Int)
uteNE :: (Int, Int),  -- North east corner in integer degrees (lat, long), exclusive.
  UtmException -> Int
uteActual :: UtmZoneNumber
} deriving Int -> UtmException -> ShowS
[UtmException] -> ShowS
UtmException -> String
(Int -> UtmException -> ShowS)
-> (UtmException -> String)
-> ([UtmException] -> ShowS)
-> Show UtmException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UtmException -> ShowS
showsPrec :: Int -> UtmException -> ShowS
$cshow :: UtmException -> String
show :: UtmException -> String
$cshowList :: [UtmException] -> ShowS
showList :: [UtmException] -> ShowS
Show


-- | Determine if the integer latitude and longitude are within the exception area.
inException :: Int -> Int -> UtmException -> Bool
inException :: Int -> Int -> UtmException -> Bool
inException Int
lat Int
long UtmException
e =
    Int -> Int -> Int -> Bool
forall {a}. Ord a => a -> a -> a -> Bool
inR Int
lat  ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ UtmException -> (Int, Int)
uteSW UtmException
e) ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ UtmException -> (Int, Int)
uteNE UtmException
e) Bool -> Bool -> Bool
&&
    Int -> Int -> Int -> Bool
forall {a}. Ord a => a -> a -> a -> Bool
inR Int
long ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ UtmException -> (Int, Int)
uteSW UtmException
e) ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ UtmException -> (Int, Int)
uteNE UtmException
e)
  where
    inR :: a -> a -> a -> Bool
inR a
v a
v1 a
v2 = a
v1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
v Bool -> Bool -> Bool
&& a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
v2


-- The UTM zone that encloses a given geodetic position. For most of the world this is based on
-- @longitude/6@, but there are exceptions around Norway and Svalbard.
utmZoneNumber :: Geodetic a -> Maybe UtmZoneNumber
utmZoneNumber :: forall a. Geodetic a -> Maybe Int
utmZoneNumber Geodetic a
geo = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
lat1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (-Int
80) Bool -> Bool -> Bool
&& Int
lat1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
84
    Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (UtmException -> Int) -> Maybe UtmException -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
zone1 UtmException -> Int
uteActual Maybe UtmException
exception
  where
    lat1 :: Int
lat1 = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Geodetic a -> Double
forall e. Geodetic e -> Double
latitude Geodetic a
geo Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
degree
    long1 :: Int
long1 = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Geodetic a -> Double
forall e. Geodetic e -> Double
longitude Geodetic a
geo Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
degree
    zone1 :: Int
zone1 = (Int
long1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
30) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    exception :: Maybe UtmException
exception = (UtmException -> Bool) -> [UtmException] -> Maybe UtmException
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Int -> Int -> UtmException -> Bool
inException Int
lat1 Int
long1)
      [
        (Int, Int) -> (Int, Int) -> Int -> UtmException
UtmE (Int
56,Int
03) (Int
64,Int
12) Int
32,  -- Southwestern end of Norway around Bergen.
        (Int, Int) -> (Int, Int) -> Int -> UtmException
UtmE (Int
72,Int
00) (Int
84,Int
09) Int
31,
        (Int, Int) -> (Int, Int) -> Int -> UtmException
UtmE (Int
72,Int
09) (Int
84,Int
21) Int
33,  -- Svalbard.
        (Int, Int) -> (Int, Int) -> Int -> UtmException
UtmE (Int
72,Int
21) (Int
84,Int
33) Int
35,
        (Int, Int) -> (Int, Int) -> Int -> UtmException
UtmE (Int
72,Int
33) (Int
84,Int
42) Int
37
      ]


-- | The UTM Zone for the given location, if it exists.
utmZone :: Geodetic a -> Maybe UtmZone
utmZone :: forall a. Geodetic a -> Maybe UtmZone
utmZone Geodetic a
geo = do
  let hemi :: UtmHemisphere
hemi = if Geodetic a -> Double
forall e. Geodetic e -> Double
latitude Geodetic a
geo Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 then UtmHemisphere
UtmNorth else UtmHemisphere
UtmSouth
  Int
zn <- Geodetic a -> Maybe Int
forall a. Geodetic a -> Maybe Int
utmZoneNumber Geodetic a
geo
  UtmHemisphere -> Int -> Maybe UtmZone
mkUtmZone UtmHemisphere
hemi Int
zn


-- | Construct a UTM Zone value. Returns @Nothing@ if the zone number is out of range.
mkUtmZone :: UtmHemisphere -> UtmZoneNumber -> Maybe UtmZone
mkUtmZone :: UtmHemisphere -> Int -> Maybe UtmZone
mkUtmZone UtmHemisphere
h Int
n = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
60
    UtmZone -> Maybe UtmZone
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (UtmZone -> Maybe UtmZone) -> UtmZone -> Maybe UtmZone
forall a b. (a -> b) -> a -> b
$ UtmHemisphere -> Int -> UtmZone
mkUtmZoneUnsafe UtmHemisphere
h Int
n


-- | Construct a UTM Zone value without checking whether the zone number is valid.
mkUtmZoneUnsafe :: UtmHemisphere -> UtmZoneNumber -> UtmZone
mkUtmZoneUnsafe :: UtmHemisphere -> Int -> UtmZone
mkUtmZoneUnsafe UtmHemisphere
h Int
n = UtmHemisphere -> Int -> GridTM WGS84 -> UtmZone
UtmZone UtmHemisphere
h Int
n (GridTM WGS84 -> UtmZone) -> GridTM WGS84 -> UtmZone
forall a b. (a -> b) -> a -> b
$ Geodetic WGS84 -> GridOffset -> Double -> GridTM WGS84
forall e.
Ellipsoid e =>
Geodetic e -> GridOffset -> Double -> GridTM e
mkGridTM Geodetic WGS84
trueO GridOffset
falseO Double
scale
  where
    trueO :: Geodetic WGS84
trueO = Double -> Double -> Double -> WGS84 -> Geodetic WGS84
forall e. Double -> Double -> Double -> e -> Geodetic e
Geodetic Double
0 (Double
degree Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
183)) Double
0 WGS84
WGS84
    falseO :: GridOffset
falseO = case UtmHemisphere
h of
      UtmHemisphere
UtmNorth -> Double -> Double -> Double -> GridOffset
GridOffset (-Double
500_000) Double
0 Double
0
      UtmHemisphere
UtmSouth -> Double -> Double -> Double -> GridOffset
GridOffset (-Double
500_000) (-Double
10_000_000) Double
0
    scale :: Double
scale = Double
0.999_6


-- | Convert a grid reference to a position, if the reference is valid.
--
-- The northings and eastings cannot contain more than 20 digits each,
-- including an optional decimal point. Negative values are not permitted.
--
-- Northings and eastings can each be followed by an optional unit. The unit
-- must be either \"m\" or \"km\". The units for both
-- must be the same because otherwise its probably an error. The default is meters.
--
-- Northings may be followed by an \"N\" and Eastings may be followed by an \"E\".
--
-- If the argument cannot be parsed then one or more error messages are returned.
fromUtmGridReference :: String -> Either [String] (GridPoint UtmZone)
fromUtmGridReference :: String -> Either [String] (GridPoint UtmZone)
fromUtmGridReference String
str = case Parsec String () (GridPoint UtmZone)
-> String -> String -> Either ParseError (GridPoint UtmZone)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (GridPoint UtmZone)
forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m (GridPoint UtmZone)
parseUtmGridReference String
str String
str of
    Left ParseError
err -> [String] -> Either [String] (GridPoint UtmZone)
forall a b. a -> Either a b
Left ([String] -> Either [String] (GridPoint UtmZone))
-> [String] -> Either [String] (GridPoint UtmZone)
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 UtmZone
r -> GridPoint UtmZone -> Either [String] (GridPoint UtmZone)
forall a b. b -> Either a b
Right GridPoint UtmZone
r


parseUtmGridReference :: Stream s m Char => ParsecT s u m (GridPoint UtmZone)
parseUtmGridReference :: forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m (GridPoint UtmZone)
parseUtmGridReference = do
      ParsecT s u m ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces1
      Int
zone <- ParsecT s u m Int
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Int
readZone ParsecT s u m Int -> String -> ParsecT s u m Int
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"Zone number"
      UtmHemisphere
hemi <- ParsecT s u m UtmHemisphere
forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m UtmHemisphere
readHemi ParsecT s u m UtmHemisphere
-> String -> ParsecT s u m UtmHemisphere
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"Hemisphere (N or S)"
      ParsecT s u m ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces1
      (Double
eastings1, Maybe GridUnit
eastUnit) <- ParsecT s u m (Double, Maybe GridUnit)
forall s (m :: * -> *) u.
Stream s m Char =>
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 s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces1
      (Double
northings1, Maybe GridUnit
northUnit) <- ParsecT s u m (Double, Maybe GridUnit)
forall s (m :: * -> *) u.
Stream s m Char =>
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 s (m :: * -> *) u. Stream s m Char => 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 s (m :: * -> *) u. Stream s m Char => 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 UtmZone -> ParsecT s u m (GridPoint UtmZone)
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GridPoint UtmZone -> ParsecT s u m (GridPoint UtmZone))
-> GridPoint UtmZone -> ParsecT s u m (GridPoint UtmZone)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> UtmZone -> GridPoint UtmZone
forall r. Double -> Double -> Double -> r -> GridPoint r
GridPoint Double
eastings1 Double
northings1 Double
0 (UtmZone -> GridPoint UtmZone) -> UtmZone -> GridPoint UtmZone
forall a b. (a -> b) -> a -> b
$ UtmHemisphere -> Int -> UtmZone
mkUtmZoneUnsafe UtmHemisphere
hemi Int
zone
  where
    readZone :: Stream s m Char => ParsecT s u m UtmZoneNumber
    readZone :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Int
readZone = do
      String
ds <- 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
      case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
ds of
        Maybe Int
Nothing -> String -> ParsecT s u m Int
forall a. String -> ParsecT s u m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Zone number not found."
        Just Int
n ->
          if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
60
            then String -> ParsecT s u m Int
forall a. String -> ParsecT s u m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT s u m Int) -> String -> ParsecT s u m Int
forall a b. (a -> b) -> a -> b
$ String
"Zone number " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" out of range."
            else Int -> ParsecT s u m Int
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
    readHemi :: Stream s m Char => ParsecT s u m UtmHemisphere
    readHemi :: forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m UtmHemisphere
readHemi = do
      Char
h <- String -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"NSns"
      case Char -> Char
toUpper Char
h of
        Char
'N' -> UtmHemisphere -> ParsecT s u m UtmHemisphere
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UtmHemisphere
UtmNorth
        Char
'S' -> UtmHemisphere -> ParsecT s u m UtmHemisphere
forall a. a -> ParsecT s u m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UtmHemisphere
UtmSouth
        Char
_ -> String -> ParsecT s u m UtmHemisphere
forall a. String -> ParsecT s u m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT s u m UtmHemisphere)
-> String -> ParsecT s u m UtmHemisphere
forall a b. (a -> b) -> a -> b
$ String
"Invalid hemisphere: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: String
". Must be N or S.")
    readDistance :: Stream s m Char => ParsecT s u m (Double, Maybe GridUnit)  -- (Distance, unit)
    readDistance :: forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m (Double, Maybe GridUnit)
readDistance = do
      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 s (m :: * -> *) u. Stream s m Char => 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: Stream s m Char => ParsecT s u m ()
    spaces1 :: forall s (m :: * -> *) u. Stream s m Char => 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.


-- | Convert a grid point to a UTM grid reference.
-- The northings and eastings are rounded down to the resolution, so the result is the south-west
-- corner of the grid square enclosing the grid point.
toUtmGridReference ::
  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 UtmZone
  -> String
toUtmGridReference :: Maybe GridUnit -> Bool -> Int -> GridPoint UtmZone -> String
toUtmGridReference Maybe GridUnit
unit Bool
letters Int
res GridPoint UtmZone
gp =
    String
zoneStr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    Double -> String
forall {b}. PrintfType b => Double -> b
dist (GridPoint UtmZone -> Double
forall r. GridPoint r -> Double
eastings GridPoint UtmZone
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 UtmZone -> Double
forall r. GridPoint r -> Double
northings GridPoint UtmZone
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)
    b :: UtmZone
b = GridPoint UtmZone -> UtmZone
forall r. GridPoint r -> r
gridBasis GridPoint UtmZone
gp
    zoneStr :: String
zoneStr = String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02d" (UtmZone -> Int
utmZoneNum UtmZone
b) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UtmHemisphere -> String
forall a. Show a => a -> String
show (UtmZone -> UtmHemisphere
utmHemisphere UtmZone
b)
    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