{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Graphics.Vega.VegaLite.Geometry
Copyright   : (c) Douglas Burke, 2018-2020
License     : BSD3

Maintainer  : dburke.gw@gmail.com
Stability   : unstable
Portability : CPP, OverloadedStrings

Geometric shapes and projections.

-}

module Graphics.Vega.VegaLite.Geometry
       ( geometry
       , geoFeatureCollection
       , geometryCollection
       , Geometry(..)

       , sphere
       , graticule
       , GraticuleProperty(..)

       , projection
       , ProjectionProperty(..)
       , Projection(..)
       , ClipRect(..)

       -- not for external export
       , projectionProperty

       ) where

import qualified Data.Aeson as A
import qualified Data.Text as T

import Control.Arrow (second)
import Data.Aeson ((.=), object, toJSON)

#if !(MIN_VERSION_base(4, 12, 0))
import Data.Monoid ((<>))
#endif


import Graphics.Vega.VegaLite.Data
  ( DataValue
  , dataValueSpec
  )
import Graphics.Vega.VegaLite.Foundation (fromT)
import Graphics.Vega.VegaLite.Specification
  ( VLProperty(VLData, VLProjection)
  , VLSpec
  , LabelledSpec
  , PropertySpec
  )
import Graphics.Vega.VegaLite.Input
  ( Data
  )


type_ :: T.Text -> LabelledSpec
type_ t = "type" .= t


{-|

Specifies a list of geo features to be used in a geoShape specification.
Each feature object in this collection can be created with the 'geometry'
function.

@
'geoFeatureCollection'
    [ 'geometry' ('GeoPolygon' [ [ ( -3, 59 ), ( -3, 52 ), ( 4, 52 ), ( -3, 59 ) ] ])
        [ ( "myRegionName", 'Graphics.Vega.VegaLite.Str' "Northern region" ) ]
    , 'geometry' ('GeoPolygon' [ [ ( -3, 52 ), ( 4, 52 ), ( 4, 45 ), ( -3, 52 ) ] ])
        [ ( "myRegionName", 'Graphics.Vega.VegaLite.Str' "Southern region" ) ]
    ]
@
-}
geoFeatureCollection :: [VLSpec] -> VLSpec
geoFeatureCollection geoms =
  object [ type_ "FeatureCollection"
         , "features" .=  geoms
         ]


{-|

Specifies a list of geometry objects to be used in a geoShape specification.
Each geometry object in this collection can be created with the 'geometry'
function.

@
'geometryCollection'
    [ 'geometry' ('GeoPolygon' [ [ ( -3, 59 ), ( 4, 59 ), ( 4, 52 ), ( -3, 59 ) ] ]) []
    , 'geometry' ('GeoPoint' -3.5 55.5) []
    ]
@
-}
geometryCollection :: [VLSpec] -> VLSpec
geometryCollection geoms =
  object [ type_ "GeometryCollection"
         , "geometries" .= geoms
         ]


{-|

Types of geographic map projection. These are based on a subset of those provided
by the <https://github.com/d3/d3-geo d3-geo library>. For details of available
projections see the
<https://vega.github.io/vega-lite/docs/projection.html#projection-types Vega-Lite documentation>.
-}

-- based on schema 3.3.0 #/definitions/ProjectionType

data Projection
    = Albers
      -- ^ An Albers equal-area conic map projection.
    | AlbersUsa
      -- ^ An Albers USA map projection that combines continental USA with
      --   Alaska and Hawaii. Unlike other projection types, this remains
      --   unaffected by 'PrRotate'.
    | AzimuthalEqualArea
      -- ^ An azimuthal equal area map projection.
    | AzimuthalEquidistant
      -- ^ An azimuthal equidistant map projection.
    | ConicConformal
      -- ^ A conformal conic map projection.
    | ConicEqualArea
      -- ^ An equal area conic map projection.
    | ConicEquidistant
      -- ^ An equidistant conic map projection.
    | Custom T.Text
      -- ^ Specify the name of the custom D3 prohection to use. See the
      --   <https://vega.github.io/vega/docs/projections/#register Vega API>
      --   for more information.
      --
      --   An example: @Custom "winkle3"@
    | EqualEarth
      -- ^ An <https://github.com/d3/d3-geo#equal-earth Equal Earth map projection>
      --   that provides a reasonable shape approximation while retaining relative areas.
      --
      --   @since 0.5.0.0
    | Equirectangular
      -- ^ An equirectangular map projection that maps longitude to x and latitude to y.
      --   While showing less area distortion towards the poles than the default 'Mercator'
      --   projection, it is neither equal-area nor conformal.
    | Gnomonic
      -- ^ A gnomonic map projection.
    | Identity
      -- ^ The identiy projection. This can be combined with 'PrReflectX' and
      --   'PrReflectY' in the list of projection properties.
      --
      --   @since 0.4.0.0
    | Mercator
      -- ^ A Mercator map projection. This is the default projection of longitude, latitude
      --   values if no projection is set explicitly. It preserves shape (local angle) and
      --   lines of equal angular bearing remain parallel straight lines. The area is
      --   /significantly/ enlarged towards the poles.
    | NaturalEarth1
      -- ^ The <https://github.com/d3/d3-geo#geoNaturalEarth1 Natural Earth projection>
      --   is neither conformal nor equal-area, but is designed to be \"appealing to the
      --   eye\" for small-scale maps of the whole world.
      --
      --   @since 0.5.0.0
    | Orthographic
      -- ^ An orthographic map projection.
    | Stereographic
      -- ^ A stereographic map projection.
    | TransverseMercator
      -- ^ A transverse Mercator map projection.


projectionLabel :: Projection -> T.Text
projectionLabel Albers = "albers"
projectionLabel AlbersUsa = "albersUsa"
projectionLabel AzimuthalEqualArea = "azimuthalEqualArea"
projectionLabel AzimuthalEquidistant = "azimuthalEquidistant"
projectionLabel ConicConformal = "conicConformal"
projectionLabel ConicEqualArea = "conicEqualarea"
projectionLabel ConicEquidistant = "conicEquidistant"
projectionLabel (Custom pName) = pName
projectionLabel EqualEarth = "equalEarth"
projectionLabel Equirectangular = "equirectangular"
projectionLabel Gnomonic = "gnomonic"
projectionLabel Identity = "identity"
projectionLabel Mercator = "mercator"
projectionLabel NaturalEarth1 = "naturalEarth1"
projectionLabel Orthographic = "orthographic"
projectionLabel Stereographic = "stereographic"
projectionLabel TransverseMercator = "transverseMercator"


-- | Specifies a clipping rectangle for defining
--   the clip extent of a map projection.

data ClipRect
    = NoClip
      -- ^ No clipping it to be applied.
    | LTRB Double Double Double Double
      -- ^ The left, top, right, and bottom extents, in pixels,
      --   of a rectangular clip.


{-|

Properties for customising a geospatial projection that converts longitude,latitude
pairs into planar @(x,y)@ coordinate pairs for rendering and query. For details see the
<https://vega.github.io/vega-lite/docs/projection.html Vega-Lite documentation>.

This type has been changed in the @0.4.0.0@ release so that all constructors
start with @Pr@ rather than @P@ (and so provide some differentiation to the
'Graphics.Vega.VegaLite.PositionChannel' constructors).

-}

-- based on schema 3.3.0 #/definitions/Projection

data ProjectionProperty
    = PrType Projection
      -- ^ The type of the map projection.
    | PrClipAngle (Maybe Double)
      -- ^ The clipping circle angle in degrees. A value of @Nothing@ will switch to
      --   antimeridian cutting rather than small-circle clipping.
    | PrClipExtent ClipRect
      -- ^ Projection’s viewport clip extent to the specified bounds in pixels.
    | PrCenter Double Double
      -- ^ Projection’s center as longitude and latitude in degrees.
    | PrScale Double
      -- ^ The projection's zoom scale, which if set, overrides automatic scaling of a
      --   geo feature to fit within the viewing area.
      --
      --   @since 0.4.0.0
    | PrTranslate Double Double
      -- ^ A projection’s panning translation, which if set, overrides automatic positioning
      --   of a geo feature to fit within the viewing area
      --
      --   Note that the prefix is @Pr@ and not @P@, to match the Elm API.
      --
      --   @since 0.4.0.0
    | PrRotate Double Double Double
      -- ^ A projection’s three-axis rotation angle. The order is @lambda@ @phi@ @gamma@,
      --   and specifies the rotation angles in degrees about each spherical axis.
    | PrPrecision Double
      -- ^ Threshold for the projection’s adaptive resampling in pixels, and corresponds to the
      --   Douglas–Peucker distance. If precision is not specified, the projection’s current
      --   resampling precision of 0.707 is used.
      --
      --   Version 3.3.0 of the Vega-Lite spec claims this should be output as a string,
      --   but it is written out as a number since the
      --   [spec is in error](https://github.com/vega/vega-lite/issues/5190).
    | PrReflectX Bool
      -- ^ Reflect the x-coordinates after performing an identity projection. This
      --   creates a left-right mirror image of the geoshape marks when subject to an
      --   identity projection with 'Identity'.
      --
      -- @since 0.4.0.0
    | PrReflectY Bool
      -- ^ Reflect the y-coordinates after performing an identity projection. This
      --   creates a left-right mirror image of the geoshape marks when subject to an
      --   identity projection with 'Identity'.
      --
      -- @since 0.4.0.0
    | PrCoefficient Double
      -- ^ The @Hammer@ map projection coefficient.
    | PrDistance Double
      -- ^ The @Satellite@ map projection distance.
    | PrFraction Double
      -- ^ The @Bottomley@ map projection fraction.
    | PrLobes Int
      -- ^ Number of lobes in lobed map projections such as the @Berghaus star@.
    | PrParallel Double
      -- ^ Parallel for map projections such as the @Armadillo@.
    | PrRadius Double
      -- ^ Radius value for map projections such as the @Gingery@.
    | PrRatio Double
      -- ^ Ratio value for map projections such as the @Hill@.
    | PrSpacing Double
      -- ^ Spacing value for map projections such as the @Lagrange@.
    | PrTilt Double
      -- ^ @Satellite@ map projection tilt.


projectionProperty :: ProjectionProperty -> LabelledSpec
projectionProperty (PrType proj) = "type" .= projectionLabel proj
projectionProperty (PrClipAngle numOrNull) = "clipAngle" .= maybe A.Null toJSON numOrNull
projectionProperty (PrClipExtent rClip) =
  ("clipExtent", case rClip of
    NoClip -> A.Null
    LTRB l t r b -> toJSON (map toJSON [l, t, r, b])
  )
projectionProperty (PrCenter lon lat) = "center" .= [lon, lat]
projectionProperty (PrScale sc) = "scale" .= sc
projectionProperty (PrTranslate tx ty) = "translate" .= [tx, ty]
projectionProperty (PrRotate lambda phi gamma) = "rotate" .= [lambda, phi, gamma]
projectionProperty (PrPrecision pr) = "precision" .= pr  -- the 3.3.0 spec says this is a string, but that's wrong,  See https://github.com/vega/vega-lite/issues/5190
projectionProperty (PrReflectX b) = "reflectX" .= b
projectionProperty (PrReflectY b) = "reflectY" .= b
projectionProperty (PrCoefficient x) = "coefficient" .= x
projectionProperty (PrDistance x) = "distance" .= x
projectionProperty (PrFraction x) = "fraction" .= x
projectionProperty (PrLobes n) = "lobes" .= n
projectionProperty (PrParallel x) = "parallel" .= x
projectionProperty (PrRadius x) = "radius" .= x
projectionProperty (PrRatio x) = "ratio" .= x
projectionProperty (PrSpacing x) = "spacing" .= x
projectionProperty (PrTilt x) = "tilt" .= x


{-|

Sets the cartographic projection used for geospatial coordinates. A projection
defines the mapping from @(longitude,latitude)@ to an @(x,y)@ plane used for rendering.
This is useful when using the 'Graphics.Vega.VegaLite.Geoshape' mark. For further details see the
<https://vega.github.io/vega-lite/docs/projection.html Vega-Lite documentation>.

@
'projection' [ 'PrType' 'Orthographic', 'PrRotate' (-40) 0 0 ]
@
-}
projection :: [ProjectionProperty] -> PropertySpec
projection pProps = (VLProjection, object (map projectionProperty pProps))


{-|

Specifies the type and content of geometry specifications for programatically
creating GeoShapes. These can be mapped to the
<https://tools.ietf.org/html/rfc7946#section-3.1 GeoJson geometry object types>
where the pluralised type names refer to their @Multi@ prefixed equivalent in the
GeoJSON specification.
-}
data Geometry
    = GeoPoint Double Double
    -- ^ The GeoJson geometry @point@ type.
    | GeoPoints [(Double, Double)]
    -- ^ The GeoJson geometry @multi-point@ type.
    | GeoLine [(Double, Double)]
    -- ^ The GeoJson geometry @line@ type.
    | GeoLines [[(Double, Double)]]
    -- ^ The GeoJson geometry @multi-line@ type.
    | GeoPolygon [[(Double, Double)]]
    -- ^ The GeoJson geometry @polygon@ type.
    | GeoPolygons [[[(Double, Double)]]]
    -- ^ The GeoJson geometry @multi-polygon@ type.


{-|

Specifies a geometric object to be used in a geoShape specification. The first
parameter is the geometric type, the second an optional list of properties to be
associated with the object.

@
'geometry' ('GeoPolygon' [ [ ( -3, 59 ), ( 4, 59 ), ( 4, 52 ), ( -3, 59 ) ] ]) []
@
-}
geometry :: Geometry -> [(T.Text, DataValue)] -> VLSpec
geometry gType properties =
  object ([ ("type", fromT "Feature")
          , ("geometry", geometryTypeSpec gType) ]
          <> if null properties
             then []
             else [("properties",
                    object (map (second dataValueSpec) properties))]
         )


geometryTypeSpec :: Geometry -> VLSpec
geometryTypeSpec gType =
  let toCoords :: [(Double, Double)] -> VLSpec
      toCoords = toJSON -- rely on Aeson converting a pair to a 2-element list

      toCoordList :: [[(Double, Double)]] -> VLSpec
      toCoordList = toJSON . map toCoords  -- this is just toJSON isn't it?

      -- can we replace this infinite tower of toJSON calls with one toJSON call?
      (ptype, cs) = case gType of
        GeoPoint x y -> ("Point", toJSON [x, y])
        GeoPoints coords -> ("MultiPoint", toCoords coords)
        GeoLine coords -> ("LineString", toCoords coords)
        GeoLines coords -> ("MultiLineString", toCoordList coords)
        GeoPolygon coords -> ("Polygon", toCoordList coords)
        GeoPolygons ccoords -> ("MultiPolygon", toJSON (map toCoordList ccoords))

  in object [("type", ptype), ("coordinates", cs)]


{-|

Generate a data source that is a sphere for bounding global geographic data.
The sphere will be subject to whatever projection is specified for the view.

@
'Graphics.Vega.VegaLite.toVegaLite'
    [ 'sphere'
    , 'projection' [ 'PrType' 'Orthographic' ]
    , 'Graphics.Vega.VegaLite.mark' 'Graphics.Vega.VegaLite.Geoshape' [ 'Graphics.Vega.VegaLite.MFill' "aliceblue" ]
    ]
@

@since 0.4.0.0
-}
sphere :: Data
sphere = (VLData, object ["sphere" .= True])


{-|

Generate a grid of lines of longitude (meridians) and latitude
(parallels).

@
let proj = 'projection' [ 'PrType' 'Orthographic' ]
    sphereSpec = 'Graphics.Vega.VegaLite.asSpec' [ 'sphere'
                        , 'Graphics.Vega.VegaLite.mark' 'Graphics.Vega.VegaLite.Geoshape' [ 'Graphics.Vega.VegaLite.MFill' "aliceblue" ] ]
    gratSpec =
        'Graphics.Vega.VegaLite.asSpec'
            [ 'graticule' [ 'GrStep' (5, 5) ]
            , 'Graphics.Vega.VegaLite.mark' 'Graphics.Vega.VegaLite.Geoshape' [ 'Graphics.Vega.VegaLite.MFilled' False, 'Graphics.Vega.VegaLite.MStrokeWidth' 0.3 ]
            ]
in 'Graphics.Vega.VegaLite.toVegaLite' [ proj, 'Graphics.Vega.VegaLite.layer' [ sphereSpec, gratSpec ] ]
@

@since 0.4.0.0

-}
graticule ::
  [GraticuleProperty] -- ^ An empty list uses the default parameters
  -> Data
graticule [] = (VLData, object ["graticule" .= True])
graticule grProps =
  (VLData, object ["graticule" .= object (map graticuleProperty grProps)])


{-|

Determine the properties of graticules. See the
<https://vega.github.io/vega-lite/docs/data.html#graticule Vega-Lite documentation> for details.

@since 0.4.0.0

-}
data GraticuleProperty
    = GrExtent (Double, Double) (Double, Double)
    -- ^ Define the extent of both the major and minor graticules.
    --   The range is given as longitude, latitude pairs of the
    --   minimum and then maximum extent. The units are degrees.
    | GrExtentMajor (Double, Double) (Double, Double)
    -- ^ As @GrExtent@ but for the major graticule lines only.
    | GrExtentMinor (Double, Double) (Double, Double)
    -- ^ As @GrExtent@ but for the minor graticule lines only.
    | GrStep (Double, Double)
    -- ^ The step angles for the graticule lines, given as a longitude,
    --   latitude pair defining the EW and NS intervals respectively.
    --   The units are degrees.
    --
    --   By default major graticule lines extend to both poles but the
    --   minor lines stop at ±80 degrees latitude.
    | GrStepMajor (Double, Double)
    -- ^ As @GrStep@ but for the major graticule lines only.
    --
    --   The default is @(90, 360)@.
    | GrStepMinor (Double, Double)
    -- ^ As @GrStep@ but for the minor graticule lines only.
    --
    --   The default is @(10, 10)@.
    | GrPrecision Double
    -- ^ The precision of the graticule. The units are degrees.
    --   A smaller value reduces visual artifacts (steps) but takes longer
    --   to render.
    --
    --   The default is @2.5@.


graticuleProperty :: GraticuleProperty -> LabelledSpec
graticuleProperty (GrExtent (lng1, lat1) (lng2, lat2)) =
  "extent" .= [[lng1, lat1], [lng2, lat2]]
graticuleProperty (GrExtentMajor (lng1, lat1) (lng2, lat2)) =
  "extentMajor" .= [[lng1, lat1], [lng2, lat2]]
graticuleProperty (GrExtentMinor (lng1, lat1) (lng2, lat2)) =
  "extentMinor" .= [[lng1, lat1], [lng2, lat2]]
graticuleProperty (GrStep (lng, lat)) = "step" .= [lng, lat]
graticuleProperty (GrStepMajor (lng, lat)) = "stepMajor" .= [lng, lat]
graticuleProperty (GrStepMinor (lng, lat)) = "stepMinor" .= [lng, lat]
graticuleProperty (GrPrecision x) = "precision" .= x