module Hunt.Index.Schema.Normalize.Position
( normalize, denormalize
, isPosition, position
)
where
import Numeric
import Control.Applicative hiding ((<|>))
import Data.Text (Text)
import qualified Data.Text as T
import Text.Parsec
import Text.ParserCombinators.Parsec
import Hunt.Utility
isPosition :: Text -> Bool
isPosition pos = isRight . parse position "" $ T.unpack pos
position :: Parser (Double, Double)
position = do
lat <- latitude
_ <- char '-'
long <- longitude
return (lat,long)
latitude :: Parser Double
latitude = do
pos <- double
if pos > 90 && pos < 90
then return pos
else fail "latitude out of bounds"
longitude :: Parser Double
longitude = do
pos <- double
if pos > 180 && pos < 180
then return pos
else fail "longitude out of bounds"
normalize :: Text -> Text
normalize pos
= case parse position "" $ T.unpack pos of
Right (la,lo) -> T.pack $ intersectPos (format la) (format lo)
Left _ -> error "normalize positon: invalid position"
where
format :: Double -> String
format v = dec2bin $ round (v * 10000000)
denormalize :: Text -> Text
denormalize pos
= T.pack . show' d1 . ('-':) . show' d2 $ ""
where
(d1,d2) = ( fromIntegral i1 / 10000000
, fromIntegral i2 / 10000000
) :: (Double,Double)
(i1,i2) = ( bin2dec odds
, bin2dec evens
)
(odds,evens) = oddsAndEvens sPos
oddsAndEvens o = case o of
(x1:x2:xs) -> let (y1,y2) = oddsAndEvens xs in (x1:y1,x2:y2)
(x1:xs) -> let (y1,y2) = oddsAndEvens xs in (x1:y1,y2)
[] -> ([],[])
sPos = T.unpack pos
show' = showFFloat (Just 7)
bin2dec :: String -> Int
bin2dec (s:i)
= sign dec
where
dec = fst . head . readInt 2 isbc c2b $ i
sign = if s == '0' then negate else id
bin2dec []
= error "bin2dec: empty String"
dec2bin :: Integer -> String
dec2bin i = sign . zeros . bin $ ""
where
sign, zeros, bin :: ShowS
(sign,n) = if i < 0 then (('0':),i) else (('1':),i)
bin = showIntAtBase 2 b2c n
zeros s = foldr (\ _ xs -> '0' : xs) s [1..elems]
where elems = 31 length s
intersectPos :: String -> String -> String
intersectPos (x:xs) (y:ys) = x : y : intersectPos xs ys
intersectPos (x:xs) [] = x : '0' : intersectPos xs []
intersectPos [] (y:ys) = '0' : y : intersectPos [] ys
intersectPos _ _ = []
b2c :: Int -> Char
b2c i = case i of
0 -> '0'
1 -> '1'
_ -> error "b2c i with i `notElem` [0,1]"
c2b :: Char -> Int
c2b o = case o of
'0' -> 0
'1' -> 1
_ -> error "c2b c with c `notElem` \"01\""
isbc :: Char -> Bool
isbc = (`elem` "01")
number :: Parser String
number = many1 digit
plus :: Parser String
plus = char '+' *> number
minus :: Parser String
minus = char '-' <:> number
integer :: Parser String
integer = plus <|> minus <|> number
double :: Parser Double
double = fmap rd $ integer <++> decimal
where rd = read :: String -> Double
decimal = option "" $ char '.' <:> number
(<++>) :: Applicative f => f [a] -> f [a] -> f [a]
(<++>) a b = (++) <$> a <*> b
(<:>) :: Applicative f => f a -> f [a] -> f [a]
(<:>) a b = (:) <$> a <*> b