vectortiles 1.2.0.4 → 1.2.0.5
raw patch · 14 files changed
+881/−883 lines, 14 filesdep ~cerealdep ~criteriondep ~protobufPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: cereal, criterion, protobuf, text, vector
API changes (from Hackage documentation)
Files
- Geography/VectorTile.hs +0/−68
- Geography/VectorTile/Geometry.hs +0/−74
- Geography/VectorTile/Protobuf.hs +0/−59
- Geography/VectorTile/Protobuf/Internal.hs +0/−410
- Geography/VectorTile/Util.hs +0/−36
- Geography/VectorTile/VectorTile.hs +0/−142
- README.md +0/−1
- lib/Geography/VectorTile.hs +68/−0
- lib/Geography/VectorTile/Geometry.hs +74/−0
- lib/Geography/VectorTile/Protobuf.hs +59/−0
- lib/Geography/VectorTile/Protobuf/Internal.hs +410/−0
- lib/Geography/VectorTile/Util.hs +36/−0
- lib/Geography/VectorTile/VectorTile.hs +142/−0
- vectortiles.cabal +92/−93
− Geography/VectorTile.hs
@@ -1,68 +0,0 @@--- |--- Module : Geography.VectorTile--- Copyright : (c) Azavea, 2016--- License : Apache 2--- Maintainer: Colin Woodbury <cwoodbury@azavea.com>------ GIS Vector Tiles, as defined by Mapbox.------ This library implements version 2.1 of the official Mapbox spec, as defined--- here: https://github.com/mapbox/vector-tile-spec/tree/master/2.1------ Note that currently this library ignores top-level protobuf extensions,--- /Value/ extensions, and /UNKNOWN/ geometries.------ The order in which to explore the modules of this library is as follows:------ 1. "Geography.VectorTile.VectorTile"--- 2. "Geography.VectorTile.Geometry"--- 3. "Geography.VectorTile.Protobuf"------ == Usage------ This library reads and writes strict `ByteString`s. By importing this module,--- you use the default protobuf backend. Given some legal--- VectorTile file called @roads.mvt@:------ > import qualified Data.ByteString as BS--- > import Data.Text (Text)--- > import Geography.VectorTile--- >--- > -- | Read in raw protobuf data and decode it into a high-level type.--- > roads :: IO (Either Text VectorTile)--- > roads = do--- > mvt <- BS.readFile "roads.mvt"--- > pure $ decode mvt >>= tile------ Or encode a `VectorTile` back into a `ByteString`:------ > roadsBytes :: VectorTile -> BS.ByteString--- > roadsBytes = encode . untile---module Geography.VectorTile- ( -- * High-level Types- -- | This module also provides lenses for data field access,- -- as `VectorTile`s are highly nested objects.- module Geography.VectorTile.VectorTile- , -- * Protobuf Backend- -- ** Conversions- tile- , untile- -- ** ByteString Encoding / Decoding- , decode- , encode- ) where--import Data.Text (Text)-import qualified Geography.VectorTile.Protobuf.Internal as PB-import Geography.VectorTile.Protobuf (decode, encode)-import Geography.VectorTile.VectorTile-------tile :: PB.RawVectorTile -> Either Text VectorTile-tile = PB.fromProtobuf--untile :: VectorTile -> PB.RawVectorTile-untile = PB.toProtobuf
− Geography/VectorTile/Geometry.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE DeriveGeneric #-}---- |--- Module : Geography.VectorTile.Geometry--- Copyright : (c) Azavea, 2016--- License : Apache 2--- Maintainer: Colin Woodbury <cwoodbury@azavea.com>--module Geography.VectorTile.Geometry- ( -- * Geometries- -- ** Types- Point, x, y- , LineString(..)- , Polygon(..)- -- ** Operations- , area- , surveyor- , distance- ) where--import Control.DeepSeq (NFData)-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import GHC.Generics (Generic)--------- | Points in space. Using "Record Pattern Synonyms" here allows us to treat--- `Point` like a normal ADT, while its implementation remains an unboxed--- @(Int,Int)@.-type Point = (Int,Int)-pattern Point :: Int -> Int -> (Int, Int)-pattern Point{x, y} = (x, y)---- | /newtype/ compiles away to expose only the `U.Vector` of unboxed `Point`s--- at runtime.-newtype LineString = LineString { lsPoints :: U.Vector Point } deriving (Eq,Show,Generic)--instance NFData LineString---- | A polygon aware of its interior rings.-data Polygon = Polygon { polyPoints :: U.Vector Point- , inner :: V.Vector Polygon } deriving (Eq,Show,Generic)--instance NFData Polygon--{---- | Very performant for the same reason as `LineString`.-newtype Polygon = Polygon { points :: U.Vector Point } deriving (Eq,Show)--}---- | The area of a `Polygon` is the difference between the areas of its--- outer ring and inner rings.-area :: Polygon -> Float-area p = surveyor (polyPoints p) + sum (V.map area $ inner p)---- | The surveyor's formula for calculating the area of a `Polygon`.--- If the value reported here is negative, then the `Polygon` should be--- considered an Interior Ring.------ Assumption: The `U.Vector` given has at least 4 `Point`s.-surveyor :: U.Vector Point -> Float-surveyor v = (/ 2) . fromIntegral . U.sum $ U.zipWith3 (\xn yn yp -> xn * (yn - yp)) xs yns yps- where v' = U.init v- xs = U.map x v'- yns = U.map y . U.tail $ U.snoc v' (U.head v')- yps = U.map y . U.init $ U.cons (U.last v') v'---- | Euclidean distance.-distance :: Point -> Point -> Float-distance p1 p2 = sqrt . fromIntegral $ dx ^ 2 + dy ^ 2- where dx = x p1 - x p2- dy = y p1 - y p2
− Geography/VectorTile/Protobuf.hs
@@ -1,59 +0,0 @@--- |--- Module : Geography.VectorTile.Protobuf--- Copyright : (c) Azavea, 2016--- License : Apache 2--- Maintainer: Colin Woodbury <cwoodbury@azavea.com>------ Most of the details of Protobuf conversion are kept in--- "Geometry.VectorTile.Protobuf.Internal", a module which is not intended--- to be imported.------ A user's main concern here should be the `Protobuffable` class, and its--- `VectorTile` instance. With it, one can do the following:------ > import Geography.VectorTile.Protobuf--- >--- > decode bytes >>= fromProtobuf -- Either Text VectorTile------ which in fact is sugared in the top-level module of this library as:------ > decode bytes >>= tile--module Geography.VectorTile.Protobuf- ( -- * Types- Protobuffable(..)- -- * ByteString Encoding / Decoding- , decode- , encode- , decodeIO- , encodeIO- ) where--import qualified Data.ByteString as BS-import Data.ProtocolBuffers hiding (decode, encode)-import Data.Serialize.Get-import Data.Serialize.Put-import Data.Text (Text, pack)-import Geography.VectorTile.Protobuf.Internal--------- | Attempt to decode a `BS.ByteString` of raw protobuf data into a mid-level--- representation of a `RawVectorTile`.-decode :: BS.ByteString -> Either Text RawVectorTile-decode bs = case runGet decodeMessage bs of- Left e -> Left $ pack e- Right vt -> Right vt---- | Encode a mid-level representation of a `RawVectorTile` into raw protobuf data.-encode :: RawVectorTile -> BS.ByteString-encode = runPut . encodeMessage---- | Given a filename, attempt to decode bytes read from that file.-decodeIO :: FilePath -> IO (Either Text RawVectorTile)-decodeIO = fmap decode . BS.readFile---- | Write a mid-level representation of a `RawVectorTile` to a file as raw--- protobuf data.-encodeIO :: RawVectorTile -> FilePath -> IO ()-encodeIO vt fp = BS.writeFile fp $ encode vt
− Geography/VectorTile/Protobuf/Internal.hs
@@ -1,410 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilyDependencies #-}---- |--- Module : Geography.VectorTile.Protobuf.Internal--- Copyright : (c) Azavea, 2016 - 2017--- License : Apache 2--- Maintainer: Colin Woodbury <cwoodbury@azavea.com>------ Raw Vector Tile data is stored as binary protobuf data.--- This module reads and writes raw protobuf ByteStrings between a data type--- which closely matches the current Mapbox vector tile spec defined here:--- https://github.com/mapbox/vector-tile-spec/blob/master/2.1/vector_tile.proto------ As this raw version of the data is hard to work with, in practice we convert--- to a more canonical Haskell type for further processing.--- See "Geography.VectorTile.VectorTile" for the user-friendly version.------ Please import this module @qualified@ to avoid namespace clashes:------ > import qualified Geography.VectorTile.Protobuf.Internal as PB--module Geography.VectorTile.Protobuf.Internal- ( -- * Types- Protobuf(..)- , Protobuffable(..)- , ProtobufGeom(..)- , RawVectorTile(..)- , RawLayer(..)- , RawVal(..)- , RawFeature(..)- , GeomType(..)- -- * Commands- , Command(..)- , commands- , uncommands- -- * Z-Encoding- , zig- , unzig- -- * Protobuf Conversions- -- | Due to Protobuf Layers and Features having their data coupled,- -- we can't define a `Protobuffable` instance for `VT.Feature`s,- -- and instead must use the two functions below.- , features- , unfeature- ) where--import Control.Applicative ((<|>))-import Control.DeepSeq (NFData)-import Control.Monad.Trans.State.Lazy-import Data.Bits-import Data.Foldable (foldrM, foldlM)-import Data.Int-import Data.List (nub)-import qualified Data.Map.Lazy as M-import Data.Maybe (fromJust)-import Data.Monoid-import Data.ProtocolBuffers hiding (decode, encode)-import qualified Data.Set as S-import Data.Text (Text, pack)-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import Data.Word-import GHC.Generics (Generic)-import qualified Geography.VectorTile.Geometry as G-import Geography.VectorTile.Util-import qualified Geography.VectorTile.VectorTile as VT-import Text.Printf--------- | A family of data types which can associated with concrete underlying--- Protobuf types.-type family Protobuf a = pb | pb -> a-type instance Protobuf VT.VectorTile = RawVectorTile-type instance Protobuf VT.Layer = RawLayer-type instance Protobuf VT.Val = RawVal---- | A type which can be converted to and from an underlying Protobuf type,--- according to the `Protobuf` type family.-class Protobuffable a where- fromProtobuf :: Protobuf a -> Either Text a- toProtobuf :: a -> Protobuf a--instance Protobuffable VT.VectorTile where- fromProtobuf raw = do- ls <- mapM fromProtobuf . getField $ _layers raw- pure . VT.VectorTile . M.fromList $ map (\l -> (VT._name l, l)) ls-- toProtobuf vt = RawVectorTile { _layers = putField . map toProtobuf . M.elems $ VT._layers vt }--instance Protobuffable VT.Layer where- fromProtobuf l = do- (ps,ls,polys) <- features keys vals . getField $ _features l- pure VT.Layer { VT._version = fromIntegral . getField $ _version l- , VT._name = getField $ _name l- , VT._points = ps- , VT._linestrings = ls- , VT._polygons = polys- , VT._extent = maybe 4096 fromIntegral (getField $ _extent l) }- where keys = getField $ _keys l- vals = getField $ _values l-- toProtobuf l = RawLayer { _version = putField . fromIntegral $ VT._version l- , _name = putField $ VT._name l- , _features = putField fs- , _keys = putField ks- , _values = putField $ map toProtobuf vs- , _extent = putField . Just . fromIntegral $ VT._extent l }- 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 = V.toList $ V.concat [ V.map (unfeature km vm Point) (VT._points l)- , V.map (unfeature km vm LineString) (VT._linestrings l)- , V.map (unfeature km vm Polygon) (VT._polygons l) ]--instance Protobuffable VT.Val where- fromProtobuf v = mtoe "Value decode: No legal Value type offered" $ fmap VT.St (getField $ _string v)- <|> fmap VT.Fl (getField $ _float v)- <|> fmap VT.Do (getField $ _double v)- <|> fmap VT.I64 (getField $ _int64 v)- <|> fmap VT.W64 (getField $ _uint64 v)- <|> fmap (\(Signed n) -> VT.S64 n) (getField $ _sint v)- <|> fmap VT.B (getField $ _bool v)-- toProtobuf (VT.St v) = def { _string = putField $ Just v }- toProtobuf (VT.Fl v) = def { _float = putField $ Just v }- toProtobuf (VT.Do v) = def { _double = putField $ Just v }- toProtobuf (VT.I64 v) = def { _int64 = putField $ Just v }- toProtobuf (VT.W64 v) = def { _uint64 = putField $ Just v }- toProtobuf (VT.S64 v) = def { _sint = putField . Just $ Signed v }- toProtobuf (VT.B v) = def { _bool = putField $ Just v }---- | A list of `RawLayer`s.-data RawVectorTile = RawVectorTile { _layers :: Repeated 3 (Message RawLayer) }- deriving (Generic,Show,Eq)--instance Encode RawVectorTile-instance Decode RawVectorTile-instance NFData RawVectorTile---- | Contains a pseudo-map of metadata, to be shared across all `RawFeature`s--- of this `RawLayer`.-data RawLayer = RawLayer { _version :: Required 15 (Value Word32)- , _name :: Required 1 (Value Text)- , _features :: Repeated 2 (Message RawFeature)- , _keys :: Repeated 3 (Value Text)- , _values :: Repeated 4 (Message RawVal)- , _extent :: Optional 5 (Value Word32)- } deriving (Generic,Show,Eq)--instance Encode RawLayer-instance Decode RawLayer-instance NFData RawLayer---- | The /Value/ types of metadata fields.-data RawVal = RawVal { _string :: Optional 1 (Value Text)- , _float :: Optional 2 (Value Float)- , _double :: Optional 3 (Value Double)- , _int64 :: Optional 4 (Value Int64)- , _uint64 :: Optional 5 (Value Word64)- , _sint :: Optional 6 (Value (Signed Int64)) -- ^ Z-encoded.- , _bool :: Optional 7 (Value Bool)- } deriving (Generic,Show,Eq)--instance Encode RawVal-instance Decode RawVal-instance NFData RawVal---- | A set of geometries unified by some theme.-data RawFeature = RawFeature { _featureId :: Optional 1 (Value Word64)- , _tags :: Packed 2 (Value Word32)- , _geom :: Optional 3 (Enumeration GeomType)- , _geometries :: Packed 4 (Value Word32)- } deriving (Generic,Show,Eq)--instance Encode RawFeature-instance Decode RawFeature-instance NFData RawFeature---- | The four potential Geometry types. The spec allows for encoders to set--- `Unknown` as the type, but our decoder ignores these.-data GeomType = Unknown | Point | LineString | Polygon- deriving (Generic,Enum,Show,Eq)--instance Encode GeomType-instance Decode GeomType-instance NFData GeomType---- | Any classical type considered a GIS "geometry". These must be able--- to convert between an encodable list of `Command`s.-class ProtobufGeom g where- fromCommands :: [Command] -> Either Text (V.Vector g)- toCommands :: V.Vector g -> [Command]---- | A valid `RawFeature` of points must contain a single `MoveTo` command--- with a count greater than 0.-instance ProtobufGeom G.Point where- fromCommands [MoveTo ps] = Right . U.convert $ evalState (U.mapM expand ps) (0,0)- fromCommands (c:_) = Left . pack $ printf "Invalid command found in Point feature: %s" (show c)- fromCommands [] = Left "No points given!"-- -- | A multipoint geometry must reduce to a single `MoveTo` command.- toCommands ps = [MoveTo $ evalState (U.mapM collapse $ U.convert ps) (0,0)]---- | A valid `RawFeature` of linestrings must contain pairs of:------ A `MoveTo` with a count of 1, followed by one `LineTo` command with--- a count greater than 0.-instance ProtobufGeom G.LineString where- fromCommands cs = evalState (f cs) (0,0)- where f (MoveTo p : LineTo ps : rs) = fmap . V.cons <$> ls <*> f rs- where ls = G.LineString <$> U.mapM expand (p <> ps)- f [] = pure $ Right V.empty- f _ = pure $ Left "LineString decode: Invalid command sequence given."-- toCommands ls = concat $ evalState (mapM f ls) (0,0)- where f (G.LineString ps) = do- l <- U.mapM collapse ps- pure [MoveTo . U.singleton $ U.head l, LineTo $ U.tail l]---- | A valid `RawFeature` of polygons must contain at least one sequence of:------ An Exterior Ring, followed by 0 or more Interior Rings.------ Any Ring must have a `MoveTo` with a count of 1, a single `LineTo`--- with a count of at least 2, and a single `ClosePath` command.------ Performs no sanity checks for malformed Interior Rings.-instance ProtobufGeom G.Polygon where- fromCommands cs = do- ps <- evalState (f cs) (0,0)- let (h,t) = (V.head ps, V.tail ps)- (ps',p') = runState (foldlM g V.empty t) h- pure $ V.snoc ps' p' -- Include the last Exterior Ring worked on.- where f (MoveTo p : LineTo ps : ClosePath : rs) = do- curr <- get- let h = U.head p- here = (G.x h + G.x curr, G.y h + G.y curr)- po <- flip U.snoc here <$> U.mapM expand (U.cons h ps)- fmap (V.cons (G.Polygon po V.empty)) <$> f rs- f [] = pure $ Right V.empty- f _ = pure . Left . pack $ printf "Polygon decode: Invalid command sequence given: %s" (show cs)- g acc p | G.area p > 0 = do -- New external rings.- curr <- get- put p- pure $ V.snoc acc curr- | otherwise = do -- Next internal ring.- modify (\s -> s { G.inner = V.snoc (G.inner s) p })- pure acc-- toCommands ps = concat $ evalState (mapM f ps) (0,0)- where f (G.Polygon p i) = do- l <- U.mapM collapse $ U.init p -- Exclude the final point.- let cs = [MoveTo . U.singleton $ U.head l, LineTo $ U.tail l, ClosePath]- concat . V.cons cs <$> mapM f i---- | The possible commands, and the values they hold.-data Command = MoveTo (U.Vector (Int,Int))- | LineTo (U.Vector (Int,Int))- | ClosePath deriving (Eq,Show)---- | Z-encode a 64-bit Int.-zig :: Int -> Word32-zig n = fromIntegral $ shift n 1 `xor` shift n (-63)---- | Decode a Z-encoded Word32 into a 64-bit Int.-unzig :: Word32 -> Int-unzig n = fromIntegral (fromIntegral unzigged :: Int32)- where unzigged = shift n (-1) `xor` negate (n .&. 1)---- | Divide a "Command Integer" into its @(Command,Count)@.-parseCmd :: Word32 -> Either Text (Int,Int)-parseCmd n = case (cmd,count) of- (1,m) -> Right $ both fromIntegral (1,m)- (2,m) -> Right $ both fromIntegral (2,m)- (7,1) -> Right (7,1)- (7,m) -> Left $ "ClosePath was given a parameter count: " <> pack (show m)- (m,_) -> Left . pack $ printf "Invalid command integer %d found in: %X" m n- where cmd = n .&. 7- count = shift n (-3)---- | Recombine a Command ID and parameter count into a Command Integer.-unparseCmd :: (Int,Int) -> Word32-unparseCmd (cmd,count) = fromIntegral $ (cmd .&. 7) .|. shift count 3---- | Attempt to parse a list of Command/Parameter integers, as defined here:------ https://github.com/mapbox/vector-tile-spec/tree/master/2.1#43-geometry-encoding-commands :: [Word32] -> Either Text [Command]-commands [] = Right []-commands (n:ns) = parseCmd n >>= f- where f (1,count) = do- mts <- MoveTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)- (mts :) <$> commands (drop (count * 2) ns)- f (2,count) = do- mts <- LineTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)- (mts :) <$> commands (drop (count * 2) ns)- f (7,_) = (ClosePath :) <$> commands ns- f _ = Left "Sentinel: You should never see this."---- | Convert a list of parsed `Command`s back into their original Command--- and Z-encoded Parameter integer forms.-uncommands :: [Command] -> [Word32]-uncommands = U.toList . U.concat . map f- where f (MoveTo ps) = U.cons (unparseCmd (1, U.length ps)) $ params ps- f (LineTo ls) = U.cons (unparseCmd (2, U.length ls)) $ params ls- f ClosePath = U.singleton $ unparseCmd (7,1) -- ClosePath, Count 1.--{- FROM PROTOBUF -}---- | Convert a list of `RawFeature`s of parsed protobuf data into `V.Vector`s--- of each of the three legal `ProtobufGeom` types.------ The long type signature is due to two things:------ 1. `Feature`s are polymorphic at the high level, but not at the parsed--- protobuf mid-level. In a @[RawFeature]@, there are features of points,--- linestrings, and polygons all mixed together.------ 2. `RawLayer`s and `RawFeature`s--- are strongly coupled at the protobuf level. In order to achieve higher--- compression ratios, `RawLayer`s contain all metadata in key/value lists--- to be shared across their `RawFeature`s, while those `RawFeature`s store only--- indices into those lists. As a result, this function needs to be passed--- those key/value lists from the parent `RawLayer`, and a more isomorphic:------ > feature :: ProtobufGeom g => RawFeature -> Either Text (Feature g)------ is not possible.-features :: [Text] -> [RawVal] -> [RawFeature]- -> Either Text (V.Vector (VT.Feature G.Point), V.Vector (VT.Feature G.LineString), V.Vector (VT.Feature G.Polygon))-features _ _ [] = Left "VectorTile.features: `[RawFeature]` empty"-features keys vals fs = (,,) <$> ps <*> ls <*> polys- where -- (_:ps':ls':polys':_) = groupBy sameGeom $ sortOn geomBias fs -- ok ok ok- ps = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just Point) fs- ls = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just LineString) fs- polys = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just Polygon) fs-- f :: ProtobufGeom g => RawFeature -> V.Vector (VT.Feature g) -> Either Text (V.Vector (VT.Feature g))- f x acc = do- geos <- commands (getField $ _geometries x) >>= fromCommands- meta <- getMeta keys vals . getField $ _tags x- pure $ VT.Feature { VT._featureId = maybe 0 fromIntegral . getField $ _featureId x- , VT._metadata = meta- , VT._geometries = geos- } `V.cons` acc--getMeta :: [Text] -> [RawVal] -> [Word32] -> Either Text (M.Map Text VT.Val)-getMeta keys vals tags = do- kv <- map (both fromIntegral) <$> pairs tags- foldrM (\(k,v) acc -> (\v' -> M.insert (keys !! k) v' acc) <$> fromProtobuf (vals !! v)) M.empty kv--{- TO PROTOBUF -}--totalMeta :: V.Vector (VT.Feature G.Point) -> V.Vector (VT.Feature G.LineString) -> V.Vector (VT.Feature G.Polygon) -> ([Text], [VT.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 -- `nub` is O(n^2)- f = V.foldr (\feat acc -> M.keysSet (VT._metadata feat) : acc) []- g = V.foldr (\feat acc -> M.elems (VT._metadata feat) : acc) []---- | Encode a high-level `Feature` back into its mid-level `RawFeature` form.-unfeature :: ProtobufGeom g => M.Map Text Int -> M.Map VT.Val Int -> GeomType -> VT.Feature g -> RawFeature-unfeature keys vals gt fe = RawFeature- { _featureId = putField . Just . fromIntegral $ VT._featureId fe- , _tags = putField $ tags fe- , _geom = putField $ Just gt- , _geometries = putField . uncommands . toCommands $ VT._geometries fe }- where tags = unpairs . map f . M.toList . VT._metadata- f (k,v) = both (fromIntegral . fromJust) (M.lookup k keys, M.lookup v vals)--{- UTIL -}---- | A `RawVal` with every entry set to `Nothing`.-def :: RawVal-def = RawVal { _string = putField Nothing- , _float = putField Nothing- , _double = putField Nothing- , _int64 = putField Nothing- , _uint64 = putField Nothing- , _sint = putField Nothing- , _bool = putField Nothing }---- | Transform a `V.Vector` of `Point`s into one of Z-encoded Parameter ints.-params :: U.Vector (Int,Int) -> U.Vector Word32-params = U.foldr (\(a,b) acc -> U.cons (zig a) $ U.cons (zig b) acc) U.empty---- | Expand a pair of diffs from some reference point into that--- of a `Point` value. The reference point is moved to our new `Point`.-expand :: (Int,Int) -> State (Int,Int) G.Point-expand p = do- curr <- get- let here = (G.x p + G.x curr, G.y p + G.y curr)- put here- pure here---- | Collapse a given `Point` into a pair of diffs, relative to--- the previous point in the sequence. The reference point is moved--- to the `Point` given.-collapse :: G.Point -> State (Int,Int) (Int,Int)-collapse p = do- curr <- get- let diff = (G.x p - G.x curr, G.y p - G.y curr)- put p- pure diff
− Geography/VectorTile/Util.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- Module : Geography.VectorTile.Util--- Copyright : (c) Azavea, 2016--- License : Apache 2--- Maintainer: Colin Woodbury <cwoodbury@azavea.com>--module Geography.VectorTile.Util where--import Data.Text (Text)--------- | A sort of "self-zip", forming pairs from every two elements in a list.--- Fails if there is an uneven number of elements.-pairs :: [a] -> Either Text [(a,a)]-pairs [] = Right []-pairs [_] = Left "Uneven number of parameters given."-pairs (x:y:zs) = ((x,y) :) <$> pairs zs---- | Flatten a list of pairs. Equivalent to:------ > ps ^.. each . both-unpairs :: [(a,a)] -> [a]-unpairs = foldr (\(a,b) acc -> a : b : acc) []---- | Apply a pure function to both elements of a tuple.-both :: (a -> b) -> (a,a) -> (b,b)-both f (x,y) = (f x, f y)---- | Convert a `Maybe` to an `Either`, with some given default value--- should the result of the `Maybe` be `Nothing`.-mtoe :: a -> Maybe b -> Either a b-mtoe _ (Just b) = Right b-mtoe a _ = Left a
− Geography/VectorTile/VectorTile.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}---- |--- Module : Geography.VectorTile.VectorTile--- Copyright : (c) Azavea, 2016 - 2017--- License : Apache 2--- Maintainer: Colin Woodbury <cwoodbury@azavea.com>------ High-level types for representing Vector Tiles.--module Geography.VectorTile.VectorTile- ( -- * Types- VectorTile(..)- , Layer(..)- , Feature(..)- , Val(..)- -- * Lenses- -- | This section can be safely ignored if one isn't concerned with lenses.- -- Otherwise, see the following for a good primer on Haskell lenses:- -- http://hackage.haskell.org/package/lens-tutorial-1.0.1/docs/Control-Lens-Tutorial.html- --- -- These lenses are written in a generic way to avoid taking a dependency- -- on one of the lens libraries.- , layers- , version- , name- , points- , linestrings- , polygons- , extent- , featureId- , metadata- , geometries- ) where--import Control.DeepSeq (NFData)-import Data.Int-import qualified Data.Map.Lazy as M-import Data.Text (Text)-import qualified Data.Vector as V-import Data.Word-import GHC.Generics (Generic)-import Geography.VectorTile.Geometry--------- | A high-level representation of a Vector Tile. Implemented internally--- as a `M.Map`, so that access to individual layers can be fast if you--- know the layer names ahead of time.-newtype VectorTile = VectorTile { _layers :: M.Map Text Layer } deriving (Eq,Show,Generic)---- | > Lens' VectorTile (Map Text Layer)-layers :: Functor f => (M.Map Text Layer -> f (M.Map Text Layer)) -> VectorTile -> f VectorTile-layers f v = VectorTile <$> f (_layers v)-{-# INLINE layers #-}--instance NFData VectorTile---- | A layer, which could contain any number of `Feature`s of any `Geometry` type.--- This codec only respects the canonical three `Geometry` types, and we split--- them here explicitely to allow for more fine-grained access to each type.-data Layer = Layer { _version :: Int -- ^ The version of the spec we follow. Should always be 2.- , _name :: Text- , _points :: V.Vector (Feature Point)- , _linestrings :: V.Vector (Feature LineString)- , _polygons :: V.Vector (Feature Polygon)- , _extent :: Int -- ^ Default: 4096- } deriving (Eq,Show,Generic)---- | > Lens' Layer Int-version :: Functor f => (Int -> f Int) -> Layer -> f Layer-version f l = (\v -> l { _version = v }) <$> f (_version l)-{-# INLINE version #-}---- | > Lens' Layer Text-name :: Functor f => (Text -> f Text) -> Layer -> f Layer-name f l = (\v -> l { _name = v }) <$> f (_name l)-{-# INLINE name #-}---- | > Lens' Layer (Vector (Feature Point))-points :: Functor f => (V.Vector (Feature Point) -> f (V.Vector (Feature Point))) -> Layer -> f Layer-points f l = (\v -> l { _points = v }) <$> f (_points l)-{-# INLINE points #-}---- | > Lens' Layer (Vector (Feature LineString)))-linestrings :: Functor f => (V.Vector (Feature LineString) -> f (V.Vector (Feature LineString))) -> Layer -> f Layer-linestrings f l = (\v -> l { _linestrings = v }) <$> f (_linestrings l)-{-# INLINE linestrings #-}---- | > Lens' Layer (Vector (Feature Polygon)))-polygons :: Functor f => (V.Vector (Feature Polygon) -> f (V.Vector (Feature Polygon))) -> Layer -> f Layer-polygons f l = (\v -> l { _polygons = v }) <$> f (_polygons l)-{-# INLINE polygons #-}---- | > Lens' Layer Int-extent :: Functor f => (Int -> f Int) -> Layer -> f Layer-extent f l = (\v -> l { _extent = v }) <$> f (_extent l)-{-# INLINE extent #-}--instance NFData Layer---- | A geographic feature. Features are a set of geometries that share--- some common theme:------ * Points: schools, gas station locations, etc.--- * LineStrings: Roads, power lines, rivers, etc.--- * Polygons: Buildings, water bodies, etc.------ Where, for instance, all school locations may be stored as a single--- `Feature`, and no `Point` within that `Feature` would represent anything--- else.------ Note: Each `Geometry` type and their /Multi*/ counterpart are considered--- the same thing, as a `V.Vector` of that `Geometry`.-data Feature g = Feature { _featureId :: Int -- ^ Default: 0- , _metadata :: M.Map Text Val- , _geometries :: V.Vector g } deriving (Eq,Show,Generic)---- | > Lens' (Feature g) Int-featureId :: Functor f => (Int -> f Int) -> Feature g -> f (Feature g)-featureId f l = (\v -> l { _featureId = v }) <$> f (_featureId l)-{-# INLINE featureId #-}---- | > Lens' (Feature g) (Map Text Val)-metadata :: Functor f => (M.Map Text Val -> f (M.Map Text Val)) -> Feature g -> f (Feature g)-metadata f l = (\v -> l { _metadata = v }) <$> f (_metadata l)-{-# INLINE metadata #-}---- | > Lens' (Feature g) (Vector g)-geometries :: Functor f => (V.Vector g -> f (V.Vector g)) -> Feature g -> f (Feature g)-geometries f l = (\v -> l { _geometries = v }) <$> f (_geometries l)-{-# INLINE geometries #-}--instance NFData g => NFData (Feature g)---- | Legal Metadata /Value/ types. Note that `S64` are Z-encoded automatically--- by the underlying "Data.ProtocolBuffers" library.-data Val = St Text | Fl Float | Do Double | I64 Int64 | W64 Word64 | S64 Int64 | B Bool- deriving (Eq,Ord,Show,Generic)--instance NFData Val
README.md view
@@ -2,7 +2,6 @@ =========== [](https://travis-ci.org/fosskers/vectortiles)-[](https://coveralls.io/github/fosskers/vectortiles?branch=master) [](https://hackage.haskell.org/package/vectortiles) [](http://stackage.org/nightly/package/vectortiles) [](http://stackage.org/lts/package/vectortiles)
+ lib/Geography/VectorTile.hs view
@@ -0,0 +1,68 @@+-- |+-- Module : Geography.VectorTile+-- Copyright : (c) Azavea, 2016+-- License : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>+--+-- GIS Vector Tiles, as defined by Mapbox.+--+-- This library implements version 2.1 of the official Mapbox spec, as defined+-- here: https://github.com/mapbox/vector-tile-spec/tree/master/2.1+--+-- Note that currently this library ignores top-level protobuf extensions,+-- /Value/ extensions, and /UNKNOWN/ geometries.+--+-- The order in which to explore the modules of this library is as follows:+--+-- 1. "Geography.VectorTile.VectorTile"+-- 2. "Geography.VectorTile.Geometry"+-- 3. "Geography.VectorTile.Protobuf"+--+-- == Usage+--+-- This library reads and writes strict `ByteString`s. By importing this module,+-- you use the default protobuf backend. Given some legal+-- VectorTile file called @roads.mvt@:+--+-- > import qualified Data.ByteString as BS+-- > import Data.Text (Text)+-- > import Geography.VectorTile+-- >+-- > -- | Read in raw protobuf data and decode it into a high-level type.+-- > roads :: IO (Either Text VectorTile)+-- > roads = do+-- > mvt <- BS.readFile "roads.mvt"+-- > pure $ decode mvt >>= tile+--+-- Or encode a `VectorTile` back into a `ByteString`:+--+-- > roadsBytes :: VectorTile -> BS.ByteString+-- > roadsBytes = encode . untile+++module Geography.VectorTile+ ( -- * High-level Types+ -- | This module also provides lenses for data field access,+ -- as `VectorTile`s are highly nested objects.+ module Geography.VectorTile.VectorTile+ , -- * Protobuf Backend+ -- ** Conversions+ tile+ , untile+ -- ** ByteString Encoding / Decoding+ , decode+ , encode+ ) where++import Data.Text (Text)+import qualified Geography.VectorTile.Protobuf.Internal as PB+import Geography.VectorTile.Protobuf (decode, encode)+import Geography.VectorTile.VectorTile++---++tile :: PB.RawVectorTile -> Either Text VectorTile+tile = PB.fromProtobuf++untile :: VectorTile -> PB.RawVectorTile+untile = PB.toProtobuf
+ lib/Geography/VectorTile/Geometry.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module : Geography.VectorTile.Geometry+-- Copyright : (c) Azavea, 2016+-- License : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>++module Geography.VectorTile.Geometry+ ( -- * Geometries+ -- ** Types+ Point, x, y+ , LineString(..)+ , Polygon(..)+ -- ** Operations+ , area+ , surveyor+ , distance+ ) where++import Control.DeepSeq (NFData)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import GHC.Generics (Generic)++---++-- | Points in space. Using "Record Pattern Synonyms" here allows us to treat+-- `Point` like a normal ADT, while its implementation remains an unboxed+-- @(Int,Int)@.+type Point = (Int,Int)+pattern Point :: Int -> Int -> (Int, Int)+pattern Point{x, y} = (x, y)++-- | /newtype/ compiles away to expose only the `U.Vector` of unboxed `Point`s+-- at runtime.+newtype LineString = LineString { lsPoints :: U.Vector Point } deriving (Eq,Show,Generic)++instance NFData LineString++-- | A polygon aware of its interior rings.+data Polygon = Polygon { polyPoints :: U.Vector Point+ , inner :: V.Vector Polygon } deriving (Eq,Show,Generic)++instance NFData Polygon++{-+-- | Very performant for the same reason as `LineString`.+newtype Polygon = Polygon { points :: U.Vector Point } deriving (Eq,Show)+-}++-- | The area of a `Polygon` is the difference between the areas of its+-- outer ring and inner rings.+area :: Polygon -> Float+area p = surveyor (polyPoints p) + sum (V.map area $ inner p)++-- | The surveyor's formula for calculating the area of a `Polygon`.+-- If the value reported here is negative, then the `Polygon` should be+-- considered an Interior Ring.+--+-- Assumption: The `U.Vector` given has at least 4 `Point`s.+surveyor :: U.Vector Point -> Float+surveyor v = (/ 2) . fromIntegral . U.sum $ U.zipWith3 (\xn yn yp -> xn * (yn - yp)) xs yns yps+ where v' = U.init v+ xs = U.map x v'+ yns = U.map y . U.tail $ U.snoc v' (U.head v')+ yps = U.map y . U.init $ U.cons (U.last v') v'++-- | Euclidean distance.+distance :: Point -> Point -> Float+distance p1 p2 = sqrt . fromIntegral $ dx ^ 2 + dy ^ 2+ where dx = x p1 - x p2+ dy = y p1 - y p2
+ lib/Geography/VectorTile/Protobuf.hs view
@@ -0,0 +1,59 @@+-- |+-- Module : Geography.VectorTile.Protobuf+-- Copyright : (c) Azavea, 2016+-- License : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>+--+-- Most of the details of Protobuf conversion are kept in+-- "Geometry.VectorTile.Protobuf.Internal", a module which is not intended+-- to be imported.+--+-- A user's main concern here should be the `Protobuffable` class, and its+-- `VectorTile` instance. With it, one can do the following:+--+-- > import Geography.VectorTile.Protobuf+-- >+-- > decode bytes >>= fromProtobuf -- Either Text VectorTile+--+-- which in fact is sugared in the top-level module of this library as:+--+-- > decode bytes >>= tile++module Geography.VectorTile.Protobuf+ ( -- * Types+ Protobuffable(..)+ -- * ByteString Encoding / Decoding+ , decode+ , encode+ , decodeIO+ , encodeIO+ ) where++import qualified Data.ByteString as BS+import Data.ProtocolBuffers hiding (decode, encode)+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Text (Text, pack)+import Geography.VectorTile.Protobuf.Internal++---++-- | Attempt to decode a `BS.ByteString` of raw protobuf data into a mid-level+-- representation of a `RawVectorTile`.+decode :: BS.ByteString -> Either Text RawVectorTile+decode bs = case runGet decodeMessage bs of+ Left e -> Left $ pack e+ Right vt -> Right vt++-- | Encode a mid-level representation of a `RawVectorTile` into raw protobuf data.+encode :: RawVectorTile -> BS.ByteString+encode = runPut . encodeMessage++-- | Given a filename, attempt to decode bytes read from that file.+decodeIO :: FilePath -> IO (Either Text RawVectorTile)+decodeIO = fmap decode . BS.readFile++-- | Write a mid-level representation of a `RawVectorTile` to a file as raw+-- protobuf data.+encodeIO :: RawVectorTile -> FilePath -> IO ()+encodeIO vt fp = BS.writeFile fp $ encode vt
+ lib/Geography/VectorTile/Protobuf/Internal.hs view
@@ -0,0 +1,410 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilyDependencies #-}++-- |+-- Module : Geography.VectorTile.Protobuf.Internal+-- Copyright : (c) Azavea, 2016 - 2017+-- License : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>+--+-- Raw Vector Tile data is stored as binary protobuf data.+-- This module reads and writes raw protobuf ByteStrings between a data type+-- which closely matches the current Mapbox vector tile spec defined here:+-- https://github.com/mapbox/vector-tile-spec/blob/master/2.1/vector_tile.proto+--+-- As this raw version of the data is hard to work with, in practice we convert+-- to a more canonical Haskell type for further processing.+-- See "Geography.VectorTile.VectorTile" for the user-friendly version.+--+-- Please import this module @qualified@ to avoid namespace clashes:+--+-- > import qualified Geography.VectorTile.Protobuf.Internal as PB++module Geography.VectorTile.Protobuf.Internal+ ( -- * Types+ Protobuf(..)+ , Protobuffable(..)+ , ProtobufGeom(..)+ , RawVectorTile(..)+ , RawLayer(..)+ , RawVal(..)+ , RawFeature(..)+ , GeomType(..)+ -- * Commands+ , Command(..)+ , commands+ , uncommands+ -- * Z-Encoding+ , zig+ , unzig+ -- * Protobuf Conversions+ -- | Due to Protobuf Layers and Features having their data coupled,+ -- we can't define a `Protobuffable` instance for `VT.Feature`s,+ -- and instead must use the two functions below.+ , features+ , unfeature+ ) where++import Control.Applicative ((<|>))+import Control.DeepSeq (NFData)+import Control.Monad.Trans.State.Lazy+import Data.Bits+import Data.Foldable (foldrM, foldlM)+import Data.Int+import Data.List (nub)+import qualified Data.Map.Lazy as M+import Data.Maybe (fromJust)+import Data.Monoid+import Data.ProtocolBuffers hiding (decode, encode)+import qualified Data.Set as S+import Data.Text (Text, pack)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import Data.Word+import GHC.Generics (Generic)+import qualified Geography.VectorTile.Geometry as G+import Geography.VectorTile.Util+import qualified Geography.VectorTile.VectorTile as VT+import Text.Printf++---++-- | A family of data types which can associated with concrete underlying+-- Protobuf types.+type family Protobuf a = pb | pb -> a+type instance Protobuf VT.VectorTile = RawVectorTile+type instance Protobuf VT.Layer = RawLayer+type instance Protobuf VT.Val = RawVal++-- | A type which can be converted to and from an underlying Protobuf type,+-- according to the `Protobuf` type family.+class Protobuffable a where+ fromProtobuf :: Protobuf a -> Either Text a+ toProtobuf :: a -> Protobuf a++instance Protobuffable VT.VectorTile where+ fromProtobuf raw = do+ ls <- mapM fromProtobuf . getField $ _layers raw+ pure . VT.VectorTile . M.fromList $ map (\l -> (VT._name l, l)) ls++ toProtobuf vt = RawVectorTile { _layers = putField . map toProtobuf . M.elems $ VT._layers vt }++instance Protobuffable VT.Layer where+ fromProtobuf l = do+ (ps,ls,polys) <- features keys vals . getField $ _features l+ pure VT.Layer { VT._version = fromIntegral . getField $ _version l+ , VT._name = getField $ _name l+ , VT._points = ps+ , VT._linestrings = ls+ , VT._polygons = polys+ , VT._extent = maybe 4096 fromIntegral (getField $ _extent l) }+ where keys = getField $ _keys l+ vals = getField $ _values l++ toProtobuf l = RawLayer { _version = putField . fromIntegral $ VT._version l+ , _name = putField $ VT._name l+ , _features = putField fs+ , _keys = putField ks+ , _values = putField $ map toProtobuf vs+ , _extent = putField . Just . fromIntegral $ VT._extent l }+ 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 = V.toList $ V.concat [ V.map (unfeature km vm Point) (VT._points l)+ , V.map (unfeature km vm LineString) (VT._linestrings l)+ , V.map (unfeature km vm Polygon) (VT._polygons l) ]++instance Protobuffable VT.Val where+ fromProtobuf v = mtoe "Value decode: No legal Value type offered" $ fmap VT.St (getField $ _string v)+ <|> fmap VT.Fl (getField $ _float v)+ <|> fmap VT.Do (getField $ _double v)+ <|> fmap VT.I64 (getField $ _int64 v)+ <|> fmap VT.W64 (getField $ _uint64 v)+ <|> fmap (\(Signed n) -> VT.S64 n) (getField $ _sint v)+ <|> fmap VT.B (getField $ _bool v)++ toProtobuf (VT.St v) = def { _string = putField $ Just v }+ toProtobuf (VT.Fl v) = def { _float = putField $ Just v }+ toProtobuf (VT.Do v) = def { _double = putField $ Just v }+ toProtobuf (VT.I64 v) = def { _int64 = putField $ Just v }+ toProtobuf (VT.W64 v) = def { _uint64 = putField $ Just v }+ toProtobuf (VT.S64 v) = def { _sint = putField . Just $ Signed v }+ toProtobuf (VT.B v) = def { _bool = putField $ Just v }++-- | A list of `RawLayer`s.+data RawVectorTile = RawVectorTile { _layers :: Repeated 3 (Message RawLayer) }+ deriving (Generic,Show,Eq)++instance Encode RawVectorTile+instance Decode RawVectorTile+instance NFData RawVectorTile++-- | Contains a pseudo-map of metadata, to be shared across all `RawFeature`s+-- of this `RawLayer`.+data RawLayer = RawLayer { _version :: Required 15 (Value Word32)+ , _name :: Required 1 (Value Text)+ , _features :: Repeated 2 (Message RawFeature)+ , _keys :: Repeated 3 (Value Text)+ , _values :: Repeated 4 (Message RawVal)+ , _extent :: Optional 5 (Value Word32)+ } deriving (Generic,Show,Eq)++instance Encode RawLayer+instance Decode RawLayer+instance NFData RawLayer++-- | The /Value/ types of metadata fields.+data RawVal = RawVal { _string :: Optional 1 (Value Text)+ , _float :: Optional 2 (Value Float)+ , _double :: Optional 3 (Value Double)+ , _int64 :: Optional 4 (Value Int64)+ , _uint64 :: Optional 5 (Value Word64)+ , _sint :: Optional 6 (Value (Signed Int64)) -- ^ Z-encoded.+ , _bool :: Optional 7 (Value Bool)+ } deriving (Generic,Show,Eq)++instance Encode RawVal+instance Decode RawVal+instance NFData RawVal++-- | A set of geometries unified by some theme.+data RawFeature = RawFeature { _featureId :: Optional 1 (Value Word64)+ , _tags :: Packed 2 (Value Word32)+ , _geom :: Optional 3 (Enumeration GeomType)+ , _geometries :: Packed 4 (Value Word32)+ } deriving (Generic,Show,Eq)++instance Encode RawFeature+instance Decode RawFeature+instance NFData RawFeature++-- | The four potential Geometry types. The spec allows for encoders to set+-- `Unknown` as the type, but our decoder ignores these.+data GeomType = Unknown | Point | LineString | Polygon+ deriving (Generic,Enum,Show,Eq)++instance Encode GeomType+instance Decode GeomType+instance NFData GeomType++-- | Any classical type considered a GIS "geometry". These must be able+-- to convert between an encodable list of `Command`s.+class ProtobufGeom g where+ fromCommands :: [Command] -> Either Text (V.Vector g)+ toCommands :: V.Vector g -> [Command]++-- | A valid `RawFeature` of points must contain a single `MoveTo` command+-- with a count greater than 0.+instance ProtobufGeom G.Point where+ fromCommands [MoveTo ps] = Right . U.convert $ evalState (U.mapM expand ps) (0,0)+ fromCommands (c:_) = Left . pack $ printf "Invalid command found in Point feature: %s" (show c)+ fromCommands [] = Left "No points given!"++ -- | A multipoint geometry must reduce to a single `MoveTo` command.+ toCommands ps = [MoveTo $ evalState (U.mapM collapse $ U.convert ps) (0,0)]++-- | A valid `RawFeature` of linestrings must contain pairs of:+--+-- A `MoveTo` with a count of 1, followed by one `LineTo` command with+-- a count greater than 0.+instance ProtobufGeom G.LineString where+ fromCommands cs = evalState (f cs) (0,0)+ where f (MoveTo p : LineTo ps : rs) = fmap . V.cons <$> ls <*> f rs+ where ls = G.LineString <$> U.mapM expand (p <> ps)+ f [] = pure $ Right V.empty+ f _ = pure $ Left "LineString decode: Invalid command sequence given."++ toCommands ls = concat $ evalState (mapM f ls) (0,0)+ where f (G.LineString ps) = do+ l <- U.mapM collapse ps+ pure [MoveTo . U.singleton $ U.head l, LineTo $ U.tail l]++-- | A valid `RawFeature` of polygons must contain at least one sequence of:+--+-- An Exterior Ring, followed by 0 or more Interior Rings.+--+-- Any Ring must have a `MoveTo` with a count of 1, a single `LineTo`+-- with a count of at least 2, and a single `ClosePath` command.+--+-- Performs no sanity checks for malformed Interior Rings.+instance ProtobufGeom G.Polygon where+ fromCommands cs = do+ ps <- evalState (f cs) (0,0)+ let (h,t) = (V.head ps, V.tail ps)+ (ps',p') = runState (foldlM g V.empty t) h+ pure $ V.snoc ps' p' -- Include the last Exterior Ring worked on.+ where f (MoveTo p : LineTo ps : ClosePath : rs) = do+ curr <- get+ let h = U.head p+ here = (G.x h + G.x curr, G.y h + G.y curr)+ po <- flip U.snoc here <$> U.mapM expand (U.cons h ps)+ fmap (V.cons (G.Polygon po V.empty)) <$> f rs+ f [] = pure $ Right V.empty+ f _ = pure . Left . pack $ printf "Polygon decode: Invalid command sequence given: %s" (show cs)+ g acc p | G.area p > 0 = do -- New external rings.+ curr <- get+ put p+ pure $ V.snoc acc curr+ | otherwise = do -- Next internal ring.+ modify (\s -> s { G.inner = V.snoc (G.inner s) p })+ pure acc++ toCommands ps = concat $ evalState (mapM f ps) (0,0)+ where f (G.Polygon p i) = do+ l <- U.mapM collapse $ U.init p -- Exclude the final point.+ let cs = [MoveTo . U.singleton $ U.head l, LineTo $ U.tail l, ClosePath]+ concat . V.cons cs <$> mapM f i++-- | The possible commands, and the values they hold.+data Command = MoveTo (U.Vector (Int,Int))+ | LineTo (U.Vector (Int,Int))+ | ClosePath deriving (Eq,Show)++-- | Z-encode a 64-bit Int.+zig :: Int -> Word32+zig n = fromIntegral $ shift n 1 `xor` shift n (-63)++-- | Decode a Z-encoded Word32 into a 64-bit Int.+unzig :: Word32 -> Int+unzig n = fromIntegral (fromIntegral unzigged :: Int32)+ where unzigged = shift n (-1) `xor` negate (n .&. 1)++-- | Divide a "Command Integer" into its @(Command,Count)@.+parseCmd :: Word32 -> Either Text (Int,Int)+parseCmd n = case (cmd,count) of+ (1,m) -> Right $ both fromIntegral (1,m)+ (2,m) -> Right $ both fromIntegral (2,m)+ (7,1) -> Right (7,1)+ (7,m) -> Left $ "ClosePath was given a parameter count: " <> pack (show m)+ (m,_) -> Left . pack $ printf "Invalid command integer %d found in: %X" m n+ where cmd = n .&. 7+ count = shift n (-3)++-- | Recombine a Command ID and parameter count into a Command Integer.+unparseCmd :: (Int,Int) -> Word32+unparseCmd (cmd,count) = fromIntegral $ (cmd .&. 7) .|. shift count 3++-- | Attempt to parse a list of Command/Parameter integers, as defined here:+--+-- https://github.com/mapbox/vector-tile-spec/tree/master/2.1#43-geometry-encoding+commands :: [Word32] -> Either Text [Command]+commands [] = Right []+commands (n:ns) = parseCmd n >>= f+ where f (1,count) = do+ mts <- MoveTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)+ (mts :) <$> commands (drop (count * 2) ns)+ f (2,count) = do+ mts <- LineTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)+ (mts :) <$> commands (drop (count * 2) ns)+ f (7,_) = (ClosePath :) <$> commands ns+ f _ = Left "Sentinel: You should never see this."++-- | Convert a list of parsed `Command`s back into their original Command+-- and Z-encoded Parameter integer forms.+uncommands :: [Command] -> [Word32]+uncommands = U.toList . U.concat . map f+ where f (MoveTo ps) = U.cons (unparseCmd (1, U.length ps)) $ params ps+ f (LineTo ls) = U.cons (unparseCmd (2, U.length ls)) $ params ls+ f ClosePath = U.singleton $ unparseCmd (7,1) -- ClosePath, Count 1.++{- FROM PROTOBUF -}++-- | Convert a list of `RawFeature`s of parsed protobuf data into `V.Vector`s+-- of each of the three legal `ProtobufGeom` types.+--+-- The long type signature is due to two things:+--+-- 1. `Feature`s are polymorphic at the high level, but not at the parsed+-- protobuf mid-level. In a @[RawFeature]@, there are features of points,+-- linestrings, and polygons all mixed together.+--+-- 2. `RawLayer`s and `RawFeature`s+-- are strongly coupled at the protobuf level. In order to achieve higher+-- compression ratios, `RawLayer`s contain all metadata in key/value lists+-- to be shared across their `RawFeature`s, while those `RawFeature`s store only+-- indices into those lists. As a result, this function needs to be passed+-- those key/value lists from the parent `RawLayer`, and a more isomorphic:+--+-- > feature :: ProtobufGeom g => RawFeature -> Either Text (Feature g)+--+-- is not possible.+features :: [Text] -> [RawVal] -> [RawFeature]+ -> Either Text (V.Vector (VT.Feature G.Point), V.Vector (VT.Feature G.LineString), V.Vector (VT.Feature G.Polygon))+features _ _ [] = Left "VectorTile.features: `[RawFeature]` empty"+features keys vals fs = (,,) <$> ps <*> ls <*> polys+ where -- (_:ps':ls':polys':_) = groupBy sameGeom $ sortOn geomBias fs -- ok ok ok+ ps = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just Point) fs+ ls = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just LineString) fs+ polys = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just Polygon) fs++ f :: ProtobufGeom g => RawFeature -> V.Vector (VT.Feature g) -> Either Text (V.Vector (VT.Feature g))+ f x acc = do+ geos <- commands (getField $ _geometries x) >>= fromCommands+ meta <- getMeta keys vals . getField $ _tags x+ pure $ VT.Feature { VT._featureId = maybe 0 fromIntegral . getField $ _featureId x+ , VT._metadata = meta+ , VT._geometries = geos+ } `V.cons` acc++getMeta :: [Text] -> [RawVal] -> [Word32] -> Either Text (M.Map Text VT.Val)+getMeta keys vals tags = do+ kv <- map (both fromIntegral) <$> pairs tags+ foldrM (\(k,v) acc -> (\v' -> M.insert (keys !! k) v' acc) <$> fromProtobuf (vals !! v)) M.empty kv++{- TO PROTOBUF -}++totalMeta :: V.Vector (VT.Feature G.Point) -> V.Vector (VT.Feature G.LineString) -> V.Vector (VT.Feature G.Polygon) -> ([Text], [VT.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 -- `nub` is O(n^2)+ f = V.foldr (\feat acc -> M.keysSet (VT._metadata feat) : acc) []+ g = V.foldr (\feat acc -> M.elems (VT._metadata feat) : acc) []++-- | Encode a high-level `Feature` back into its mid-level `RawFeature` form.+unfeature :: ProtobufGeom g => M.Map Text Int -> M.Map VT.Val Int -> GeomType -> VT.Feature g -> RawFeature+unfeature keys vals gt fe = RawFeature+ { _featureId = putField . Just . fromIntegral $ VT._featureId fe+ , _tags = putField $ tags fe+ , _geom = putField $ Just gt+ , _geometries = putField . uncommands . toCommands $ VT._geometries fe }+ where tags = unpairs . map f . M.toList . VT._metadata+ f (k,v) = both (fromIntegral . fromJust) (M.lookup k keys, M.lookup v vals)++{- UTIL -}++-- | A `RawVal` with every entry set to `Nothing`.+def :: RawVal+def = RawVal { _string = putField Nothing+ , _float = putField Nothing+ , _double = putField Nothing+ , _int64 = putField Nothing+ , _uint64 = putField Nothing+ , _sint = putField Nothing+ , _bool = putField Nothing }++-- | Transform a `V.Vector` of `Point`s into one of Z-encoded Parameter ints.+params :: U.Vector (Int,Int) -> U.Vector Word32+params = U.foldr (\(a,b) acc -> U.cons (zig a) $ U.cons (zig b) acc) U.empty++-- | Expand a pair of diffs from some reference point into that+-- of a `Point` value. The reference point is moved to our new `Point`.+expand :: (Int,Int) -> State (Int,Int) G.Point+expand p = do+ curr <- get+ let here = (G.x p + G.x curr, G.y p + G.y curr)+ put here+ pure here++-- | Collapse a given `Point` into a pair of diffs, relative to+-- the previous point in the sequence. The reference point is moved+-- to the `Point` given.+collapse :: G.Point -> State (Int,Int) (Int,Int)+collapse p = do+ curr <- get+ let diff = (G.x p - G.x curr, G.y p - G.y curr)+ put p+ pure diff
+ lib/Geography/VectorTile/Util.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Geography.VectorTile.Util+-- Copyright : (c) Azavea, 2016+-- License : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>++module Geography.VectorTile.Util where++import Data.Text (Text)++---++-- | A sort of "self-zip", forming pairs from every two elements in a list.+-- Fails if there is an uneven number of elements.+pairs :: [a] -> Either Text [(a,a)]+pairs [] = Right []+pairs [_] = Left "Uneven number of parameters given."+pairs (x:y:zs) = ((x,y) :) <$> pairs zs++-- | Flatten a list of pairs. Equivalent to:+--+-- > ps ^.. each . both+unpairs :: [(a,a)] -> [a]+unpairs = foldr (\(a,b) acc -> a : b : acc) []++-- | Apply a pure function to both elements of a tuple.+both :: (a -> b) -> (a,a) -> (b,b)+both f (x,y) = (f x, f y)++-- | Convert a `Maybe` to an `Either`, with some given default value+-- should the result of the `Maybe` be `Nothing`.+mtoe :: a -> Maybe b -> Either a b+mtoe _ (Just b) = Right b+mtoe a _ = Left a
+ lib/Geography/VectorTile/VectorTile.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module : Geography.VectorTile.VectorTile+-- Copyright : (c) Azavea, 2016 - 2017+-- License : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>+--+-- High-level types for representing Vector Tiles.++module Geography.VectorTile.VectorTile+ ( -- * Types+ VectorTile(..)+ , Layer(..)+ , Feature(..)+ , Val(..)+ -- * Lenses+ -- | This section can be safely ignored if one isn't concerned with lenses.+ -- Otherwise, see the following for a good primer on Haskell lenses:+ -- http://hackage.haskell.org/package/lens-tutorial-1.0.1/docs/Control-Lens-Tutorial.html+ --+ -- These lenses are written in a generic way to avoid taking a dependency+ -- on one of the lens libraries.+ , layers+ , version+ , name+ , points+ , linestrings+ , polygons+ , extent+ , featureId+ , metadata+ , geometries+ ) where++import Control.DeepSeq (NFData)+import Data.Int+import qualified Data.Map.Lazy as M+import Data.Text (Text)+import qualified Data.Vector as V+import Data.Word+import GHC.Generics (Generic)+import Geography.VectorTile.Geometry++---++-- | A high-level representation of a Vector Tile. Implemented internally+-- as a `M.Map`, so that access to individual layers can be fast if you+-- know the layer names ahead of time.+newtype VectorTile = VectorTile { _layers :: M.Map Text Layer } deriving (Eq,Show,Generic)++-- | > Lens' VectorTile (Map Text Layer)+layers :: Functor f => (M.Map Text Layer -> f (M.Map Text Layer)) -> VectorTile -> f VectorTile+layers f v = VectorTile <$> f (_layers v)+{-# INLINE layers #-}++instance NFData VectorTile++-- | A layer, which could contain any number of `Feature`s of any `Geometry` type.+-- This codec only respects the canonical three `Geometry` types, and we split+-- them here explicitely to allow for more fine-grained access to each type.+data Layer = Layer { _version :: Int -- ^ The version of the spec we follow. Should always be 2.+ , _name :: Text+ , _points :: V.Vector (Feature Point)+ , _linestrings :: V.Vector (Feature LineString)+ , _polygons :: V.Vector (Feature Polygon)+ , _extent :: Int -- ^ Default: 4096+ } deriving (Eq,Show,Generic)++-- | > Lens' Layer Int+version :: Functor f => (Int -> f Int) -> Layer -> f Layer+version f l = (\v -> l { _version = v }) <$> f (_version l)+{-# INLINE version #-}++-- | > Lens' Layer Text+name :: Functor f => (Text -> f Text) -> Layer -> f Layer+name f l = (\v -> l { _name = v }) <$> f (_name l)+{-# INLINE name #-}++-- | > Lens' Layer (Vector (Feature Point))+points :: Functor f => (V.Vector (Feature Point) -> f (V.Vector (Feature Point))) -> Layer -> f Layer+points f l = (\v -> l { _points = v }) <$> f (_points l)+{-# INLINE points #-}++-- | > Lens' Layer (Vector (Feature LineString)))+linestrings :: Functor f => (V.Vector (Feature LineString) -> f (V.Vector (Feature LineString))) -> Layer -> f Layer+linestrings f l = (\v -> l { _linestrings = v }) <$> f (_linestrings l)+{-# INLINE linestrings #-}++-- | > Lens' Layer (Vector (Feature Polygon)))+polygons :: Functor f => (V.Vector (Feature Polygon) -> f (V.Vector (Feature Polygon))) -> Layer -> f Layer+polygons f l = (\v -> l { _polygons = v }) <$> f (_polygons l)+{-# INLINE polygons #-}++-- | > Lens' Layer Int+extent :: Functor f => (Int -> f Int) -> Layer -> f Layer+extent f l = (\v -> l { _extent = v }) <$> f (_extent l)+{-# INLINE extent #-}++instance NFData Layer++-- | A geographic feature. Features are a set of geometries that share+-- some common theme:+--+-- * Points: schools, gas station locations, etc.+-- * LineStrings: Roads, power lines, rivers, etc.+-- * Polygons: Buildings, water bodies, etc.+--+-- Where, for instance, all school locations may be stored as a single+-- `Feature`, and no `Point` within that `Feature` would represent anything+-- else.+--+-- Note: Each `Geometry` type and their /Multi*/ counterpart are considered+-- the same thing, as a `V.Vector` of that `Geometry`.+data Feature g = Feature { _featureId :: Int -- ^ Default: 0+ , _metadata :: M.Map Text Val+ , _geometries :: V.Vector g } deriving (Eq,Show,Generic)++-- | > Lens' (Feature g) Int+featureId :: Functor f => (Int -> f Int) -> Feature g -> f (Feature g)+featureId f l = (\v -> l { _featureId = v }) <$> f (_featureId l)+{-# INLINE featureId #-}++-- | > Lens' (Feature g) (Map Text Val)+metadata :: Functor f => (M.Map Text Val -> f (M.Map Text Val)) -> Feature g -> f (Feature g)+metadata f l = (\v -> l { _metadata = v }) <$> f (_metadata l)+{-# INLINE metadata #-}++-- | > Lens' (Feature g) (Vector g)+geometries :: Functor f => (V.Vector g -> f (V.Vector g)) -> Feature g -> f (Feature g)+geometries f l = (\v -> l { _geometries = v }) <$> f (_geometries l)+{-# INLINE geometries #-}++instance NFData g => NFData (Feature g)++-- | Legal Metadata /Value/ types. Note that `S64` are Z-encoded automatically+-- by the underlying "Data.ProtocolBuffers" library.+data Val = St Text | Fl Float | Do Double | I64 Int64 | W64 Word64 | S64 Int64 | B Bool+ deriving (Eq,Ord,Show,Generic)++instance NFData Val
vectortiles.cabal view
@@ -1,103 +1,102 @@--- Initial gaia-vector-tiles.cabal generated by cabal init. For further--- documentation, see http://haskell.org/cabal/users-guide/--name: vectortiles-version: 1.2.0.4-synopsis: GIS Vector Tiles, as defined by Mapbox.-description: GIS Vector Tiles, as defined by Mapbox.- .- This library implements version 2.1 of the official Mapbox spec, as defined- here: <https://github.com/mapbox/vector-tile-spec/tree/master/2.1>- .- Note that currently this library ignores top-level protobuf extensions,- /Value/ extensions, and /UNKNOWN/ geometries.- .- The order in which to explore the modules of this library is as follows:- .- 1. "Geography.VectorTile.VectorTile" (high-level types)- .- 2. "Geography.VectorTile.Geometry" (typical GIS geometry types)- .- 3. "Geography.VectorTile.Protobuf" (mid-level representation of parsed protobuf data with conversion functions)--homepage: https://github.com/fosskers/vectortiles-license: Apache-2.0-license-file: LICENSE-author: Colin Woodbury-maintainer: cwoodbury@azavea.com--- copyright:-category: Geography-build-type: Simple+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack -cabal-version: >=1.10+name: vectortiles+version: 1.2.0.5+synopsis: GIS Vector Tiles, as defined by Mapbox.+description: GIS Vector Tiles, as defined by Mapbox.+ .+ This library implements version 2.1 of the official Mapbox spec, as defined+ here: <https://github.com/mapbox/vector-tile-spec/tree/master/2.1>+ .+ Note that currently this library ignores top-level protobuf extensions,+ /Value/ extensions, and /UNKNOWN/ geometries.+ .+ The order in which to explore the modules of this library is as follows:+ .+ 1. "Geography.VectorTile.VectorTile" (high-level types)+ .+ 2. "Geography.VectorTile.Geometry" (typical GIS geometry types)+ .+ 3. "Geography.VectorTile.Protobuf" (mid-level representation of parsed protobuf data with conversion functions)+homepage: https://github.com/fosskers/vectortiles+license: Apache-2.0+license-file: LICENSE+author: Colin Woodbury+maintainer: cwoodbury@azavea.com+category: Geography+build-type: Simple+cabal-version: >= 1.10 -extra-source-files: test/roads.mvt- , test/onepoint.mvt- , test/linestring.mvt- , test/polygon.mvt- , test/clearlake.mvt- , README.md- , CHANGELOG.md+extra-source-files:+ CHANGELOG.md+ README.md+ test/clearlake.mvt+ test/linestring.mvt+ test/onepoint.mvt+ test/polygon.mvt+ test/roads.mvt library- exposed-modules: Geography.VectorTile- , Geography.VectorTile.VectorTile- , Geography.VectorTile.Protobuf- , Geography.VectorTile.Protobuf.Internal- , Geography.VectorTile.Geometry- , Geography.VectorTile.Util-- -- other-modules:- -- other-extensions:- build-depends: base >=4.9 && <4.10- , text >= 1.2 && < 1.3- , vector >= 0.11 && < 0.13- , containers- , protobuf >= 0.2.1.1 && < 0.3- , deepseq >= 1.4 && < 1.5- , transformers >= 0.5 && < 0.6- , cereal >= 0.5 && < 0.6- , bytestring-- -- hs-source-dirs:- default-language: Haskell2010-+ hs-source-dirs:+ lib+ exposed-modules:+ Geography.VectorTile+ Geography.VectorTile.Geometry+ Geography.VectorTile.Protobuf+ Geography.VectorTile.Protobuf.Internal+ Geography.VectorTile.Util+ Geography.VectorTile.VectorTile+ build-depends:+ base >=4.9 && <4.10+ , bytestring+ , cereal >=0.5 && <0.6+ , containers+ , protobuf >=0.2.1.1 && <0.3+ , text >=1.2 && <1.3+ , vector >=0.11 && <0.13+ , deepseq >=1.4 && <1.5+ , transformers >=0.5 && <0.6+ default-language: Haskell2010 ghc-options: -fwarn-unused-imports -fwarn-unused-binds test-suite vectortiles-test- type: exitcode-stdio-1.0-- build-depends: base >=4.9 && <4.10- , tasty >= 0.10.1.2- , tasty-hunit >= 0.9.2- , text >=1.2 && <1.3- , vectortiles- , protobuf- , bytestring- , cereal >= 0.5 && < 0.6- , hex >= 0.1 && < 0.2- , vector-- hs-source-dirs: test- main-is: Test.hs- default-language: Haskell2010- ghc-options: -Wall -threaded+ type: exitcode-stdio-1.0+ build-depends:+ base >=4.9 && <4.10+ , bytestring+ , cereal >=0.5 && <0.6+ , containers+ , protobuf >=0.2.1.1 && <0.3+ , text >=1.2 && <1.3+ , vector >=0.11 && <0.13+ , hex >=0.1 && <0.2+ , tasty >=0.10.1.2+ , tasty-hunit >=0.9.2+ , vectortiles+ hs-source-dirs:+ test+ main-is: Test.hs+ default-language: Haskell2010+ ghc-options: -fwarn-unused-imports -fwarn-unused-binds -threaded benchmark vectortiles-bench type: exitcode-stdio-1.0-- build-depends: base >= 4.9 && < 4.10- , criterion >= 1.1 && < 1.2- , vectortiles- , protobuf- , bytestring- , cereal- , microlens >= 0.4 && < 0.5- , microlens-platform >= 0.3 && < 0.4- , text- , containers-- hs-source-dirs: bench- main-is: Bench.hs- default-language: Haskell2010- ghc-options: -Wall -threaded -O+ build-depends:+ base >=4.9 && <4.10+ , bytestring+ , cereal >=0.5 && <0.6+ , containers+ , protobuf >=0.2.1.1 && <0.3+ , text >=1.2 && <1.3+ , vector >=0.11 && <0.13+ , criterion >=1.1 && <1.3+ , microlens >=0.4 && <0.5+ , microlens-platform >=0.3 && <0.4+ , vectortiles+ hs-source-dirs:+ bench+ main-is: Bench.hs+ default-language: Haskell2010+ ghc-options: -fwarn-unused-imports -fwarn-unused-binds -threaded -O