diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Lorne Applebaum + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/googlepolyline.cabal b/googlepolyline.cabal new file mode 100644 --- /dev/null +++ b/googlepolyline.cabal @@ -0,0 +1,40 @@ +-- Initial googlepolyline.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: googlepolyline +version: 0.1.0.0 +synopsis: Google Polyline Encoder/Decoder +-- description: +license: MIT +license-file: LICENSE +author: Lorne Applebaum +maintainer: me@lorne.me +-- copyright: +category: Data, Text +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Data.Text.GooglePolyline + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8 + , bytestring >= 0.10 && <0.11 + , text >= 1.2 && <1.3 + hs-source-dirs: src + default-language: Haskell2010 + +Test-Suite test-googlepolyline + type: exitcode-stdio-1.0 + hs-source-dirs: tests, src + build-depends: base >=4.7 && <4.8 + , bytestring >= 0.10 && <0.11 + , text >= 1.2 && <1.3 + , HUnit >= 1.2 && <1.3 + , QuickCheck >= 2.7 && <2.8 + , test-framework-hunit >= 0.3 && <0.4 + , test-framework-quickcheck2 >= 0.3 && <0.4 + , test-framework >= 0.8 && <0.9 + main-is: Tests.hs + default-language: Haskell2010 diff --git a/src/Data/Text/GooglePolyline.hs b/src/Data/Text/GooglePolyline.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/GooglePolyline.hs @@ -0,0 +1,123 @@ +{-| + +Provides encoding and decoding of Google Polyline text which is used +in the Google Maps API. A description of the polyline format and +algorithm can be found at + +. + +-} + +module Data.Text.GooglePolyline ( LatLong(..), encode, decode ) + where + +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Char as C +import Data.Bits +import Data.Int ( Int32 ) + +-- | Type to encapsulate latitude/longitude pairs. +data LatLong = LatLong + { latitude :: Double + , longitude :: Double + } deriving ( Show, Eq ) + +toInts :: BSC.ByteString -> [ Int32 ] +toInts = map fromIntegral . BS.unpack + +-- Step 11 +toChrs :: [ Int32 ] -> T.Text +toChrs = T.pack . map ( C.chr . fromIntegral ) + +sub63 :: [ Int32 ] -> [ Int32 ] +sub63 = map ( (-63) + ) + +-- Step 10 +add63 :: [ Int32 ] -> [ Int32 ] +add63 = map ( 63 + ) + +splitChunk :: [ Int32 ] -> ( [ Int32 ], [ Int32 ] ) +splitChunk is = let (a,b) = span ( >= 0x20 ) is in + (a ++ [head b], tail b ) + +-- Step 8 and 9 +delimChunk :: [ Int32 ] -> [ Int32 ] +delimChunk is = map ( .|. 0x20) ( init is ) ++ [ last is ] + +dechunk :: [ Int32 ] -> Int32 +dechunk is = let withShifts = zip is [0,5..] + in + sum $ map ( \(c,s) -> shift (c .&. 0x1F) s ) withShifts + +-- Step 6 and 7 +enchunk :: Int32 -> [ Int32 ] +enchunk 0 = [ 0 ] -- Special case for 0. Code below would result in an empty. +enchunk i = + let shifts = [ 0,5.. ] + shifted = takeWhile (>0) $ map ( \s -> shift i (-s) ) shifts + in + map ( .&. 0x1F ) shifted + +-- Inverse of negEnc +negDec :: Int32 -> Int32 +negDec i = let x = shift i (-1) in + if testBit i 0 then complement x else x + +-- Google steps 3 to 5 +negEnc :: Int32 -> Int32 +negEnc i = let x = shift i 1 in + if i < 0 then complement x else x + +toDouble :: Int32 -> Double +toDouble x = fromIntegral x / 1e5 + +fromDouble :: Double -> Int32 +fromDouble x = round ( x * 1e5 ) + +oneCoordOp :: [Int32] -> Double +oneCoordOp = toDouble . negDec . dechunk + +oneCoordEnc :: Double -> T.Text +oneCoordEnc = toChrs . add63 . delimChunk . enchunk . negEnc . fromDouble + +stringPrep :: BSC.ByteString -> [ Int32 ] +stringPrep = sub63 . toInts + +toChunks :: [ Int32 ] -> [ [Int32] ] +toChunks [] = [] +toChunks xs = let (c,cs) = splitChunk xs in + c : toChunks cs + +stringToCoords :: BSC.ByteString -> [ Double ] +stringToCoords = map oneCoordOp . toChunks . stringPrep + +makePairs :: [ Double ] -> [ LatLong ] +makePairs [] = [] +makePairs (d1:d2:ds) = LatLong d1 d2 : makePairs ds + +catPairs :: [ LatLong ] -> [ Double ] +catPairs [] = [] +catPairs ( LatLong a b : xs ) = a : b : catPairs xs + +addPair :: LatLong -> LatLong -> LatLong +addPair (LatLong x1 y1) (LatLong x2 y2) = LatLong (x1 + x2) (y1 + y2) + +subPair :: LatLong -> LatLong -> LatLong +subPair (LatLong x1 y1) (LatLong x2 y2) = LatLong (x1 - x2) (y1 - y2) + +-- inverse of ( scanl1 addPair ) +adjDiff :: [ LatLong ] -> [ LatLong ] +adjDiff p = zipWith subPair p (LatLong 0 0:p) + +-- | Decodes Google Polyline text to a sequence of Latitude/Longitude +-- points. Inverse of 'encode'. +decode :: T.Text -> [ LatLong ] +decode = scanl1 addPair . makePairs . stringToCoords . TE.encodeUtf8 + +-- | Encodes a sequence of Latitude/Longitude points into Google +-- Polyline text. Inverse of 'decode'. +encode :: [ LatLong ] -> T.Text +encode = T.concat . fmap oneCoordEnc . catPairs . adjDiff diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,30 @@ +import Units +import QuickCheck + +import Test.Framework ( defaultMain, testGroup ) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +main :: IO () +main = defaultMain tests + +tests = [ + testGroup "Unit Tests" [ + testCase "North West Point-Enc" singlePointNWenc + , testCase "North East Point-Enc" singlePointNEenc + , testCase "South West Point-Enc" singlePointSWenc + , testCase "South East Point-Enc" singlePointSEenc + , testCase "Zero Point-Enc" singlePointZeroEnc + , testCase "Three Point Path-Enc" threePointPathEnc + , testCase "North West Point-Dec" singlePointNWdec + , testCase "North East Point-Dec" singlePointNEdec + , testCase "South West Point-Dec" singlePointSWdec + , testCase "South East Point-Dec" singlePointSEdec + , testCase "Zero Point-Dec" singlePointZeroDec + , testCase "Three Point Path-Dec" threePointPathDec + ] + , + testGroup "QuickCheck" [ + testProperty "Decode as inverse" prop_decodeInverse + ] + ]