module Data.Geohash
( encode
, decode
, decode_
) where
import Data.Bits
import Data.Array
import Data.Char
import Data.List
b32chr = "0123456789bcdefghjkmnpqrstuvwxyz"
b32 = array (0, l) $ zip [0..l] b32chr
where l = length b32chr
b32_ = array (48, 122) $ [(i, indexOfChr (chr i)) | i <- [48..122]]
where indexOfChr c = maybe (1) id (elemIndex c b32chr)
bools2bits bs =
foldl (.|.) 0 $ bits bs 0
where bits [] _ = [0]
bits (True:bs) pos = bit pos:bits bs (pos + 1)
bits (False:bs) pos = 0:bits bs (pos + 1)
bits2bools bs =
case bs .&. 1 of
1 -> True:bits2bools bs'
0 -> False:bits2bools bs'
where bs' = bs `shiftR` 1
b32encode bits =
b32!index:b32encode next
where
(this, next) = splitAt 5 bits
index :: Int
index = bools2bits $ reverse this
b32decode :: String -> Maybe [Bool]
b32decode s =
if all wellDefined $ map ord s
then Just $ decode s
else Nothing
where
wellDefined ix =
if inRange (bounds b32_) ix
then b32_!ix /= 1
else False
decode [] = []
decode (c:cs) =
(reverse . take 5 $ bits2bools bits) ++ decode cs
where bits = b32_!(ord c)
bitstring (beg, end) x
| x > mid = True:bitstring (mid, end) x
| otherwise = False:bitstring (beg, mid) x
where
mid = beg + ((end beg)/2)
unbitstring (beg, end) [] = (beg, end)
unbitstring (beg, end) (x:xs)
| x = unbitstring (mid, end) xs
| otherwise = unbitstring (beg, mid) xs
where
mid = beg + ((end beg)/2)
encode :: (Fractional a, Ord a)
=> Int
-> (a, a)
-> Maybe String
encode precision (lat, lon) =
if inRange (180, 180) lon && inRange (90, 90) lat
then Just $ take precision $ b32encode $ interleave lonBits latBits
else Nothing
where
inRange (beg, end) x = x >= beg && x <= end
interleave (a:as) bs = a:(interleave' as bs)
interleave' as (b:bs) = b:(interleave as bs)
lonBits = bitstring (180, 180) lon
latBits = bitstring (90 , 90) lat
decode :: (Fractional a)
=> String
-> Maybe (a, a)
decode geohash =
case decode_ geohash of
Just ((latmin, latmax), (lonmin, lonmax)) ->
Just (latmin + (latmax latmin) / 2, lonmin + (lonmax lonmin) / 2)
Nothing -> Nothing
decode_ :: (Fractional a)
=> String
-> Maybe ((a, a), (a, a))
decode_ geohash =
case b32decode geohash of
Just bits ->
let (lonBits, latBits) = deinterleave bits in
Just $ (unbitstring (90, 90) latBits,
unbitstring (180, 180) lonBits)
Nothing ->
Nothing
where
deinterleave xs@(_:ys) = (deinterleave' xs, deinterleave' ys)
deinterleave' (x:_:xs) = x:deinterleave' xs
deinterleave' (x:_) = [x]
deinterleave' [] = []