content: -- ----------------------------------------------------------------------------
  {- |
    Normalization and validation for geographic positions.
  -}
  -- ----------------------------------------------------------------------------
  
  module Hunt.Index.Schema.Normalize.Position
         ( normalize
         , denormalize
         , isPosition
         , position
         )
  where
  
  import           Data.Text (Text)
  import qualified Data.Text as T
  import           Hunt.Utility
  import           Numeric
  import           Text.Parsec
  import           Text.ParserCombinators.Parsec
  
  -- ------------------------------------------------------------
  -- validator
  -- ------------------------------------------------------------
  
  -- | Checks if value is a valid position.
  --   A valid position has a format like "double-double"/"latitude-longitude".
  isPosition :: Text -> Bool
  isPosition pos = isRight . parse position "" $ T.unpack pos
  
  -- | Parse a coordinate.
  position :: Parser (Double, Double)
  position = do
    lat  <- latitude
    _ <- char '-'
    long <- longitude
    return (lat,long)
  
  -- | Parse a latitude value.
  latitude :: Parser Double
  latitude = do
    pos <- double
    if pos > -90 && pos < 90
      then return pos
      else fail "latitude out of bounds"
  
  -- | Parse a longitude value.
  longitude :: Parser Double
  longitude = do
    pos <- double
    if pos > -180 && pos < 180
      then return pos
      else fail "longitude out of bounds"
  
  -- ------------------------------------------------------------
  -- normalizer
  -- ------------------------------------------------------------
  
  -- | Normalizes valid position
  --   A valid position has a format like "double-double"/"latitude-longitude".
  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)
  
  
  -- | Denormalizes internal position into valid position.
  --   A valid position has a format like "double-double"/"latitude-longitude".
  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)
  
  -- ------------------------------------------------------------
  -- normalizer helper
  -- ------------------------------------------------------------
  
  -- | Decimal representation of a binary encoded string.
  --
  --   /Note/: The input needs to be valid.
  --           @length input >= 2 && all (`elem` "01") input@
  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"
  
  -- | Convert Integer to Binary and normalize result
  --   with leading zeros to a length of 32 characters.
  --   The first character is the sign: 0 -> negative.
  --
  --   /Note/: The input needs to be valid.
  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
  
  -- | Merge two lists starting with an element of the first list, then one
  --   of the second list and so on.
  --   Works like @concat . zipWith (\a b -> a:b:[])@, but pads with zeros.
  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 _      _      = []
  
  {-
  -- ShowS version with accumulator - unnecessary
  intersectPos :: String -> String -> ShowS
  intersectPos la lo = foldPos' la lo id
      where
      foldPos' (x:xs) (y:ys) a = foldPos' xs ys (\s -> a (x   : y   : s))
      foldPos' (x:xs) []     a = foldPos' xs "" (\s -> a (x   : '0' : s))
      foldPos' []     (y:ys) a = foldPos' "" ys (\s -> a ('0' : y   : s))
      foldPos' []    []      a = a
  -}
  
  -- ------------------------------------------------------------
  -- Int to binary and vice versa
  -- ------------------------------------------------------------
  
  -- | Binary integer to character.
  b2c :: Int -> Char
  b2c i = case i of
    0 -> '0'
    1 -> '1'
    _ -> error "b2c i with i `notElem` [0,1]"
  
  -- | Character to binary integer.
  c2b :: Char -> Int
  c2b o = case o of
    '0' -> 0
    '1' -> 1
    _ -> error "c2b c with c `notElem` \"01\""
  
  -- | Is the character a binary number.
  isbc :: Char -> Bool
  isbc = (`elem` ("01" :: String))
  
  -- ------------------------------------------------------------
  -- parser helper
  -- ------------------------------------------------------------
  
  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
  
  -- ------------------------------------------------------------
  