{-# LANGUAGE OverloadedStrings#-}
{-# LANGUAGE DeriveFunctor #-}

module Data.WKT.Polygon (module Data.WKT.Polygon) where

import Data.WKT.Classes
import Data.WKT.Point
import Data.WKT.LineString

import Data.List (intercalate)
import Data.WKT.Helpers (generateZMString, zmParser)
import Data.Text (pack, Text)
import Data.Attoparsec.Text (parseOnly, skipSpace, asciiCI, Parser)
import Control.Applicative ((<|>))

newtype Polygon a = Polygon [LineString a]
    deriving ((forall a b. (a -> b) -> Polygon a -> Polygon b)
-> (forall a b. a -> Polygon b -> Polygon a) -> Functor Polygon
forall a b. a -> Polygon b -> Polygon a
forall a b. (a -> b) -> Polygon a -> Polygon b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Polygon a -> Polygon b
fmap :: forall a b. (a -> b) -> Polygon a -> Polygon b
$c<$ :: forall a b. a -> Polygon b -> Polygon a
<$ :: forall a b. a -> Polygon b -> Polygon a
Functor, Polygon a -> Polygon a -> Bool
(Polygon a -> Polygon a -> Bool)
-> (Polygon a -> Polygon a -> Bool) -> Eq (Polygon a)
forall a. Eq a => Polygon a -> Polygon a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Polygon a -> Polygon a -> Bool
== :: Polygon a -> Polygon a -> Bool
$c/= :: forall a. Eq a => Polygon a -> Polygon a -> Bool
/= :: Polygon a -> Polygon a -> Bool
Eq)

instance Show a => Show (Polygon a) where
    show :: Polygon a -> String
show (Polygon [LineString a]
polygon) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
rings
        where
            rings :: [String]
rings = (LineString a -> String) -> [LineString a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(LineString [Point a]
ring) -> String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Point a -> String
forall a. Show a => a -> String
show (Point a -> String) -> [Point a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point a]
ring) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")") [LineString a]
polygon

instance Show a => ToWKT (Polygon a) where
    toWKT :: Polygon a -> Text
toWKT Polygon a
polygon = Text
"Polygon" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
zmString Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Polygon a -> String
forall a. Show a => a -> String
show Polygon a
polygon) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        where
            Polygon [LineString a]
rings = Polygon a
polygon
            (LineString [Point a]
firstLine) = [LineString a] -> LineString a
forall a. HasCallStack => [a] -> a
head [LineString a]
rings
            first :: Point a
first = [Point a] -> Point a
forall a. HasCallStack => [a] -> a
head [Point a]
firstLine
            z' :: Maybe a
z' = Point a -> Maybe a
forall a. Point a -> Maybe a
z Point a
first
            m' :: Maybe a
m' = Point a -> Maybe a
forall a. Point a -> Maybe a
m Point a
first

            zmString :: Text
zmString = Maybe a -> Maybe a -> Text
forall a. Maybe a -> Maybe a -> Text
generateZMString Maybe a
z' Maybe a
m'

instance Eq a => Valid (Polygon a) where
    isValid :: Polygon a -> Bool
isValid (Polygon [LineString a]
lines') = Bool
validLines Bool -> Bool -> Bool
&& Bool
validPolygon
        where
            validLines :: Bool
validLines = (LineString a -> Bool) -> [LineString a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LineString a -> Bool
forall a. Valid a => a -> Bool
isValid [LineString a]
lines'
            validPolygon :: Bool
validPolygon = (LineString a -> Bool) -> [LineString a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(LineString [Point a]
line) -> [Point a] -> Point a
forall a. HasCallStack => [a] -> a
head [Point a]
line Point a -> Point a -> Bool
forall a. Eq a => a -> a -> Bool
== [Point a] -> Point a
forall a. HasCallStack => [a] -> a
last [Point a]
line) [LineString a]
lines'

instance FromWKT Polygon where
    fromWKT :: Text -> Polygon Double
fromWKT = (String -> Polygon Double)
-> (Polygon Double -> Polygon Double)
-> Either String (Polygon Double)
-> Polygon Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Polygon Double
forall a. HasCallStack => String -> a
error (String -> Polygon Double) -> ShowS -> String -> Polygon Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. Show a => a -> String
show) Polygon Double -> Polygon Double
forall a. a -> a
id (Either String (Polygon Double) -> Polygon Double)
-> (Text -> Either String (Polygon Double))
-> Text
-> Polygon Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Polygon Double) -> Text -> Either String (Polygon Double)
forall a. Parser a -> Text -> Either String a
parseOnly Parser (Polygon Double)
forall (a :: * -> *). ParseableFromWKT a => Parser (a Double)
wktParser

instance ParseableFromWKT Polygon where
    wktParser :: Parser (Polygon Double)
wktParser = do
        Parser ()
skipSpace
        Text
_ <- Text -> Parser Text Text
asciiCI Text
"POLYGON"
        (Text
zFlag, Text
mFlag) <- Parser (Text, Text)
zmParser
        Text
_ <- Parser Text Text
"("
        Text -> Text -> Parser (Polygon Double)
parsePolygon Text
zFlag Text
mFlag
        
parsePolygon :: Text -> Text -> Parser (Polygon Double)
parsePolygon :: Text -> Text -> Parser (Polygon Double)
parsePolygon Text
zFlag Text
mFlag = [LineString Double] -> Polygon Double
forall a. [LineString a] -> Polygon a
Polygon ([LineString Double] -> Polygon Double)
-> Parser Text [LineString Double] -> Parser (Polygon Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Parser Text [LineString Double]
ringsParser Text
zFlag Text
mFlag
    where
        ringsParser :: Text -> Text -> Parser Text [LineString Double]
ringsParser Text
zFlag' Text
mFlag' = do
            Parser ()
skipSpace
            Text
_ <- Parser Text Text
"("
            LineString Double
newRing <- Text -> Text -> Parser (LineString Double)
parseLineString Text
zFlag' Text
mFlag'
            Parser ()
skipSpace
            Text
closing <- Parser Text Text
")" Parser Text Text -> Parser Text Text -> Parser Text Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Text
""
            if Text
closing Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"" then
                [LineString Double] -> Parser Text [LineString Double]
forall a. a -> Parser Text a
forall (m :: * -> *) a. Monad m => a -> m a
return [LineString Double
newRing]
            else do
                    (LineString Double
newRing LineString Double -> [LineString Double] -> [LineString Double]
forall a. a -> [a] -> [a]
:) ([LineString Double] -> [LineString Double])
-> Parser Text [LineString Double]
-> Parser Text [LineString Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Text
"," Parser Text Text
-> Parser Text [LineString Double]
-> Parser Text [LineString Double]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Text -> Parser Text [LineString Double]
ringsParser Text
zFlag' Text
mFlag')