module MGRSRef where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.Except
import Data.Char
import Data.Fixed
import Text.Regex.PCRE
import Datum
import qualified UTMRef as U
data MGRSRef = MGRSRef { easting :: Int
, northing :: Int
, eastingId :: Char
, northingId :: Char
, utmZoneNumber :: Int
, utmZoneChar :: Char
, precision :: Precision
, isBessel :: Bool
, datum :: Datum
} deriving (Eq)
data Precision = M1
| M10
| M100
| M1000
| M10000
deriving (Eq)
instance Enum Precision where
fromEnum M1 = 1
fromEnum M10 = 10
fromEnum M100 = 100
fromEnum M1000 = 1000
fromEnum M10000 = 10000
toEnum 1 = M1
toEnum 10 = M10
toEnum 100 = M100
toEnum 1000 = M1000
toEnum 10000 = M10000
northingIds :: [Char]
northingIds = [ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'J', 'K'
, 'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'U', 'V' ]
instance Show MGRSRef where
show m@(MGRSRef _ _ _ _ _ _ precision _ _) = showWithPrecision m precision
showWithPrecision :: MGRSRef
-> Precision
-> String
showWithPrecision (MGRSRef easting northing eastingId northingId utmZoneNumber utmZoneChar _ _ _) precision = do
let
p = fromEnum precision
eastingR = easting `div` p
northingR = northing `div` p
padding = case precision of
M1 -> 5
M10 -> 4
M100 -> 3
M1000 -> 2
M10000 -> 1
eastingRs = padWithZeros (show eastingR) padding
northingRs = padWithZeros (show northingR) padding
utmZonePadding = if (utmZoneNumber < 10) then "0" else ""
utmZonePadding ++ show utmZoneNumber ++ [utmZoneChar] ++ [eastingId] ++ [northingId] ++ eastingRs ++ northingRs
where padWithZeros :: String -> Int -> String
padWithZeros text padding =
if (padding length text > 0) then padWithZeros ('0' : text) padding
else text
toMGRSRef :: U.UTMRef
-> Bool
-> MGRSRef
toMGRSRef (U.UTMRef easting northing latZone lngZone _) isBessel = do
let
set = (lngZone 1) `mod` 6 + 1
eId = (\x -> x + (if x > 14 then 1 else 0))
. (\x -> x + (if x > 8 then 1 else 0))
$ (floor (easting / 100000.0) + 8 * ((set 1) `mod` 3))
eIdC = chr $ eId + 64
nId = (\x -> x (if x > 19 then 20 else 0))
. (\x -> x + (if isBessel then 10 else 0))
. (\x -> x + (if even set then 5 else 0))
$ floor ((northing `mod'` 2000000) / 100000.0)
nIdC = northingIds !! nId
MGRSRef (round(easting) `mod` 100000) (round(northing) `mod` 100000) eIdC nIdC lngZone latZone M1 isBessel wgs84Datum
mkMGRSRef :: Int
-> Int
-> Char
-> Char
-> Int
-> Char
-> Precision
-> Bool
-> Except String MGRSRef
mkMGRSRef e n eId nId un uc p b = do
est <- withExcept (const "Invalid easting") (evalEasting e)
nrt <- withExcept (const "Invalid northing") (evalNorthing n)
estId <- withExcept (const "Invalid eastingId") (evalEastingId eId)
nrtId <- withExcept (const "Invalid northingId") (evalNorthingId nId)
uzn <- withExcept (const "Invalid utmZoneNumber") (evalUtmZoneNumber un)
uzc <- withExcept (const "Invalid utmZoneChar") (evalUtmZoneChar uc)
pure MGRSRef { easting = est
, northing = nrt
, eastingId = estId
, northingId = nrtId
, utmZoneNumber = uzn
, utmZoneChar = uzc
, precision = p
, isBessel = b
, datum = wgs84Datum }
where evalEasting :: Int -> Except String Int
evalEasting e | e < 0 || e > 99999 = throwError ("Invalid easting (" ++ show e ++ ")")
| otherwise = pure (e)
evalNorthing :: Int -> Except String Int
evalNorthing n | n < 0 || n > 99999 = throwError ("Invalid northing (" ++ show n ++ ")")
| otherwise = pure (n)
evalUtmZoneNumber :: Int -> Except String Int
evalUtmZoneNumber u | u < 1 || u > 60 = throwError ("Invalid utmZoneNumber (" ++ show u ++ ")")
| otherwise = pure (u)
evalUtmZoneChar :: Char -> Except String Char
evalUtmZoneChar u | u < 'A' || u > 'Z' = throwError ("Invalid utmZoneChar (" ++ show u ++ ")")
| otherwise = pure (u)
evalEastingId :: Char -> Except String Char
evalEastingId e | e < 'A' || e > 'Z' || e == 'I' || e == 'O' = throwError ("Invalid eastingId (" ++ show e ++ ")")
| otherwise = pure (e)
evalNorthingId :: Char -> Except String Char
evalNorthingId n | n < 'A' || n > 'Z' || n == 'I' || n == 'O' = throwError ("Invalid northingId (" ++ show n ++ ")")
| otherwise = pure (n)
mkMGRSRef' :: String
-> Except String MGRSRef
mkMGRSRef' ref = do
groups <- withExcept (const "Invalid easting") (evalRefMatch ref)
let
group = head groups
en = group !! 5
enlh = length en `div` 2
p = 10 ^ (5 enlh)
pure MGRSRef { easting = p * (read (take enlh en) :: Int)
, northing = p * (read (drop enlh en) :: Int)
, eastingId = (group !! 3) !! 0
, northingId = (group !! 4) !! 0
, utmZoneNumber = read (group !! 1) :: Int
, utmZoneChar = (group !! 2) !! 0
, precision = toEnum p
, isBessel = False
, datum = wgs84Datum }
where evalRefMatch :: String -> Except String [[String]]
evalRefMatch ref = do
let groups = ref =~ "(\\d{1,2})((?![IO])[C-X])((?![IO])[A-Z])((?![IO])[A-Z])(\\d{2,10})" :: [[String]]
case groups of
[] -> throwError ("No matches")
[_,_,_,_,_,en]
| odd $ length en -> throwError ("Invalid ref")
| otherwise -> pure groups
_ -> pure groups
toUTMRef :: MGRSRef -> Except String U.UTMRef
toUTMRef (MGRSRef easting northing eastingId northingId utmZoneNumber utmZoneChar _ _ _) = do
let
set = (utmZoneNumber 1) `mod` 6 + 1
isOffset = even set
e = (\x -> if (x > 9) then x 1 else x)
. (\x -> if (x > 15) then x 1 else x)
$ ord eastingId 65
ex = (easting + ((e `mod` 8 + 1) * 100000)) `mod` 1000000
n = (\x -> if (x < 0) then x + 16 else x)
. (\x -> if isOffset then x 5 else x)
. (\x -> if (x > 9) then x 1 else x)
. (\x -> if (x > 15) then x 1 else x)
$ ord northingId 64
nn = case utmZoneChar of
'Q'
| (not(isOffset) && northingId < 'T') || (isOffset && (northingId < 'C' || northingId > 'E')) -> 2000000
| otherwise -> 0
'R' -> 2000000
'S'
| (not(isOffset) && northingId < 'R') || (isOffset && northingId > 'E') -> 4000000
| otherwise -> 2000000
'T' -> 4000000
'U'
| (not(isOffset) && northingId < 'P') || (isOffset && northingId > 'U') -> 6000000
| otherwise -> 4000000
'V' -> 6000000
'W' -> 6000000
'X' -> 8000000
nx = nn + (100000 * (n 1)) + northing
U.mkUTMRef (fromIntegral ex) (fromIntegral nx) utmZoneChar utmZoneNumber