{-# LANGUAGE MultiParamTypeClasses #-}

-- | Distinguished coordinate systems for the United Kingdom.
module Geodetics.UK (
   OSGB36 (..),
   UkNationalGrid (..),
   ukGrid,
   fromUkGridReference,
   toUkGridReference
) where

import Control.Monad
import Data.Array
import Data.Char
import Geodetics.Geodetic
import Geodetics.Grid
import Geodetics.Ellipsoids
import Geodetics.TransverseMercator



-- | Ellipsoid definition for Great Britain. Airy 1830 offset from the centre of the Earth
-- and rotated slightly.
--
-- The Helmert parameters are from the Ordnance Survey document
-- \"A Guide to Coordinate Systems in Great Britain\", which notes that it
-- can be in error by as much as 5 meters and should not be used in applications
-- requiring greater accuracy.  A more precise conversion requires a large table
-- of corrections for historical inaccuracies in the triangulation of the UK.
data OSGB36 = OSGB36 deriving (OSGB36 -> OSGB36 -> Bool
(OSGB36 -> OSGB36 -> Bool)
-> (OSGB36 -> OSGB36 -> Bool) -> Eq OSGB36
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OSGB36 -> OSGB36 -> Bool
== :: OSGB36 -> OSGB36 -> Bool
$c/= :: OSGB36 -> OSGB36 -> Bool
/= :: OSGB36 -> OSGB36 -> Bool
Eq, Int -> OSGB36 -> ShowS
[OSGB36] -> ShowS
OSGB36 -> String
(Int -> OSGB36 -> ShowS)
-> (OSGB36 -> String) -> ([OSGB36] -> ShowS) -> Show OSGB36
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OSGB36 -> ShowS
showsPrec :: Int -> OSGB36 -> ShowS
$cshow :: OSGB36 -> String
show :: OSGB36 -> String
$cshowList :: [OSGB36] -> ShowS
showList :: [OSGB36] -> ShowS
Show)

instance Ellipsoid OSGB36 where
   majorRadius :: OSGB36 -> Double
majorRadius OSGB36
_ = Double
6377563.396
   flatR :: OSGB36 -> Double
flatR OSGB36
_ = Double
299.3249646
   helmert :: OSGB36 -> Helmert
helmert OSGB36
_ = Helmert {
      cX :: Double
cX = Double
446.448, cY :: Double
cY = -Double
125.157, cZ :: Double
cZ = Double
542.06,
      helmertScale :: Double
helmertScale = -Double
20.4894,
      rX :: Double
rX = Double
0.1502 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
arcsecond, rY :: Double
rY = Double
0.247 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
arcsecond, rZ :: Double
rZ = Double
0.8421 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
arcsecond }

-- | The UK National Grid is a Transverse Mercator projection with a true origin at
-- 49 degrees North, 2 degrees West on OSGB36, and a false origin 400km West and 100 km North of
-- the true origin. The scale factor is defined as @10**(0.9998268 - 1)@.
data UkNationalGrid = UkNationalGrid deriving (UkNationalGrid -> UkNationalGrid -> Bool
(UkNationalGrid -> UkNationalGrid -> Bool)
-> (UkNationalGrid -> UkNationalGrid -> Bool) -> Eq UkNationalGrid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UkNationalGrid -> UkNationalGrid -> Bool
== :: UkNationalGrid -> UkNationalGrid -> Bool
$c/= :: UkNationalGrid -> UkNationalGrid -> Bool
/= :: UkNationalGrid -> UkNationalGrid -> Bool
Eq, Int -> UkNationalGrid -> ShowS
[UkNationalGrid] -> ShowS
UkNationalGrid -> String
(Int -> UkNationalGrid -> ShowS)
-> (UkNationalGrid -> String)
-> ([UkNationalGrid] -> ShowS)
-> Show UkNationalGrid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UkNationalGrid -> ShowS
showsPrec :: Int -> UkNationalGrid -> ShowS
$cshow :: UkNationalGrid -> String
show :: UkNationalGrid -> String
$cshowList :: [UkNationalGrid] -> ShowS
showList :: [UkNationalGrid] -> ShowS
Show)

instance GridClass UkNationalGrid OSGB36 where
   toGrid :: UkNationalGrid -> Geodetic OSGB36 -> GridPoint UkNationalGrid
toGrid UkNationalGrid
_ = UkNationalGrid
-> GridPoint (GridTM OSGB36) -> GridPoint UkNationalGrid
forall b a. b -> GridPoint a -> GridPoint b
unsafeGridCoerce UkNationalGrid
UkNationalGrid (GridPoint (GridTM OSGB36) -> GridPoint UkNationalGrid)
-> (Geodetic OSGB36 -> GridPoint (GridTM OSGB36))
-> Geodetic OSGB36
-> GridPoint UkNationalGrid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GridTM OSGB36 -> Geodetic OSGB36 -> GridPoint (GridTM OSGB36)
forall r e. GridClass r e => r -> Geodetic e -> GridPoint r
toGrid GridTM OSGB36
ukGrid
   fromGrid :: GridPoint UkNationalGrid -> Geodetic OSGB36
fromGrid = GridPoint (GridTM OSGB36) -> Geodetic OSGB36
forall r e. GridClass r e => GridPoint r -> Geodetic e
fromGrid (GridPoint (GridTM OSGB36) -> Geodetic OSGB36)
-> (GridPoint UkNationalGrid -> GridPoint (GridTM OSGB36))
-> GridPoint UkNationalGrid
-> Geodetic OSGB36
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GridTM OSGB36
-> GridPoint UkNationalGrid -> GridPoint (GridTM OSGB36)
forall b a. b -> GridPoint a -> GridPoint b
unsafeGridCoerce GridTM OSGB36
ukGrid
   gridEllipsoid :: UkNationalGrid -> OSGB36
gridEllipsoid UkNationalGrid
_ = OSGB36
OSGB36



ukTrueOrigin :: Geodetic OSGB36
ukTrueOrigin :: Geodetic OSGB36
ukTrueOrigin = Geodetic {
   latitude :: Double
latitude = Double
49 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
degree,
   longitude :: Double
longitude = (-Double
2) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
degree,
   geoAlt :: Double
geoAlt = Double
0,
   ellipsoid :: OSGB36
ellipsoid = OSGB36
OSGB36
}

ukFalseOrigin :: GridOffset
ukFalseOrigin :: GridOffset
ukFalseOrigin = Double -> Double -> Double -> GridOffset
GridOffset ((-Double
400) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer) (Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer) (Double
0 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer)


-- | Numerical definition of the UK national grid.
ukGrid :: GridTM OSGB36
ukGrid :: GridTM OSGB36
ukGrid = Geodetic OSGB36 -> GridOffset -> Double -> GridTM OSGB36
forall e.
Ellipsoid e =>
Geodetic e -> GridOffset -> Double -> GridTM e
mkGridTM Geodetic OSGB36
ukTrueOrigin GridOffset
ukFalseOrigin
   (Double
10 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (Double
0.9998268 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1))


-- | Size of a UK letter-pair grid square.
ukGridSquare :: Double
ukGridSquare :: Double
ukGridSquare = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer


-- | Convert a grid reference to a position, if the reference is valid.
-- This returns the position of the south-west corner of the nominated
-- grid square and an offset to its centre. Altitude is set to zero.
fromUkGridReference :: String -> Maybe (GridPoint UkNationalGrid, GridOffset)
fromUkGridReference :: String -> Maybe (GridPoint UkNationalGrid, GridOffset)
fromUkGridReference String
str =
      case String
str of
         Char
c1:Char
c2:String
ds -> do
            let n :: Int
n = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ds
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int -> Bool
forall a. Integral a => a -> Bool
even Int
n
            let (String
dsE, String
dsN) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) String
ds
            (Double
east, Double
sq) <- Double -> String -> Maybe (Double, Double)
fromGridDigits Double
ukGridSquare String
dsE
            (Double
north, Double
_) <- Double -> String -> Maybe (Double, Double)
fromGridDigits Double
ukGridSquare String
dsN
            GridPoint UkNationalGrid
base <- Char -> Char -> Maybe (GridPoint UkNationalGrid)
fromUkGridLetters Char
c1 Char
c2
            let half :: Double
half = Double
sq Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
            (GridPoint UkNationalGrid, GridOffset)
-> Maybe (GridPoint UkNationalGrid, GridOffset)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (GridOffset -> GridPoint UkNationalGrid -> GridPoint UkNationalGrid
forall g. GridOffset -> GridPoint g -> GridPoint g
applyOffset (Double -> Double -> Double -> GridOffset
GridOffset Double
east Double
north Double
0) GridPoint UkNationalGrid
base,
                  Double -> Double -> Double -> GridOffset
GridOffset Double
half Double
half Double
0)
         String
_ -> Maybe (GridPoint UkNationalGrid, GridOffset)
forall a. Maybe a
Nothing




-- | The south west corner of the nominated grid square, if it is a legal square.
-- This function works for all pairs of letters except 'I' (as that is not used).
-- In practice only those pairs covering the UK are actually considered meaningful.
fromUkGridLetters :: Char -> Char -> Maybe (GridPoint UkNationalGrid)
fromUkGridLetters :: Char -> Char -> Maybe (GridPoint UkNationalGrid)
fromUkGridLetters Char
c1 Char
c2 = GridOffset -> GridPoint UkNationalGrid -> GridPoint UkNationalGrid
forall g. GridOffset -> GridPoint g -> GridPoint g
applyOffset (GridOffset
 -> GridPoint UkNationalGrid -> GridPoint UkNationalGrid)
-> Maybe GridOffset
-> Maybe (GridPoint UkNationalGrid -> GridPoint UkNationalGrid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GridOffset -> GridOffset -> GridOffset
forall a. Monoid a => a -> a -> a
mappend (GridOffset -> GridOffset -> GridOffset)
-> Maybe GridOffset -> Maybe (GridOffset -> GridOffset)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GridOffset
g1 Maybe (GridOffset -> GridOffset)
-> Maybe GridOffset -> Maybe GridOffset
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe GridOffset
g2) Maybe (GridPoint UkNationalGrid -> GridPoint UkNationalGrid)
-> Maybe (GridPoint UkNationalGrid)
-> Maybe (GridPoint UkNationalGrid)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (GridPoint UkNationalGrid)
letterOrigin
   where
      letterOrigin :: Maybe (GridPoint UkNationalGrid)
letterOrigin = GridPoint UkNationalGrid -> Maybe (GridPoint UkNationalGrid)
forall a. a -> Maybe a
Just (GridPoint UkNationalGrid -> Maybe (GridPoint UkNationalGrid))
-> GridPoint UkNationalGrid -> Maybe (GridPoint UkNationalGrid)
forall a b. (a -> b) -> a -> b
$ Double
-> Double -> Double -> UkNationalGrid -> GridPoint UkNationalGrid
forall r. Double -> Double -> Double -> r -> GridPoint r
GridPoint ((-Double
1000) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer) ((-Double
500) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer) Double
m0 UkNationalGrid
UkNationalGrid
      gridIndex :: Char -> Maybe Int
gridIndex Char
c
         | (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'A', Char
'H') Char
c  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A'  -- 'I' is not used.
         | (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'J', Char
'Z') Char
c  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'B'
         | Bool
otherwise             = Maybe Int
forall a. Maybe a
Nothing
      gridSquare :: Char -> Maybe (a, b)
gridSquare Char
c = do -- Maybe monad
         Int
g <- Char -> Maybe Int
gridIndex Char
c
         let (Int
y,Int
x) = Int
g Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
5
         (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x, b
4 b -> b -> b
forall a. Num a => a -> a -> a
- Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
      g1 :: Maybe GridOffset
g1 = do
         (Double
x,Double
y) <- Char -> Maybe (Double, Double)
forall {a} {b}. (Num a, Num b) => Char -> Maybe (a, b)
gridSquare Char
c1
         GridOffset -> Maybe GridOffset
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (GridOffset -> Maybe GridOffset) -> GridOffset -> Maybe GridOffset
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> GridOffset
GridOffset (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
500 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer)) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
500 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer)) Double
m0
      g2 :: Maybe GridOffset
g2 = do
         (Double
x,Double
y) <- Char -> Maybe (Double, Double)
forall {a} {b}. (Num a, Num b) => Char -> Maybe (a, b)
gridSquare Char
c2
         GridOffset -> Maybe GridOffset
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (GridOffset -> Maybe GridOffset) -> GridOffset -> Maybe GridOffset
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> GridOffset
GridOffset (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer)) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer)) Double
m0
      m0 :: Double
m0 = Double
0


-- | Find the nearest UK grid reference point to a specified position. The Int argument is the number of
-- digits precision, so 2 for a 4-figure reference and 3 for a 6-figure reference, although any value
-- between 0 and 5 can be used (giving a 1 meter precision).
-- Altitude is ignored. If the result is outside the area defined by the two letter grid codes then
-- @Nothing@ is returned.
toUkGridReference :: Int -> GridPoint UkNationalGrid -> Maybe String
toUkGridReference :: Int -> GridPoint UkNationalGrid -> Maybe String
toUkGridReference Int
n GridPoint UkNationalGrid
p
   | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0         = String -> Maybe String
forall a. HasCallStack => String -> a
error String
"toUkGridReference: precision argument must not be negative."
   | Bool
otherwise     = do
      (Integer
gx, String
strEast) <- Double -> Int -> Double -> Maybe (Integer, String)
toGridDigits Double
ukGridSquare Int
n (Double -> Maybe (Integer, String))
-> Double -> Maybe (Integer, String)
forall a b. (a -> b) -> a -> b
$ GridPoint UkNationalGrid -> Double
forall r. GridPoint r -> Double
eastings GridPoint UkNationalGrid
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1000 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer
      (Integer
gy, String
strNorth) <- Double -> Int -> Double -> Maybe (Integer, String)
toGridDigits Double
ukGridSquare Int
n (Double -> Maybe (Integer, String))
-> Double -> Maybe (Integer, String)
forall a b. (a -> b) -> a -> b
$ GridPoint UkNationalGrid -> Double
forall r. GridPoint r -> Double
northings GridPoint UkNationalGrid
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
500 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
kilometer
      let (Int
gx1, Int
gx2) = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
gx Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
5
          (Int
gy1, Int
gy2) = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
gy Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
5
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
gx1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5 Bool -> Bool -> Bool
&& Int
gy1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5)
      let c1 :: Char
c1 = Int -> Int -> Char
gridSquare Int
gx1 Int
gy1
          c2 :: Char
c2 = Int -> Int -> Char
gridSquare Int
gx2 Int
gy2
      String -> Maybe String
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Char
c1 Char -> ShowS
forall a. a -> [a] -> [a]
: Char
c2 Char -> ShowS
forall a. a -> [a] -> [a]
: String
strEast String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
strNorth
   where
      gridSquare :: Int -> Int -> Char
gridSquare Int
x Int
y = Array (Int, Int) Char
letters Array (Int, Int) Char -> (Int, Int) -> Char
forall i e. Ix i => Array i e -> i -> e
! (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y, Int
x)
      letters :: Array (Int, Int) Char
      letters :: Array (Int, Int) Char
letters = ((Int, Int), (Int, Int)) -> String -> Array (Int, Int) Char
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray ((Int
0,Int
0),(Int
4,Int
4)) (String -> Array (Int, Int) Char)
-> String -> Array (Int, Int) Char
forall a b. (a -> b) -> a -> b
$ [Char
'A'..Char
'H'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'J'..Char
'Z']