{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Data.Geometry.Geos.Raw.Geometry
( Geom(..)
, GeomConst(..)
, Geometry(..)
, GeomTypeId(..)
, withMaybeGeometry
, getSRID
, setSRID
, getTypeName
, getTypeId
, getCoordinateSequence
, getNumCoordinates
, getNumInteriorRings
, getNumGeometries
, getInteriorRingN
, getGeometryN
, getExteriorRing
, createPoint
, createLinearRing
, createLineString
, createPolygon
, createMultiPoint
, createMultiLineString
, createMultiPolygon
, createCollection
, project
, projectNormalized
, interpolate
, interpolateNormalized
, disjoint
, touches
, intersects
, crosses
, within
, contains
, overlaps
, equals
, equalsExact
, covers
, coveredBy
, area
, geometryLength
, distance
, hausdorffDistance
, nearestPoints
, normalize
)
where
import qualified Data.Geometry.Geos.Raw.Internal
as I
import Control.Monad
import Data.Geometry.Geos.Raw.Base
import Data.Geometry.Geos.Raw.CoordSeq
import Foreign hiding ( throwIfNull
, throwIf
, throwIfNeg
)
import Foreign.Ptr ( nullPtr )
import Foreign.C.Types
import Foreign.C.String
newtype Geom = Geom {
unGeom :: ForeignPtr I.GEOSGeometry
}
newtype GeomConst = GeomConst {
unGeomConst :: Ptr I.GEOSGeometry
}
class Geometry a where
type CoordSeqInput a
withGeometry :: a
-> (Ptr I.GEOSGeometry -> IO b )
-> IO b
constructGeometry :: I.GEOSContextHandle_t -> Ptr I.GEOSGeometry -> IO a
instance Geometry Geom where
type CoordSeqInput Geom = CoordSeqConst
withGeometry (Geom g) = withForeignPtr g
constructGeometry h geo = do
fptr <- newForeignPtrEnv I.geos_GeomDestroy h geo
return $ Geom fptr
instance Geometry GeomConst where
type CoordSeqInput GeomConst = CoordSeq
withGeometry (GeomConst p) f = f p
constructGeometry _ geo = return $ GeomConst geo
withMaybeGeometry
:: Geometry a => Maybe a -> (Ptr I.GEOSGeometry -> IO b) -> IO b
withMaybeGeometry mg f = case mg of
Just g -> withGeometry g f
Nothing -> f nullPtr
createGeometryFromCoords
:: Geometry b
=> ( I.GEOSContextHandle_t
-> Ptr I.GEOSCoordSequence
-> IO (Ptr I.GEOSGeometry)
)
-> CoordSeqConst
-> Geos b
createGeometryFromCoords f c = withGeos $ \h ->
withCoordinateSequence c $ \pcs -> do
ptr <- f h pcs
constructGeometry h ptr
geomEq
:: (Eq ca, Geometry a, CoordSeqInput a ~ ca, CoordinateSequence ca)
=> a
-> a
-> Bool
geomEq a b = runGeos $ do
sa <- getSRID a
sb <- getSRID b
ta <- getTypeId a
tb <- getTypeId b
if (sa == sb) && (ta == tb)
then do
csa <- getCoordinateSequence a
csb <- getCoordinateSequence b
return $ csa == csb
else return False
instance Eq Geom where
a == b = geomEq a b
instance Eq GeomConst where
a == b = geomEq a b
getSRID :: Geometry a => a -> Geos (Maybe Int)
getSRID g = withGeos $ \h -> do
s <- withGeometry g $ I.geos_GetSRID h
case fromIntegral s of
0 -> return Nothing
i -> return (Just i)
setSRID :: Geometry a => Maybe Int -> a -> Geos a
setSRID Nothing g = return g
setSRID (Just i) g = withGeos $ \h -> do
withGeometry g $ \gp -> I.geos_SetSRID h gp $ fromIntegral i
return g
data GeomTypeId = PointTypeId | LineStringTypeId | LinearRingTypeId | PolygonTypeId
| MultiPointTypeId | MultiLineStringTypeId | MultiPolygonTypeId | GeometryCollectionTypeId deriving (Eq,Show)
geomTypeId :: Integer -> GeomTypeId
geomTypeId 0 = PointTypeId
geomTypeId 1 = LineStringTypeId
geomTypeId 2 = LinearRingTypeId
geomTypeId 3 = PolygonTypeId
geomTypeId 4 = MultiPointTypeId
geomTypeId 5 = MultiLineStringTypeId
geomTypeId 6 = MultiPolygonTypeId
geomTypeId 7 = GeometryCollectionTypeId
geomTypeId i = error $ "Not a valid geometry type " ++ show i
getTypeName :: Geometry a => a -> Geos String
getTypeName g = withGeos' $ \h -> do
eitherCString <- throwIfNull' "getType" $ withGeometry g $ I.geos_GeomType h
traverse peekCString eitherCString
getTypeId :: Geometry a => a -> Geos GeomTypeId
getTypeId g =
fmap geomTypeId
$ throwIf (0 >) (mkErrorMessage "getTypeId")
$ withGeos
$ \h -> do
i <- withGeometry g $ I.geos_GeomTypeId h
return (fromIntegral i)
getCoordinateSequence :: Geometry a => a -> Geos CoordSeq
getCoordinateSequence g = withGeos' $ \h -> do
eitherCptr <-
throwIfNull' "getCoordinateSequence" $ withGeometry g $ \gptr ->
I.geos_GetCoordSeq h gptr
traverse (create h) eitherCptr
where
create h cptr = do
cptr' <- I.geos_CoordSeqClone h cptr
fptr <- newForeignPtrEnv I.geos_CoordSeqDestroy h cptr'
return $ CoordSeq fptr
getNum_
:: Geometry a
=> (I.GEOSContextHandle_t -> Ptr I.GEOSGeometry -> IO CInt)
-> a
-> Geos Int
getNum_ f g =
throwIf (0 >) (mkErrorMessage "getNumCoordinates") $ withGeos $ \h -> do
i <- withGeometry g $ f h
return $ fromIntegral i
getNumCoordinates :: Geometry a => a -> Geos Int
getNumCoordinates = getNum_ I.geos_GetNumCoordinates
getNumInteriorRings :: Geometry a => a -> Geos Int
getNumInteriorRings = getNum_ I.geos_GetNumInteriorRings
getNumGeometries :: Geometry a => a -> Geos Int
getNumGeometries = getNum_ I.geos_GetNumGeometries
getN_
:: Geometry a
=> ( I.GEOSContextHandle_t
-> Ptr I.GEOSGeometry
-> CInt
-> IO (Ptr I.GEOSGeometry)
)
-> a
-> Int
-> Geos GeomConst
getN_ f g i = withGeos' $ \h -> do
eitherPtr <- throwIfNull' "getN" $ withGeometry g $ \gp ->
f h gp $ fromIntegral i
traverse (constructGeometry h) eitherPtr
getGeometryN :: Geometry a => a -> Int -> Geos GeomConst
getGeometryN = getN_ I.geos_GetGeometryN
getExteriorRing :: Geometry a => a -> Geos GeomConst
getExteriorRing g = withGeos' $ \h -> do
eitherGeoPtr <- throwIfNull' "getExteriorRing"
$ withGeometry g (I.geos_GetExteriorRing h)
traverse (constructGeometry h) eitherGeoPtr
getInteriorRingN :: Geometry a => a -> Int -> Geos GeomConst
getInteriorRingN = getN_ I.geos_GetInteriorRingN
normalize :: Geometry a => a -> Geos a
normalize g = do
cloned <- cloneGeometry g
_ <-
throwIf (0 >) (mkErrorMessage "normalize")
$ withGeos
$ withGeometry cloned
. I.geos_Normalize
return cloned
cloneGeometry :: Geometry a => a -> Geos a
cloneGeometry g =
withGeos $ \h -> withGeometry g $ I.geos_GeomClone h >=> constructGeometry h
createPoint :: Geometry b => CoordSeqConst -> Geos b
createPoint = createGeometryFromCoords I.geos_GeomCreatePoint
createLinearRing :: Geometry a => CoordSeqConst -> Geos a
createLinearRing = createGeometryFromCoords I.geos_GeomCreateLinearRing
createLineString :: Geometry b => CoordSeqConst -> Geos b
createLineString = createGeometryFromCoords I.geos_GeomCreateLineString
createPolygon :: Geometry a => GeomConst -> [GeomConst] -> Geos a
createPolygon o hs = withGeos $ \h -> do
ptrs <- mapM (`withGeometry` return) hs
withGeometry o $ \op -> do
g' <- case ptrs of
[] -> I.geos_GeomCreatePolygon h op nullPtr 0
xs -> withArray xs
$ \ph -> I.geos_GeomCreatePolygon h op ph $ fromIntegral $ length hs
constructGeometry h g'
createMulti_ :: Geometry a => I.GEOSGeomType -> [GeomConst] -> Geos a
createMulti_ t gs = withGeos $ \h -> do
ptrs <- mapM (`withGeometry` return) gs
withArray ptrs $ \ph -> do
g' <-
I.geos_GeomCreateCollection h (I.unGEOSGeomType t) ph
$ fromIntegral
$ length gs
constructGeometry h g'
createMultiPoint :: Geometry a => [GeomConst] -> Geos a
createMultiPoint = createMulti_ I.multiPointId
createMultiLineString :: Geometry a => [GeomConst] -> Geos a
createMultiLineString = createMulti_ I.multiLineStringId
createMultiPolygon :: Geometry a => [GeomConst] -> Geos a
createMultiPolygon = createMulti_ I.multiPolygonId
createCollection :: Geometry a => [GeomConst] -> Geos a
createCollection = createMulti_ I.geometryCollectionId
geo_2_
:: Geometry a
=> ( I.GEOSContextHandle_t
-> Ptr I.GEOSGeometry
-> Ptr I.GEOSGeometry
-> IO CDouble
)
-> a
-> a
-> Geos Double
geo_2_ f g p = withGeos $ \h -> do
d <- withGeometry g $ \gp -> withGeometry p $ f h gp
return . realToFrac $ d
project :: Geometry a => a -> a -> Geos Double
project = geo_2_ I.geos_Project
projectNormalized :: Geometry a => a -> a -> Geos Double
projectNormalized = geo_2_ I.geos_ProjectNormalized
geo_1_d
:: Geometry a
=> ( I.GEOSContextHandle_t
-> Ptr I.GEOSGeometry
-> CDouble
-> IO (Ptr I.GEOSGeometry)
)
-> a
-> Double
-> Geos Geom
geo_1_d f g d = withGeos $ \h -> withGeometry g $ \gp -> do
gp' <- f h gp $ realToFrac d
constructGeometry h gp'
interpolate :: Geometry a => a -> Double -> Geos Geom
interpolate = geo_1_d I.geos_Interpolate
interpolateNormalized :: Geometry a => a -> Double -> Geos Geom
interpolateNormalized = geo_1_d I.geos_InterpolateNormalized
binaryPredicate_
:: Geometry a
=> ( I.GEOSContextHandle_t
-> Ptr I.GEOSGeometry
-> Ptr I.GEOSGeometry
-> IO CChar
)
-> String
-> a
-> a
-> Geos Bool
binaryPredicate_ f s g1 g2 = do
b <- throwIf ((==) 2) (mkErrorMessage s) $ withGeos $ \h ->
withGeometry g1 $ \gp1 -> withGeometry g2 $ f h gp1
return . toBool $ b
disjoint :: Geometry a => a -> a -> Geos Bool
disjoint = binaryPredicate_ I.geos_Disjoint "disjoint"
touches :: Geometry a => a -> a -> Geos Bool
touches = binaryPredicate_ I.geos_Touches "touches"
intersects :: Geometry a => a -> a -> Geos Bool
intersects = binaryPredicate_ I.geos_Intersects "intersects"
crosses :: Geometry a => a -> a -> Geos Bool
crosses = binaryPredicate_ I.geos_Crosses "crosses"
within :: Geometry a => a -> a -> Geos Bool
within = binaryPredicate_ I.geos_Within "within"
contains :: Geometry a => a -> a -> Geos Bool
contains = binaryPredicate_ I.geos_Contains "contains"
overlaps :: Geometry a => a -> a -> Geos Bool
overlaps = binaryPredicate_ I.geos_Overlaps "overlaps"
equals :: Geometry a => a -> a -> Geos Bool
equals = binaryPredicate_ I.geos_Equals "equals"
equalsExact :: Geometry a => a -> a -> Double -> Geos Bool
equalsExact g1' g2' d = binaryPredicate_
(\h g1 g2 -> I.geos_EqualsExact h g1 g2 (realToFrac d))
"equalsExact"
g1'
g2'
covers :: Geometry a => a -> a -> Geos Bool
covers = binaryPredicate_ I.geos_Covers "covers"
coveredBy :: Geometry a => a -> a -> Geos Bool
coveredBy = binaryPredicate_ I.geos_CoveredBy "coveredBy"
geo_1
:: Geometry a
=> (I.GEOSContextHandle_t -> Ptr I.GEOSGeometry -> Ptr CDouble -> IO CInt)
-> a
-> Geos Double
geo_1 f g = withGeos' $ \h -> alloca $ \dptr -> do
eitherResult <- throwIfZero' (mkErrorMessage "geo_1")
$ withGeometry g (flip (f h) dptr)
traverse (\_ -> marshallDouble dptr) eitherResult
area :: Geometry a => a -> Geos Double
area = geo_1 I.geos_Area
geometryLength :: Geometry a => a -> Geos Double
geometryLength = geo_1 I.geos_Length
geo_2_d
:: Geometry a
=> ( I.GEOSContextHandle_t
-> Ptr I.GEOSGeometry
-> Ptr I.GEOSGeometry
-> Ptr CDouble
-> IO CInt
)
-> a
-> a
-> Geos Double
geo_2_d f geo1 geo2 = withGeos' $ \h -> alloca $ \dptr -> do
eitherResult <-
throwIfZero' (mkErrorMessage "geo_2") $ withGeometry geo1 $ \geoPtr1 ->
withGeometry geo2 $ \geoPtr2 -> f h geoPtr1 geoPtr2 dptr
traverse (\_ -> marshallDouble dptr) eitherResult
distance :: Geometry a => a -> a -> Geos Double
distance = geo_2_d I.geos_Distance
hausdorffDistance :: Geometry a => a -> a -> Geos Double
hausdorffDistance = geo_2_d I.geos_HausdorffDistance
nearestPoints :: (Geometry a, CoordinateSequence b) => a -> a -> Geos b
nearestPoints g p = do
ptr <- withGeos
$ \h -> withGeometry g $ \gp -> withGeometry p $ I.geos_NearestPoints h gp
createCoordinateSequence ptr