module Geography.VectorTile
(
VectorTile(..)
, Layer(..)
, Feature(..)
, Val(..)
, tile
, layer
, features
, value
, untile
, unlayer
, unfeature
, unval
, layers
, version
, name
, points
, linestrings
, polygons
, extent
, featureId
, metadata
, geometries
) where
import Control.Applicative ((<|>))
import Control.DeepSeq (NFData)
import Data.Foldable (foldrM)
import Data.Int
import Data.List (nub, elemIndex)
import qualified Data.Map.Lazy as M
import Data.Maybe (fromJust)
import Data.Monoid
import Data.ProtocolBuffers
import qualified Data.Set as S
import Data.Text (Text,pack)
import qualified Data.Vector as V
import Data.Word
import GHC.Generics (Generic)
import Geography.VectorTile.Geometry
import qualified Geography.VectorTile.Raw as R
import Geography.VectorTile.Util
newtype VectorTile = VectorTile { _layers :: V.Vector Layer } deriving (Eq,Show,Generic)
layers :: Functor f => (V.Vector Layer -> f (V.Vector Layer)) -> VectorTile -> f VectorTile
layers f v = VectorTile <$> f (_layers v)
instance NFData VectorTile
data Layer = Layer { _version :: Int
, _name :: Text
, _points :: V.Vector (Feature Point)
, _linestrings :: V.Vector (Feature LineString)
, _polygons :: V.Vector (Feature Polygon)
, _extent :: Int
} deriving (Eq,Show,Generic)
version :: Functor f => (Layer -> f Int) -> Layer -> f Layer
version f l = fmap (\v -> l { _version = v }) $ f l
name :: Functor f => (Layer -> f Text) -> Layer -> f Layer
name f l = fmap (\v -> l { _name = v }) $ f l
points :: Functor f => (Layer -> f (V.Vector (Feature Point))) -> Layer -> f Layer
points f l = fmap (\v -> l { _points = v }) $ f l
linestrings :: Functor f => (Layer -> f (V.Vector (Feature LineString))) -> Layer -> f Layer
linestrings f l = fmap (\v -> l { _linestrings = v }) $ f l
polygons :: Functor f => (Layer -> f (V.Vector (Feature Polygon))) -> Layer -> f Layer
polygons f l = fmap (\v -> l { _polygons = v }) $ f l
extent :: Functor f => (Layer -> f Int) -> Layer -> f Layer
extent f l = fmap (\v -> l { _extent = v }) $ f l
instance NFData Layer
data Feature g = Feature { _featureId :: Int
, _metadata :: M.Map Text Val
, _geometries :: V.Vector g } deriving (Eq,Show,Generic)
featureId :: Functor f => (Feature g -> f Int) -> Feature g -> f (Feature g)
featureId f l = fmap (\v -> l { _featureId = v }) $ f l
metadata :: Functor f => (Feature g -> f (M.Map Text Val)) -> Feature g -> f (Feature g)
metadata f l = fmap (\v -> l { _metadata = v }) $ f l
geometries :: Functor f => (Feature g -> f (V.Vector g)) -> Feature g -> f (Feature g)
geometries f l = fmap (\v -> l { _geometries = v }) $ f l
instance NFData g => NFData (Feature g)
data Val = St Text | Fl Float | Do Double | I64 Int64 | W64 Word64 | S64 Int64 | B Bool
deriving (Eq,Show,Generic)
instance NFData Val
tile :: R.RawVectorTile -> Either Text VectorTile
tile = fmap (VectorTile . V.fromList) . mapM layer . getField . R.layers
layer :: R.RawLayer -> Either Text Layer
layer l = do
(ps,ls,polys) <- features keys vals . getField $ R.features l
pure Layer { _version = fromIntegral . getField $ R.version l
, _name = getField $ R.name l
, _points = ps
, _linestrings = ls
, _polygons = polys
, _extent = maybe 4096 fromIntegral (getField $ R.extent l) }
where keys = getField $ R.keys l
vals = getField $ R.values l
features :: [Text] -> [R.RawVal] -> [R.RawFeature]
-> Either Text (V.Vector (Feature Point), V.Vector (Feature LineString), V.Vector (Feature Polygon))
features _ _ [] = Left "VectorTile.features: `[R.RawFeature]` empty"
features keys vals fs = (,,) <$> ps <*> ls <*> polys
where
ps = foldrM f V.empty $ filter (\fe -> getField (R.geom fe) == Just R.Point) fs
ls = foldrM f V.empty $ filter (\fe -> getField (R.geom fe) == Just R.LineString) fs
polys = foldrM f V.empty $ filter (\fe -> getField (R.geom fe) == Just R.Polygon) fs
f :: Geometry g => R.RawFeature -> V.Vector (Feature g) -> Either Text (V.Vector (Feature g))
f x acc = do
geos <- commands (getField $ R.geometries x) >>= fromCommands
meta <- getMeta keys vals . getField $ R.tags x
pure $ Feature { _featureId = maybe 0 fromIntegral . getField $ R.featureId x
, _metadata = meta
, _geometries = geos
} `V.cons` acc
value :: R.RawVal -> Either Text Val
value v = mtoe "Value decode: No legal Value type offered" $ fmap St (getField $ R.string v)
<|> fmap Fl (getField $ R.float v)
<|> fmap Do (getField $ R.double v)
<|> fmap I64 (getField $ R.int64 v)
<|> fmap W64 (getField $ R.uint64 v)
<|> fmap (\(Signed n) -> S64 n) (getField $ R.sint v)
<|> fmap B (getField $ R.bool v)
getMeta :: [Text] -> [R.RawVal] -> [Word32] -> Either Text (M.Map Text Val)
getMeta keys vals tags = do
kv <- map (both fromIntegral) <$> pairs tags
foldrM (\(k,v) acc -> (\v' -> M.insert (keys !! k) v' acc) <$> (value $ vals !! v)) M.empty kv
untile :: VectorTile -> R.RawVectorTile
untile vt = R.RawVectorTile { R.layers = putField . V.toList . V.map unlayer $ _layers vt }
unlayer :: Layer -> R.RawLayer
unlayer l = R.RawLayer { R.version = putField . fromIntegral $ _version l
, R.name = putField $ _name l
, R.features = putField fs
, R.keys = putField ks
, R.values = putField $ map unval vs
, R.extent = putField . Just . fromIntegral $ _extent l }
where (ks,vs) = totalMeta (_points l) (_linestrings l) (_polygons l)
fs = V.toList $ V.concat [ V.map (unfeature ks vs) (_points l)
, V.map (unfeature ks vs) (_linestrings l)
, V.map (unfeature ks vs) (_polygons l) ]
totalMeta :: V.Vector (Feature Point) -> V.Vector (Feature LineString) -> V.Vector (Feature Polygon) -> ([Text], [Val])
totalMeta ps ls polys = (keys, vals)
where keys = S.toList . S.unions $ f ps <> f ls <> f polys
vals = nub . concat $ g ps <> g ls <> g polys
f = V.foldr (\x acc -> M.keysSet (_metadata x) : acc) []
g = V.foldr (\x acc -> M.elems (_metadata x) : acc) []
unfeature :: R.Geom g => [Text] -> [Val] -> Feature g -> R.RawFeature
unfeature keys vals fe = R.RawFeature
{ R.featureId = putField . Just . fromIntegral $ _featureId fe
, R.tags = putField $ tags fe
, R.geom = putField . Just . R.geomType . V.head $ _geometries fe
, R.geometries = putField . uncommands . toCommands $ _geometries fe
}
where tags = unpairs . map f . M.toList . _metadata
f (k,v) = both (fromIntegral . fromJust) (k `elemIndex` keys, v `elemIndex` vals)
unval :: Val -> R.RawVal
unval (St v) = def { R.string = putField $ Just v }
unval (Fl v) = def { R.float = putField $ Just v }
unval (Do v) = def { R.double = putField $ Just v }
unval (I64 v) = def { R.int64 = putField $ Just v }
unval (W64 v) = def { R.uint64 = putField $ Just v }
unval (S64 v) = def { R.sint = putField . Just $ Signed v }
unval (B v) = def { R.bool = putField $ Just v }
def :: R.RawVal
def = R.RawVal { R.string = putField Nothing
, R.float = putField Nothing
, R.double = putField Nothing
, R.int64 = putField Nothing
, R.uint64 = putField Nothing
, R.sint = putField Nothing
, R.bool = putField Nothing }