diff --git a/Geography/VectorTile.hs b/Geography/VectorTile.hs new file mode 100644 --- /dev/null +++ b/Geography/VectorTile.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | +-- Module : Geography.VectorTile +-- Copyright : (c) Azavea, 2016 +-- License : Apache 2 +-- Maintainer: Colin Woodbury +-- +-- 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 } diff --git a/Geography/VectorTile/Geometry.hs b/Geography/VectorTile/Geometry.hs new file mode 100644 --- /dev/null +++ b/Geography/VectorTile/Geometry.hs @@ -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 + +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 diff --git a/Geography/VectorTile/Raw.hs b/Geography/VectorTile/Raw.hs new file mode 100644 --- /dev/null +++ b/Geography/VectorTile/Raw.hs @@ -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 +-- +-- 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 diff --git a/Geography/VectorTile/Util.hs b/Geography/VectorTile/Util.hs new file mode 100644 --- /dev/null +++ b/Geography/VectorTile/Util.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Geography.VectorTile.Util +-- Copyright : (c) Azavea, 2016 +-- License : Apache 2 +-- Maintainer: Colin Woodbury + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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!" diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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" +-} diff --git a/test/linestring.mvt b/test/linestring.mvt new file mode 100644 --- /dev/null +++ b/test/linestring.mvt @@ -0,0 +1,5 @@ +" + OneLineString " + + +ÖÖ(€ x diff --git a/test/onepoint.mvt b/test/onepoint.mvt new file mode 100644 --- /dev/null +++ b/test/onepoint.mvt @@ -0,0 +1,4 @@ + +OnePoint" + +(€ x diff --git a/test/polygon.mvt b/test/polygon.mvt new file mode 100644 Binary files /dev/null and b/test/polygon.mvt differ diff --git a/test/roads.mvt b/test/roads.mvt new file mode 100644 Binary files /dev/null and b/test/roads.mvt differ diff --git a/vectortiles.cabal b/vectortiles.cabal new file mode 100644 --- /dev/null +++ b/vectortiles.cabal @@ -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