{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Geography.VectorTile.Internal
(
Protobuf
, Protobuffable(..)
, ProtobufGeom(..)
, Tile.Tile(Tile, layers)
, Layer.Layer(Layer, version, name, features, keys, values, extent)
, Feature.Feature(..)
, Value.Value(..)
, GeomType.GeomType(..)
, Command(..)
, commands
, uncommands
, zig
, unzig
, feats
, unfeats
) where
import Control.Applicative ((<|>))
import Control.Monad.Except
import Control.Monad.State.Strict
import Data.Bits
import qualified Data.ByteString.Lazy as BL
import Data.Foldable (fold, foldlM, toList)
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as HS
import Data.Int
import Data.List (unfoldr)
import Data.Maybe (fromJust)
import Data.Sequence (Seq, (<|), (|>))
import qualified Data.Sequence as Seq
import Data.Text (Text, pack)
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Data.Word
import qualified Geography.VectorTile.Geometry as G
import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile as Tile
import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Feature as Feature
import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType as GeomType
import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Layer as Layer
import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Value as Value
import Geography.VectorTile.Util
import qualified Geography.VectorTile.VectorTile as VT
import Text.Printf
import Text.ProtocolBuffers.Basic (Utf8(..), defaultValue, utf8)
type family Protobuf a = pb | pb -> a
type instance Protobuf VT.VectorTile = Tile.Tile
type instance Protobuf VT.Layer = Layer.Layer
type instance Protobuf VT.Val = Value.Value
type family GeomVec g = v | v -> g
type instance GeomVec G.Point = VS.Vector G.Point
type instance GeomVec G.LineString = V.Vector G.LineString
type instance GeomVec G.Polygon = V.Vector G.Polygon
class Protobuffable a where
fromProtobuf :: Protobuf a -> Either Text a
toProtobuf :: a -> Protobuf a
instance Protobuffable VT.VectorTile where
fromProtobuf raw = do
ls <- traverse fromProtobuf . toList $ Tile.layers raw
pure . VT.VectorTile . M.fromList $ map (\l -> (VT._name l, l)) ls
toProtobuf vt = Tile.Tile { Tile.layers = Seq.fromList . map toProtobuf . M.elems $ VT._layers vt
, Tile.ext'field = defaultValue }
instance Protobuffable VT.Layer where
fromProtobuf l = do
Feats ps ls polys <- feats (utf8 <$> Layer.keys l) (Layer.values l) $ Layer.features l
pure VT.Layer { VT._version = fromIntegral $ Layer.version l
, VT._name = utf8 $ Layer.name l
, VT._points = V.fromList $ toList ps
, VT._linestrings = V.fromList $ toList ls
, VT._polygons = V.fromList $ toList polys
, VT._extent = maybe 4096 fromIntegral (Layer.extent l) }
toProtobuf l = Layer.Layer { Layer.version = fromIntegral $ VT._version l
, Layer.name = Utf8 $ VT._name l
, Layer.features = Seq.fromList $ V.toList fs
, Layer.keys = Seq.fromList $ map Utf8 ks
, Layer.values = Seq.fromList $ map toProtobuf vs
, Layer.extent = Just . fromIntegral $ VT._extent l
, Layer.ext'field = defaultValue }
where (ks,vs) = totalMeta (VT._points l) (VT._linestrings l) (VT._polygons l)
(km,vm) = (M.fromList $ zip ks [0..], M.fromList $ zip vs [0..])
fs = fold [ fmap (unfeats km vm GeomType.POINT) (VT._points l)
, fmap (unfeats km vm GeomType.LINESTRING) (VT._linestrings l)
, fmap (unfeats km vm GeomType.POLYGON) (VT._polygons l) ]
instance Protobuffable VT.Val where
fromProtobuf v = maybe (Left "Value decode: No legal Value type offered") Right $
fmap (VT.St . utf8) (Value.string_value v)
<|> fmap VT.Fl (Value.float_value v)
<|> fmap VT.Do (Value.double_value v)
<|> fmap VT.I64 (Value.int_value v)
<|> fmap VT.W64 (Value.uint_value v)
<|> fmap VT.S64 (Value.sint_value v)
<|> fmap VT.B (Value.bool_value v)
toProtobuf (VT.St v) = defaultValue { Value.string_value = Just $ Utf8 v }
toProtobuf (VT.Fl v) = defaultValue { Value.float_value = Just v }
toProtobuf (VT.Do v) = defaultValue { Value.double_value = Just v }
toProtobuf (VT.I64 v) = defaultValue { Value.int_value = Just v }
toProtobuf (VT.W64 v) = defaultValue { Value.uint_value = Just v }
toProtobuf (VT.S64 v) = defaultValue { Value.sint_value = Just v }
toProtobuf (VT.B v) = defaultValue { Value.bool_value = Just v }
class ProtobufGeom g where
fromCommands :: [Command] -> Either Text (GeomVec g)
toCommands :: GeomVec g -> [Command]
instance ProtobufGeom G.Point where
fromCommands [ MoveTo ps ] = Right $ expand (G.Point 0 0) ps
fromCommands (c : _) = Left . pack $ printf "Invalid command found in Point feature: %s" (show c)
fromCommands [] = Left "No points given!"
toCommands ps = [ MoveTo $ evalState (VS.mapM collapse ps) (G.Point 0 0) ]
instance ProtobufGeom G.LineString where
fromCommands cs = evalStateT (V.unfoldrM f cs) (G.Point 0 0)
where f :: [Command] -> StateT G.Point (Either Text) (Maybe (G.LineString, [Command]))
f (MoveTo p : LineTo ps : rs) = do
curr <- get
let ls = G.LineString . expand curr $ VS.head p `VS.cons` ps
put . VS.last $ G.lsPoints ls
pure $ Just (ls, rs)
f [] = pure Nothing
f _ = throwError "LineString decode: Invalid command sequence given."
toCommands ls = fold $ evalState (traverse f ls) (G.Point 0 0)
where f (G.LineString ps) = do
l <- VS.mapM collapse ps
pure [ MoveTo (VS.singleton $ VS.head l), LineTo (VS.tail l) ]
instance ProtobufGeom G.Polygon where
fromCommands cs = do
polys <- evalStateT (V.unfoldrM f cs) (G.Point 0 0)
pure $ V.unfoldr g polys
where f :: [Command] -> StateT G.Point (Either Text) (Maybe (G.Polygon, [Command]))
f (MoveTo p : LineTo ps : ClosePath : rs) = do
curr <- get
let ps' = expand curr $ VS.head p `VS.cons` ps
put $ VS.last ps'
pure $ Just (G.Polygon (VS.snoc ps' $ VS.head ps') mempty, rs)
f [] = pure Nothing
f _ = throwError . pack $ printf "Polygon decode: Invalid command sequence given: %s" (show cs)
g :: V.Vector G.Polygon -> Maybe (G.Polygon, V.Vector G.Polygon)
g v | V.null v = Nothing
| otherwise = Just (p, v')
where p = (V.head v) { G.inner = is }
(is,v') = V.break (\i -> G.area i > 0) $ V.tail v
toCommands ps = fold $ evalState (traverse f ps) (G.Point 0 0)
where f :: G.Polygon -> State G.Point [Command]
f (G.Polygon p i) = do
l <- VS.mapM collapse $ VS.init p
let cs = [ MoveTo (VS.singleton $ VS.head l), LineTo (VS.tail l), ClosePath ]
fold . (cs :) <$> traverse f (V.toList i)
data Command = MoveTo (VS.Vector G.Point)
| LineTo (VS.Vector G.Point)
| ClosePath deriving (Eq,Show)
zig :: Int -> Word32
zig n = fromIntegral $ shift n 1 `xor` shift n (-63)
{-# INLINE zig #-}
unzig :: Word32 -> Int
unzig n = fromIntegral (fromIntegral unzigged :: Int32)
where unzigged = shift n (-1) `xor` negate (n .&. 1)
{-# INLINE unzig #-}
unsafeParseCmd :: Word32 -> Pair
unsafeParseCmd n = case cmd of
1 -> Pair 1 (fromIntegral count)
2 -> Pair 2 (fromIntegral count)
7 | count == 1 -> Pair 7 1
| otherwise -> error $ "ClosePath was given a parameter count: " <> show count
m -> error $ printf "Invalid command integer %d found in: %X" m n
where cmd = n .&. 7
count = shift n (-3)
unparseCmd :: Pair -> Word32
unparseCmd (Pair cmd count) = fromIntegral $ (cmd .&. 7) .|. shift count 3
{-# INLINE unparseCmd #-}
commands :: [Word32] -> [Command]
commands = unfoldr go
where go [] = Nothing
go (n : ns) = case unsafeParseCmd n of
Pair 1 count ->
let (ls, rs) = splitAt (count * 2) ns
mts = MoveTo $ pairsWith unzig ls
in Just (mts, rs)
Pair 2 count ->
let (ls, rs) = splitAt (count * 2) ns
mts = LineTo $ pairsWith unzig ls
in Just (mts, rs)
Pair 7 _ -> Just (ClosePath, ns)
_ -> error "Sentinel: You should never see this."
uncommands :: [Command] -> Seq Word32
uncommands = Seq.fromList >=> f
where f (MoveTo ps) = unparseCmd (Pair 1 (VS.length ps)) <| params ps
f (LineTo ls) = unparseCmd (Pair 2 (VS.length ls)) <| params ls
f ClosePath = Seq.singleton $ unparseCmd (Pair 7 1)
feats :: Seq BL.ByteString -> Seq Value.Value -> Seq Feature.Feature -> Either Text Feats
feats _ _ Seq.Empty = Left "VectorTile.features: `[RawFeature]` empty"
feats keys vals fs = foldlM g (Feats mempty mempty mempty) fs
where f :: ProtobufGeom g => Feature.Feature -> Either Text (VT.Feature (GeomVec g))
f x = VT.Feature
<$> pure (maybe 0 fromIntegral $ Feature.id x)
<*> getMeta keys vals (Feature.tags x)
<*> (fromCommands . commands . toList $ Feature.geometry x)
g feets@(Feats ps ls po) fe = case Feature.type' fe of
Just GeomType.POINT -> (\fe' -> feets { featPoints = ps |> fe' }) <$> f fe
Just GeomType.LINESTRING -> (\fe' -> feets { featLines = ls |> fe' }) <$> f fe
Just GeomType.POLYGON -> (\fe' -> feets { featPolys = po |> fe' }) <$> f fe
_ -> Left "Geometry type of UNKNOWN given."
data Feats = Feats { featPoints :: !(Seq (VT.Feature (GeomVec G.Point)))
, featLines :: !(Seq (VT.Feature (GeomVec G.LineString)))
, featPolys :: !(Seq (VT.Feature (GeomVec G.Polygon))) }
getMeta :: Seq BL.ByteString -> Seq Value.Value -> Seq Word32 -> Either Text (M.HashMap BL.ByteString VT.Val)
getMeta keys vals tags = do
let kv = pairsWith fromIntegral (toList tags)
VS.foldM' (\acc (G.Point k v) -> (\v' -> M.insert (keys `Seq.index` k) v' acc) <$> fromProtobuf (vals `Seq.index` v)) M.empty kv
totalMeta :: V.Vector (VT.Feature (GeomVec G.Point))
-> V.Vector (VT.Feature (GeomVec G.LineString))
-> V.Vector (VT.Feature (GeomVec G.Polygon))
-> ([BL.ByteString], [VT.Val])
totalMeta ps ls polys = (keys, vals)
where keys = HS.toList $ f ps <> f ls <> f polys
vals = HS.toList $ g ps <> g ls <> g polys
f = foldMap (HS.fromMap . void . VT._metadata)
g = foldMap (HS.fromList . M.elems . VT._metadata)
unfeats :: ProtobufGeom g
=> M.HashMap BL.ByteString Int
-> M.HashMap VT.Val Int
-> GeomType.GeomType
-> VT.Feature (GeomVec g)
-> Feature.Feature
unfeats keys vals gt fe = Feature.Feature
{ Feature.id = Just . fromIntegral $ VT._featureId fe
, Feature.tags = Seq.fromList $ tags fe
, Feature.type' = Just gt
, Feature.geometry = uncommands . toCommands $ VT._geometries fe }
where tags = unpairs . map f . M.toList . VT._metadata
f (k,v) = (fromIntegral . fromJust $ M.lookup k keys, fromIntegral . fromJust $ M.lookup v vals)
params :: VS.Vector G.Point -> Seq Word32
params = VS.foldl' (\acc (G.Point a b) -> acc |> zig a |> zig b) Seq.Empty
expand :: G.Point -> VS.Vector G.Point -> VS.Vector G.Point
expand = VS.postscanl' (<>)
collapse :: G.Point -> State G.Point G.Point
collapse p = do
curr <- get
let diff = G.Point (G.x p - G.x curr) (G.y p - G.y curr)
put p
pure diff