vectortiles (empty) → 1.0.0
raw patch · 13 files changed
+1379/−0 lines, 13 filesdep +basedep +bytestringdep +cerealsetup-changedbinary-added
Dependencies added: base, bytestring, cereal, containers, criterion, deepseq, hex, protobuf, tasty, tasty-hunit, text, th-printf, transformers, vector, vectortiles
Files
- Geography/VectorTile.hs +353/−0
- Geography/VectorTile/Geometry.hs +255/−0
- Geography/VectorTile/Raw.hs +142/−0
- Geography/VectorTile/Util.hs +36/−0
- LICENSE +202/−0
- Setup.hs +2/−0
- bench/Bench.hs +43/−0
- test/Test.hs +245/−0
- test/linestring.mvt +5/−0
- test/onepoint.mvt +4/−0
- test/polygon.mvt binary
- test/roads.mvt binary
- vectortiles.cabal +92/−0
+ Geography/VectorTile.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- 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" (here)+-- 2. "Geography.VectorTile.Geometry"+-- 3. "Geography.VectorTile.Raw"+--+-- == Usage+--+-- This library reads and writes strict `ByteString`s. Given some legal+-- VectorTile file called @roads.mvt@:+--+-- > import qualified Data.ByteString as BS+-- > import Data.Text (Text)+-- > import Geography.VectorTile+-- > import qualified Geography.VectorTile.Raw as R+-- >+-- > -- | 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 $ R.decode mvt >>= tile+--+-- Or encode a `VectorTile` back into a `ByteString`:+--+-- > roadsBytes :: VectorTile -> BS.ByteString+-- > roadsBytes = R.encode . untile++module Geography.VectorTile+ ( -- * Types+ VectorTile(..)+ , Layer(..)+ , Feature(..)+ , Val(..)+ -- * Protobuf Conversions+ -- ** From Protobuf+ -- | Generally the `tile` function is the only one needed here. Usage:+ --+ -- > import qualified Geography.VectorTile.Raw as R+ -- >+ -- > R.decode someBytes >>= tile+ --+ -- Note that since the "Data.ProtocolBuffers" library does not handle default+ -- values, we handle those specifically defined in /vector_tile.proto/+ -- explicitely here. See:+ --+ -- https://github.com/mapbox/vector-tile-spec/blob/master/2.1/vector_tile.proto+ , tile+ , layer+ , features+ , value+ -- ** To Protobuf+ -- | To convert from high-level data back into a form that can be encoded+ -- into raw protobuf bytes, use:+ --+ -- > import qualified Geography.VectorTile.Raw as R+ -- >+ -- > R.encode $ untile someTile+ --+ -- This is a pure process and will succeed every time.+ , untile+ , unlayer+ , unfeature+ , unval+ -- * 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.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++---++{- Types -}++-- | A high-level representation of a Vector Tile. At its simplest, a tile+-- is just a list of `Layer`s.+--+-- There is potential to implement `_layers` as a `M.Map`, with its String-based+-- `name` as a key.+newtype VectorTile = VectorTile { _layers :: V.Vector Layer } deriving (Eq,Show,Generic)++-- | > Lens' VectorTile (Vector Layer)+layers :: Functor f => (V.Vector Layer -> f (V.Vector 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 => (Layer -> f Int) -> Layer -> f Layer+version f l = fmap (\v -> l { _version = v }) $ f l+{-# INLINE version #-}++-- | > Lens' Layer Text+name :: Functor f => (Layer -> f Text) -> Layer -> f Layer+name f l = fmap (\v -> l { _name = v }) $ f l+{-# INLINE name #-}++-- | > Lens' Layer (Vector (Feature Point))+points :: Functor f => (Layer -> f (V.Vector (Feature Point))) -> Layer -> f Layer+points f l = fmap (\v -> l { _points = v }) $ f l+{-# INLINE points #-}++-- | > Lens' Layer (Vector (Feature LineString)))+linestrings :: Functor f => (Layer -> f (V.Vector (Feature LineString))) -> Layer -> f Layer+linestrings f l = fmap (\v -> l { _linestrings = v }) $ f l+{-# INLINE linestrings #-}++-- | > Lens' Layer (Vector (Feature Polygon)))+polygons :: Functor f => (Layer -> f (V.Vector (Feature Polygon))) -> Layer -> f Layer+polygons f l = fmap (\v -> l { _polygons = v }) $ f l+{-# INLINE polygons #-}++-- | > Lens' Layer Int+extent :: Functor f => (Layer -> f Int) -> Layer -> f Layer+extent f l = fmap (\v -> l { _extent = v }) $ f 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 => (Feature g -> f Int) -> Feature g -> f (Feature g)+featureId f l = fmap (\v -> l { _featureId = v }) $ f l+{-# INLINE featureId #-}++-- | > Lens' (Feature g) (Map Text Val)+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+{-# INLINE metadata #-}++-- | > Lens' (Feature g) (Vector g)+geometries :: Functor f => (Feature g -> f (V.Vector g)) -> Feature g -> f (Feature g)+geometries f l = fmap (\v -> l { _geometries = v }) $ f 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,Show,Generic)++instance NFData Val++{- FROM PROTOBUF -}++-- | Convert a `R.RawVectorTile` of parsed protobuf data into a useable+-- `VectorTile`.+tile :: R.RawVectorTile -> Either Text VectorTile+tile = fmap (VectorTile . V.fromList) . mapM layer . getField . R.layers++-- | Convert a single `R.RawLayer` of parsed protobuf data into a useable+-- `Layer`.+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++-- | Convert a list of `R.RawFeature`s of parsed protobuf data into `V.Vector`s+-- of each of the three legal `Geometry` 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. `R.RawLayer`s and `R.RawFeature`s+-- are strongly coupled at the protobuf level. In order to achieve higher+-- compression ratios, `R.RawLayer`s contain all metadata in key/value lists+-- to be shared across their `R.RawFeature`s, while those `R.RawFeature`s store only+-- indices into those lists. As a result, this function needs to be passed+-- those key/value lists from the parent `R.RawLayer`, and a more isomorphic:+--+-- > feature :: Geometry g => RawFeature -> Either Text (Feature g)+--+-- is not possible.+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':ls':polys':_) = groupBy sameGeom $ sortOn geomBias fs -- ok ok ok+ 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++-- | Convert a `R.RawVal` parsed from protobuf data into a useable+-- `Val`. The higher-level `Val` type better expresses the mutual exclusivity+-- of the /Value/ types.+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++{- TO PROTOBUF -}++-- | Encode a high-level `VectorTile` back into its mid-level+-- `R.RawVectorTile` form.+untile :: VectorTile -> R.RawVectorTile+untile vt = R.RawVectorTile { R.layers = putField . V.toList . V.map unlayer $ _layers vt }++-- Has to get back all its metadata from its features+-- | Encode a high-level `Layer` back into its mid-level `R.RawLayer` form.+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 -- `nub` is O(n^2)+ f = V.foldr (\x acc -> M.keysSet (_metadata x) : acc) []+ g = V.foldr (\x acc -> M.elems (_metadata x) : acc) []++-- | Encode a high-level `Feature` back into its mid-level `R.RawFeature` form.+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)++-- | Encode a high-level `Val` back into its mid-level `R.RawVal` form.+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 }++-- | A `R.RawVal` with every entry set to `Nothing`.+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 }
+ Geography/VectorTile/Geometry.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# 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+ Geometry(..)+ , Point(..)+ , LineString(..)+ , Polygon(..)+ -- ** Operations+ , area+ , surveyor+ , distance+ -- * Commands+ , Command(..)+ , commands+ , uncommands+ -- * Z-Encoding+ , zig+ , unzig+ ) where++import Control.DeepSeq (NFData)+import Control.Monad.Trans.State.Lazy+import Data.Bits+import Data.Foldable (foldlM)+import Data.Int+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import Data.Word+import GHC.Generics (Generic)+import Geography.VectorTile.Util+import Text.Printf.TH++---++-- | 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)++-- | Points are just vectors in R2, and thus form a Vector space.+instance Monoid Point where+ mempty = Point 0 0+ (Point a b) `mappend` (Point a' b') = Point (a + a') (b + b')++-- | /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++-- | Any classical type considered a GIS "geometry". These must be able+-- to convert between an encodable list of `Command`s.+class Geometry g where+ fromCommands :: [Command] -> Either Text (V.Vector g)+ toCommands :: V.Vector g -> [Command]++-- | A valid `R.Feature` of points must contain a single `MoveTo` command+-- with a count greater than 0.+instance Geometry Point where+ fromCommands (MoveTo ps : []) = Right . U.convert $ evalState (U.mapM expand ps) (0,0)+ fromCommands (c:_) = Left $ [st|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 `R.Feature` 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 Geometry LineString where+ fromCommands cs = evalState (f cs) (0,0)+ where f (MoveTo p : LineTo ps : rs) = fmap . V.cons <$> ls <*> f rs+ where ls = 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 (LineString ps) = do+ curr <- get+ let (h,t) = (U.head ps, U.tail ps)+ put h+ l <- U.mapM collapse t+ pure [MoveTo $ U.singleton (x h - x curr, y h - y curr), LineTo l]++-- | A valid `R.Feature` 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 Geometry 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 = (x h + x curr, y h + y curr)+ po <- flip U.snoc here <$> U.mapM expand (U.cons h ps)+ fmap (V.cons (Polygon po V.empty)) <$> f rs+ f [] = pure $ Right V.empty+ f _ = pure . Left $ [st|Polygon decode: Invalid command sequence given: %s|] (show cs)+ g acc p | area p > 0 = do -- New external rings.+ curr <- get+ put p+ pure $ V.snoc acc curr+ | otherwise = do -- Next internal ring.+ modify (\s -> s { inner = V.snoc (inner s) p })+ pure acc++ toCommands ps = concat $ evalState (mapM f ps) (0,0)+ where f (Polygon p i) = do+ curr <- get+ let (h,t) = (U.head p, U.tail $ U.init p) -- Exclude the final point.+ put h+ l <- U.mapM collapse t+ let cs = [MoveTo $ U.singleton (x h - x curr, y h - y curr), LineTo 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 T.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: " <> T.pack (show m)+ (m,_) -> Left $ [st|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 T.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.++{- UTIL -}++-- | 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) Point+expand p = do+ curr <- get+ let here = (x p + x curr, y p + 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 :: Point -> State (Int,Int) (Int,Int)+collapse p = do+ curr <- get+ let diff = (x p - x curr, y p - y curr)+ put p+ pure diff
+ Geography/VectorTile/Raw.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Geography.VectorTile.Raw+-- Copyright : (c) Azavea, 2016+-- 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` for the user-friendly version.+--+-- Please import this module @qualified@ to avoid namespace clashes:+--+-- > import qualified Geography.VectorTile.Raw as R++module Geography.VectorTile.Raw+ ( -- * Types+ RawVectorTile(..)+ , RawLayer(..)+ , RawVal(..)+ , RawFeature(..)+ , GeomType(..)+ , Geom(..)+ -- * Encoding / Decoding+ , decode+ , encode+ , decodeIO+ , encodeIO+ ) where++import Control.DeepSeq (NFData)+import qualified Data.ByteString as BS+import Data.Int+import Data.ProtocolBuffers hiding (decode, encode)+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Text (Text, pack)+import Data.Word+import GHC.Generics (Generic)+import qualified Geography.VectorTile.Geometry as G++---++-- | 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++-- | A `Geom` can recover its `GeomType` from its `G.Geometry` instance.+class G.Geometry g => Geom g where+ -- | The @g@ here is a proxy argument to discern the type.+ geomType :: g -> GeomType++instance Geom G.Point where+ geomType _ = Point++instance Geom G.LineString where+ geomType _ = LineString++instance Geom G.Polygon where+ geomType _ = Polygon++-- | 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/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
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,43 @@+module Main where++import Control.Monad ((>=>))+import Criterion.Main+import qualified Data.ByteString as BS+import Geography.VectorTile+import qualified Geography.VectorTile.Raw as R++---++main :: IO ()+main = do+ op <- BS.readFile "test/onepoint.mvt"+ ls <- BS.readFile "test/linestring.mvt"+ rd <- BS.readFile "test/roads.mvt"+ let op' = fromRight $ R.decode op >>= tile+ ls' = fromRight $ R.decode ls >>= tile+ rd' = fromRight $ R.decode rd >>= tile+ defaultMain [ bgroup "Decoding"+ [ bgroup "onepoint.mvt" $ decodes op+ , bgroup "linestring.mvt" $ decodes ls+ , bgroup "roads.mvt" $ decodes rd+ ]+ , bgroup "Encoding"+ [ bgroup "Point" $ encodes op'+ , bgroup "LineString" $ encodes ls'+ , bgroup "Roads" $ encodes rd'+ ]+ ]++decodes :: BS.ByteString -> [Benchmark]+decodes bs = [ bench "Raw.VectorTile" $ nf R.decode bs+ , bench "VectorTile" $ nf (R.decode >=> tile) bs+ ]++encodes :: VectorTile -> [Benchmark]+encodes vt = [ bench "Raw.VectorTile" $ nf untile vt+ , bench "ByteString" $ nf (R.encode . untile) vt+ ]++fromRight :: Either a b -> b+fromRight (Right b) = b+fromRight _ = error "`Left` given to fromRight!"
+ test/Test.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import qualified Data.ByteString as BS+import Data.Hex+import Data.ProtocolBuffers+import Data.Serialize.Get+import Data.Serialize.Put+import qualified Geography.VectorTile.Raw as R+import Test.Tasty+import Test.Tasty.HUnit+import Geography.VectorTile+import Geography.VectorTile.Geometry+import qualified Data.Vector.Unboxed as U++---++main :: IO ()+main = do+ op <- BS.readFile "test/onepoint.mvt"+ ls <- BS.readFile "test/linestring.mvt"+ pl <- BS.readFile "test/polygon.mvt"+ rd <- BS.readFile "test/roads.mvt"+ defaultMain $ suite op ls pl rd++{- SUITES -}++suite :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString -> TestTree+suite op ls pl rd = testGroup "Unit Tests"+ [ testGroup "Protobuf"+ [ testGroup "Decoding"+ [ testCase "onepoint.mvt -> Raw.Tile" $ testOnePoint op+ , testCase "linestring.mvt -> Raw.Tile" $ testLineString ls+-- , testCase "polygon.mvt -> Raw.Tile" $ testPolygon pl+ , testCase "roads.mvt -> Raw.Tile" $ testDecode rd+ , testCase "onepoint.mvt -> VectorTile" $ tileDecode op+ , testCase "linestring.mvt -> VectorTile" $ tileDecode ls+ , testCase "roads.mvt -> VectorTile" $ tileDecode rd+ ]+ , testGroup "Encoding"+ [ testGroup "RawVectorTile <-> VectorTile"+ [ testCase "One Point" $ encodeIso onePoint+ , testCase "One LineString" $ encodeIso oneLineString+ , testCase "One Polygon" $ encodeIso onePolygon+ , testCase "roads.mvt" . encodeIso . fromRight $ R.decode rd+ ]+ ]+ , testGroup "Serialization Isomorphism"+ [ testCase "onepoint.mvt <-> Raw.Tile" $ fromRaw op+ , testCase "linestring.mvt <-> Raw.Tile" $ fromRaw ls+-- , testCase "polygon.mvt <-> Raw.Tile" $ fromRaw pl+ -- , testCase "roads.mvt <-> Raw.Tile" $ fromRaw rd+ , testCase "testTile <-> protobuf bytes" testTileIso+ ]+ ]+ , testGroup "Geometries"+ [ testCase "Z-encoding Isomorphism" zencoding+ , testCase "Command Parsing" commandTest+ , testCase "[Word32] <-> [Command]" commandIso+ , testCase "[Word32] <-> V.Vector Point" pointIso+ , testCase "[Word32] <-> V.Vector LineString" linestringIso+ , testCase "[Word32] <-> V.Vector Polygon (2 ex)" polygonIso+ , testCase "[Word32] <-> V.Vector Polygon (1 ex, 1 in)" polygonIso2+ ]+ ]++testOnePoint :: BS.ByteString -> Assertion+testOnePoint vt = case decodeIt vt of+ Left e -> assertFailure e+ Right t -> t @?= onePoint++testLineString :: BS.ByteString -> Assertion+testLineString vt = case decodeIt vt of+ Left e -> assertFailure e+ Right t -> t @?= oneLineString++testPolygon :: BS.ByteString -> Assertion+testPolygon vt = case decodeIt vt of+ Left e -> assertFailure e+ Right t -> t @?= onePolygon++-- | For testing is decoding succeeded in generally. Makes no guarantee+-- about the quality of the content, only that the parse succeeded.+testDecode :: BS.ByteString -> Assertion+testDecode = assert . isRight . decodeIt++tileDecode :: BS.ByteString -> Assertion+tileDecode bs = case decodeIt bs of+ Left e -> assertFailure e+ Right t -> assert . isRight $ tile t++fromRaw :: BS.ByteString -> Assertion+fromRaw vt = case decodeIt vt of+ Left e -> assertFailure e+ Right l -> hex (encodeIt l) @?= hex vt+-- Right l -> if runPut (encodeMessage l) == vt+-- then assert True+-- else assertString "Isomorphism failed."++testTileIso :: Assertion+testTileIso = case decodeIt pb of+ Right tl -> assertEqual "" tl testTile+ Left e -> assertFailure e+ where pb = encodeIt testTile++decodeIt :: BS.ByteString -> Either String R.RawVectorTile+decodeIt = runGet decodeMessage++encodeIt :: R.RawVectorTile -> BS.ByteString+encodeIt = runPut . encodeMessage++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False++fromRight :: Either a b -> b+fromRight (Right b) = b+fromRight _ = error "`Left` given to fromRight!"++rawTest :: IO (Either String R.RawVectorTile)+rawTest = decodeIt <$> BS.readFile "onepoint.mvt"++encodeIso :: R.RawVectorTile -> Assertion+encodeIso vt = assert . isRight . fmap untile $ tile vt++testTile :: R.RawVectorTile+testTile = R.RawVectorTile $ putField [l]+ where l = R.RawLayer { R.version = putField 2+ , R.name = putField "testlayer"+ , R.features = putField [f]+ , R.keys = putField ["somekey"]+ , R.values = putField [v]+ , R.extent = putField $ Just 4096+ }+ f = R.RawFeature { R.featureId = putField $ Just 0+ , R.tags = putField [0,0]+ , R.geom = putField $ Just R.Point+ , R.geometries = putField [9, 50, 34] -- MoveTo(+25,+17)+ }+ v = R.RawVal { R.string = putField $ Just "Some Value"+ , R.float = putField Nothing+ , R.double = putField Nothing+ , R.int64 = putField Nothing+ , R.uint64 = putField Nothing+ , R.sint = putField Nothing+ , R.bool = putField Nothing+ }++-- | Correct decoding of `onepoint.mvt`+onePoint :: R.RawVectorTile+onePoint = R.RawVectorTile $ putField [l]+ where l = R.RawLayer { R.version = putField 1+ , R.name = putField "OnePoint"+ , R.features = putField [f]+ , R.keys = putField []+ , R.values = putField []+ , R.extent = putField $ Just 4096+ }+ f = R.RawFeature { R.featureId = putField Nothing+ , R.tags = putField []+ , R.geom = putField $ Just R.Point+ , R.geometries = putField [9, 10, 10] -- MoveTo(+5,+5)+ }++-- | Correct decoding of `linestring.mvt`+oneLineString :: R.RawVectorTile+oneLineString = R.RawVectorTile $ putField [l]+ where l = R.RawLayer { R.version = putField 1+ , R.name = putField "OneLineString"+ , R.features = putField [f]+ , R.keys = putField []+ , R.values = putField []+ , R.extent = putField $ Just 4096+ }+ f = R.RawFeature { R.featureId = putField Nothing+ , R.tags = putField []+ , R.geom = putField $ Just R.LineString+ -- MoveTo(+5,+5), LineTo(+1195,+1195)+ , R.geometries = putField [9, 10, 10, 10, 2390, 2390]+ }++-- | Correct decoding of `polygon.mvt`+onePolygon :: R.RawVectorTile+onePolygon = R.RawVectorTile $ putField [l]+ where l = R.RawLayer { R.version = putField 1+ , R.name = putField "OnePolygon"+ , R.features = putField [f]+ , R.keys = putField []+ , R.values = putField []+ , R.extent = putField $ Just 4096+ }+ f = R.RawFeature { R.featureId = putField Nothing+ , R.tags = putField []+ , R.geom = putField $ Just R.Polygon+ -- MoveTo(+2,+2), LineTo(+3,+2), LineTo(-3,+2), ClosePath+ , R.geometries = putField [9, 4, 4, 18, 6, 4, 5, 4, 15]+ }++zencoding :: Assertion+zencoding = assert $ map (unzig . zig) vs @?= vs+ where vs = [0,(-1),1,(-2),2,(-3),3]++commandTest :: Assertion+commandTest = assert $ commands [9,4,4,18,6,4,5,4,15] @?= Right+ [ MoveTo $ U.singleton (2,2)+ , LineTo $ U.fromList [(3,2),(-3,2)]+ , ClosePath ]++commandIso :: Assertion+commandIso = assert $ (uncommands . fromRight $ commands cs) @?= cs+ where cs = [9,4,4,18,6,4,5,4,15]++pointIso :: Assertion+pointIso = cs' @?= cs+ where cs = [17,4,4,6,6]+ cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @Point)++linestringIso :: Assertion+linestringIso = cs' @?= cs+ where cs = [9,4,4,18,6,4,5,4,9,4,4,18,6,4,5,4]+ cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @LineString)++-- | Two external rings+polygonIso :: Assertion+polygonIso = cs' @?= cs+ where cs = [9,4,4,18,6,4,5,4,15,9,4,4,18,6,4,5,4,15]+ cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @Polygon)++-- | One external, one internal+polygonIso2 :: Assertion+polygonIso2 = cs' @?= cs+ where cs = [9,4,4,26,6,0,0,6,5,0,15,9,2,3,26,0,2,2,0,0,1,15]+ cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @Polygon)++{-}+foo :: FilePath -> IO (Either Text VectorTile)+foo bs = do+ mvt <- BS.readFile bs+ pure $ R.decode mvt >>= tile++-- fmap (V.length . layers <$>) $ foo "roads.mvt"+-}
+ test/linestring.mvt view
@@ -0,0 +1,5 @@+"+ OneLineString" +++ÖÖ( x
+ test/onepoint.mvt view
@@ -0,0 +1,4 @@++OnePoint" ++( x
+ test/polygon.mvt view
binary file changed (absent → 34 bytes)
+ test/roads.mvt view
binary file changed (absent → 38364 bytes)
+ vectortiles.cabal view
@@ -0,0 +1,92 @@+-- Initial gaia-vector-tiles.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: vectortiles+version: 1.0.0+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" (high-level types and conversion functions)+ 2. "Geography.VectorTile.Geometry" (typical GIS geometry types)+ 3. "Geography.VectorTile.Raw" (mid-level representation of parsed protobuf data)++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+-- extra-source-files:+cabal-version: >=1.10++extra-source-files: test/roads.mvt+ , test/onepoint.mvt+ , test/linestring.mvt+ , test/polygon.mvt++library+ exposed-modules: Geography.VectorTile+ , Geography.VectorTile.Raw+ , 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.12+ , containers+ , protobuf >= 0.2.1.1 && < 0.3+ , deepseq >= 1.4 && < 1.5+ , th-printf >= 0.3 && < 0.4+ , transformers >= 0.5 && < 0.6+ , cereal >= 0.5 && < 0.6+ , bytestring++ -- hs-source-dirs:+ default-language: Haskell2010+-- ghc-options: -Wall++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++benchmark vectortiles-bench+ type: exitcode-stdio-1.0++ build-depends: base >= 4.9 && < 4.10+ , criterion >= 1.1 && < 1.2+ , vectortiles+ , protobuf+ , bytestring+ , cereal++ hs-source-dirs: bench+ main-is: Bench.hs+ default-language: Haskell2010+ ghc-options: -Wall -threaded -O