{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Vega.VegaLite.Geometry
( geometry
, geoFeatureCollection
, geometryCollection
, Geometry(..)
, sphere
, graticule
, GraticuleProperty(..)
, projection
, ProjectionProperty(..)
, Projection(..)
, ClipRect(..)
, projectionProperty
) where
import qualified Data.Aeson as A
import qualified Data.Text as T
import Control.Arrow (second)
import Data.Aeson ((.=), object, toJSON)
import Data.Aeson.Types (Pair)
#if !(MIN_VERSION_base(4, 12, 0))
import Data.Monoid ((<>))
#endif
import Graphics.Vega.VegaLite.Data
( DataValue
, dataValueSpec
)
import Graphics.Vega.VegaLite.Foundation
( fromT
, toObject
)
import Graphics.Vega.VegaLite.Specification
( VLProperty(VLData, VLProjection)
, VLSpec
, PropertySpec
)
import Graphics.Vega.VegaLite.Input
( Data
)
type_ :: T.Text -> Pair
type_ :: Text -> Pair
type_ Text
t = Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
t
geoFeatureCollection :: [VLSpec] -> VLSpec
geoFeatureCollection :: [VLSpec] -> VLSpec
geoFeatureCollection [VLSpec]
geoms =
[Pair] -> VLSpec
object [ Text -> Pair
type_ Text
"FeatureCollection"
, Key
"features" Key -> [VLSpec] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [VLSpec]
geoms
]
geometryCollection :: [VLSpec] -> VLSpec
geometryCollection :: [VLSpec] -> VLSpec
geometryCollection [VLSpec]
geoms =
[Pair] -> VLSpec
object [ Text -> Pair
type_ Text
"GeometryCollection"
, Key
"geometries" Key -> [VLSpec] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [VLSpec]
geoms
]
data Projection
= Albers
| AlbersUsa
| AzimuthalEqualArea
| AzimuthalEquidistant
| ConicConformal
| ConicEqualArea
| ConicEquidistant
| Custom T.Text
| EqualEarth
| Equirectangular
| Gnomonic
| Identity
| Mercator
| NaturalEarth1
| Orthographic
| Stereographic
| TransverseMercator
projectionLabel :: Projection -> T.Text
projectionLabel :: Projection -> Text
projectionLabel Projection
Albers = Text
"albers"
projectionLabel Projection
AlbersUsa = Text
"albersUsa"
projectionLabel Projection
AzimuthalEqualArea = Text
"azimuthalEqualArea"
projectionLabel Projection
AzimuthalEquidistant = Text
"azimuthalEquidistant"
projectionLabel Projection
ConicConformal = Text
"conicConformal"
projectionLabel Projection
ConicEqualArea = Text
"conicEqualarea"
projectionLabel Projection
ConicEquidistant = Text
"conicEquidistant"
projectionLabel (Custom Text
pName) = Text
pName
projectionLabel Projection
EqualEarth = Text
"equalEarth"
projectionLabel Projection
Equirectangular = Text
"equirectangular"
projectionLabel Projection
Gnomonic = Text
"gnomonic"
projectionLabel Projection
Identity = Text
"identity"
projectionLabel Projection
Mercator = Text
"mercator"
projectionLabel Projection
NaturalEarth1 = Text
"naturalEarth1"
projectionLabel Projection
Orthographic = Text
"orthographic"
projectionLabel Projection
Stereographic = Text
"stereographic"
projectionLabel Projection
TransverseMercator = Text
"transverseMercator"
data ClipRect
= NoClip
| LTRB Double Double Double Double
data ProjectionProperty
= PrType Projection
| PrClipAngle (Maybe Double)
| PrClipExtent ClipRect
| PrCenter Double Double
| PrScale Double
| PrTranslate Double Double
| PrRotate Double Double Double
| PrPrecision Double
| PrReflectX Bool
| PrReflectY Bool
| PrCoefficient Double
| PrDistance Double
| PrFraction Double
| PrLobes Int
| PrParallel Double
| PrRadius Double
| PrRatio Double
| PrSpacing Double
| PrTilt Double
projectionProperty :: ProjectionProperty -> Pair
projectionProperty :: ProjectionProperty -> Pair
projectionProperty (PrType Projection
proj) = Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Projection -> Text
projectionLabel Projection
proj
projectionProperty (PrClipAngle Maybe Double
numOrNull) = Key
"clipAngle" Key -> VLSpec -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= VLSpec -> (Double -> VLSpec) -> Maybe Double -> VLSpec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe VLSpec
A.Null Double -> VLSpec
forall a. ToJSON a => a -> VLSpec
toJSON Maybe Double
numOrNull
projectionProperty (PrClipExtent ClipRect
rClip) =
(Key
"clipExtent", case ClipRect
rClip of
ClipRect
NoClip -> VLSpec
A.Null
LTRB Double
l Double
t Double
r Double
b -> [VLSpec] -> VLSpec
forall a. ToJSON a => a -> VLSpec
toJSON ((Double -> VLSpec) -> [Double] -> [VLSpec]
forall a b. (a -> b) -> [a] -> [b]
map Double -> VLSpec
forall a. ToJSON a => a -> VLSpec
toJSON [Double
l, Double
t, Double
r, Double
b])
)
projectionProperty (PrCenter Double
lon Double
lat) = Key
"center" Key -> [Double] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Double
lon, Double
lat]
projectionProperty (PrScale Double
sc) = Key
"scale" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
sc
projectionProperty (PrTranslate Double
tx Double
ty) = Key
"translate" Key -> [Double] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Double
tx, Double
ty]
projectionProperty (PrRotate Double
lambda Double
phi Double
gamma) = Key
"rotate" Key -> [Double] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Double
lambda, Double
phi, Double
gamma]
projectionProperty (PrPrecision Double
pr) = Key
"precision" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
pr
projectionProperty (PrReflectX Bool
b) = Key
"reflectX" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
b
projectionProperty (PrReflectY Bool
b) = Key
"reflectY" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
b
projectionProperty (PrCoefficient Double
x) = Key
"coefficient" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projectionProperty (PrDistance Double
x) = Key
"distance" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projectionProperty (PrFraction Double
x) = Key
"fraction" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projectionProperty (PrLobes Int
n) = Key
"lobes" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
n
projectionProperty (PrParallel Double
x) = Key
"parallel" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projectionProperty (PrRadius Double
x) = Key
"radius" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projectionProperty (PrRatio Double
x) = Key
"ratio" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projectionProperty (PrSpacing Double
x) = Key
"spacing" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projectionProperty (PrTilt Double
x) = Key
"tilt" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
projection :: [ProjectionProperty] -> PropertySpec
projection :: [ProjectionProperty] -> PropertySpec
projection [ProjectionProperty]
pProps = (VLProperty
VLProjection, [Pair] -> VLSpec
object ((ProjectionProperty -> Pair) -> [ProjectionProperty] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map ProjectionProperty -> Pair
projectionProperty [ProjectionProperty]
pProps))
data Geometry
= GeoPoint Double Double
| GeoPoints [(Double, Double)]
| GeoLine [(Double, Double)]
| GeoLines [[(Double, Double)]]
| GeoPolygon [[(Double, Double)]]
| GeoPolygons [[[(Double, Double)]]]
geometry :: Geometry -> [(T.Text, DataValue)] -> VLSpec
geometry :: Geometry -> [(Text, DataValue)] -> VLSpec
geometry Geometry
gType [(Text, DataValue)]
properties =
[Pair] -> VLSpec
object ([ (Key
"type", Text -> VLSpec
fromT Text
"Feature")
, (Key
"geometry", Geometry -> VLSpec
geometryTypeSpec Geometry
gType) ]
[Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> if [(Text, DataValue)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, DataValue)]
properties
then []
else [(Key
"properties",
[LabelledSpec] -> VLSpec
toObject (((Text, DataValue) -> LabelledSpec)
-> [(Text, DataValue)] -> [LabelledSpec]
forall a b. (a -> b) -> [a] -> [b]
map ((DataValue -> VLSpec) -> (Text, DataValue) -> LabelledSpec
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second DataValue -> VLSpec
dataValueSpec) [(Text, DataValue)]
properties))]
)
geometryTypeSpec :: Geometry -> VLSpec
geometryTypeSpec :: Geometry -> VLSpec
geometryTypeSpec Geometry
gType =
let toCoords :: [(Double, Double)] -> VLSpec
toCoords :: [(Double, Double)] -> VLSpec
toCoords = [(Double, Double)] -> VLSpec
forall a. ToJSON a => a -> VLSpec
toJSON
toCoordList :: [[(Double, Double)]] -> VLSpec
toCoordList :: [[(Double, Double)]] -> VLSpec
toCoordList = [VLSpec] -> VLSpec
forall a. ToJSON a => a -> VLSpec
toJSON ([VLSpec] -> VLSpec)
-> ([[(Double, Double)]] -> [VLSpec])
-> [[(Double, Double)]]
-> VLSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Double, Double)] -> VLSpec) -> [[(Double, Double)]] -> [VLSpec]
forall a b. (a -> b) -> [a] -> [b]
map [(Double, Double)] -> VLSpec
toCoords
(VLSpec
ptype, VLSpec
cs) = case Geometry
gType of
GeoPoint Double
x Double
y -> (VLSpec
"Point", [Double] -> VLSpec
forall a. ToJSON a => a -> VLSpec
toJSON [Double
x, Double
y])
GeoPoints [(Double, Double)]
coords -> (VLSpec
"MultiPoint", [(Double, Double)] -> VLSpec
toCoords [(Double, Double)]
coords)
GeoLine [(Double, Double)]
coords -> (VLSpec
"LineString", [(Double, Double)] -> VLSpec
toCoords [(Double, Double)]
coords)
GeoLines [[(Double, Double)]]
coords -> (VLSpec
"MultiLineString", [[(Double, Double)]] -> VLSpec
toCoordList [[(Double, Double)]]
coords)
GeoPolygon [[(Double, Double)]]
coords -> (VLSpec
"Polygon", [[(Double, Double)]] -> VLSpec
toCoordList [[(Double, Double)]]
coords)
GeoPolygons [[[(Double, Double)]]]
ccoords -> (VLSpec
"MultiPolygon", [VLSpec] -> VLSpec
forall a. ToJSON a => a -> VLSpec
toJSON (([[(Double, Double)]] -> VLSpec)
-> [[[(Double, Double)]]] -> [VLSpec]
forall a b. (a -> b) -> [a] -> [b]
map [[(Double, Double)]] -> VLSpec
toCoordList [[[(Double, Double)]]]
ccoords))
in [Pair] -> VLSpec
object [(Key
"type", VLSpec
ptype), (Key
"coordinates", VLSpec
cs)]
sphere :: Data
sphere :: PropertySpec
sphere = (VLProperty
VLData, [Pair] -> VLSpec
object [Key
"sphere" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
True])
graticule ::
[GraticuleProperty]
-> Data
graticule :: [GraticuleProperty] -> PropertySpec
graticule [] = (VLProperty
VLData, [Pair] -> VLSpec
object [Key
"graticule" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
True])
graticule [GraticuleProperty]
grProps =
(VLProperty
VLData, [Pair] -> VLSpec
object [Key
"graticule" Key -> VLSpec -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> VLSpec
object ((GraticuleProperty -> Pair) -> [GraticuleProperty] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map GraticuleProperty -> Pair
graticuleProperty [GraticuleProperty]
grProps)])
data GraticuleProperty
= GrExtent (Double, Double) (Double, Double)
| GrExtentMajor (Double, Double) (Double, Double)
| GrExtentMinor (Double, Double) (Double, Double)
| GrStep (Double, Double)
| GrStepMajor (Double, Double)
| GrStepMinor (Double, Double)
| GrPrecision Double
graticuleProperty :: GraticuleProperty -> Pair
graticuleProperty :: GraticuleProperty -> Pair
graticuleProperty (GrExtent (Double
lng1, Double
lat1) (Double
lng2, Double
lat2)) =
Key
"extent" Key -> [[Double]] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [[Double
lng1, Double
lat1], [Double
lng2, Double
lat2]]
graticuleProperty (GrExtentMajor (Double
lng1, Double
lat1) (Double
lng2, Double
lat2)) =
Key
"extentMajor" Key -> [[Double]] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [[Double
lng1, Double
lat1], [Double
lng2, Double
lat2]]
graticuleProperty (GrExtentMinor (Double
lng1, Double
lat1) (Double
lng2, Double
lat2)) =
Key
"extentMinor" Key -> [[Double]] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [[Double
lng1, Double
lat1], [Double
lng2, Double
lat2]]
graticuleProperty (GrStep (Double
lng, Double
lat)) = Key
"step" Key -> [Double] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Double
lng, Double
lat]
graticuleProperty (GrStepMajor (Double
lng, Double
lat)) = Key
"stepMajor" Key -> [Double] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Double
lng, Double
lat]
graticuleProperty (GrStepMinor (Double
lng, Double
lat)) = Key
"stepMinor" Key -> [Double] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Double
lng, Double
lat]
graticuleProperty (GrPrecision Double
x) = Key
"precision" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x