diff --git a/hgeos.cabal b/hgeos.cabal --- a/hgeos.cabal +++ b/hgeos.cabal @@ -1,5 +1,5 @@ name: hgeos -version: 0.1.3.0 +version: 0.1.4.0 synopsis: Simple Haskell bindings to GEOS C API description: Simple Haskell bindings to the @@ -25,12 +25,14 @@ hs-source-dirs: src/lib default-language: Haskell2010 build-depends: base >= 4.7 && < 5 + , transformers extra-libraries: geos_c c-sources: src/lib/Data/Geolocation/GEOS/helpers.c , src/lib/Data/Geolocation/GEOS/helpers.h cc-options: -std=c99 -pthread exposed-modules: Data.Geolocation.GEOS , Data.Geolocation.GEOS.Imports + , Data.Geolocation.GEOS.Trans if os(windows) include-dirs: C:/OSGeo4W64/include extra-lib-dirs: C:/OSGeo4W64/lib @@ -43,7 +45,10 @@ build-depends: MissingH , base >= 4.7 && < 5 , hgeos + , mtl + , transformers other-modules: GEOSTest.Arith , GEOSTest.HighLevelAPI , GEOSTest.LowLevelAPI , GEOSTest.Sample + , GEOSTest.TransAPI diff --git a/src/lib/Data/Geolocation/GEOS.hs b/src/lib/Data/Geolocation/GEOS.hs --- a/src/lib/Data/Geolocation/GEOS.hs +++ b/src/lib/Data/Geolocation/GEOS.hs @@ -12,6 +12,8 @@ For the low-level FFI bindings, see "Data.Geolocation.GEOS.Imports". +For the monad transformer wrappers, see "Data.Geolocation.GEOS.Trans". + @@ -60,7 +62,7 @@ data Context = Context ContextStateRef data ContextState = ContextState - { hCtx :: GEOSContextHandle_t + { hCtx :: GEOSContextHandle , hReaders :: [GEOSWKTReaderPtr] , hWriters :: [GEOSWKTWriterPtr] , hGeometries :: [GEOSGeometryPtr] @@ -104,7 +106,7 @@ value <- peek valuePtr return $ Just (realToFrac value) -checkAndDoNotTrack :: ContextStateRef -> (GEOSContextHandle_t -> IO GEOSGeometryPtr) -> IO (Maybe Geometry) +checkAndDoNotTrack :: ContextStateRef -> (GEOSContextHandle -> IO GEOSGeometryPtr) -> IO (Maybe Geometry) checkAndDoNotTrack sr f = do ContextState{..} <- readIORef sr h <- f hCtx @@ -112,7 +114,7 @@ then Nothing else Just $ Geometry sr h -checkAndTrack :: ContextStateRef -> (GEOSContextHandle_t -> IO GEOSGeometryPtr) -> IO (Maybe Geometry) +checkAndTrack :: ContextStateRef -> (GEOSContextHandle -> IO GEOSGeometryPtr) -> IO (Maybe Geometry) checkAndTrack sr f = do ContextState{..} <- readIORef sr h <- f hCtx @@ -166,7 +168,7 @@ then Nothing else Just $ fromIntegral value -getOrdinate :: (GEOSContextHandle_t -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt) -> +getOrdinate :: (GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt) -> CoordinateSequence -> Word -> IO (Maybe Double) getOrdinate f (CoordinateSequence sr h) index = do ContextState{..} <- readIORef sr diff --git a/src/lib/Data/Geolocation/GEOS/Imports.hs b/src/lib/Data/Geolocation/GEOS/Imports.hs --- a/src/lib/Data/Geolocation/GEOS/Imports.hs +++ b/src/lib/Data/Geolocation/GEOS/Imports.hs @@ -14,11 +14,13 @@ For the high-level API, see "Data.Geolocation.GEOS". +For the monad transformer wrappers, see "Data.Geolocation.GEOS.Trans". + -} module Data.Geolocation.GEOS.Imports - ( GEOSContextHandle_t () + ( GEOSContextHandle () , GEOSCoordSequencePtr () , GEOSGeometryPtr () , GEOSWKTReaderPtr () @@ -56,11 +58,11 @@ -- |Determines if given pointer is null class NullablePtr a where - -- |Returns @True@ if pointer is null, @False@ otherwise + -- |Evaluates to @True@ if pointer is null, @False@ otherwise isNullPtr :: a -> Bool --- |Wraps @GEOSContextHandle_t@ -newtype GEOSContextHandle_t = GEOSContextHandle_t (Ptr GEOSContextHandle_t) +-- |Wraps @GEOSContextHandle@ +newtype GEOSContextHandle = GEOSContextHandle (Ptr GEOSContextHandle) -- |Wraps @GEOSCoordSequence*@ newtype GEOSCoordSequencePtr = GEOSCoordSequencePtr (Ptr GEOSCoordSequencePtr) @@ -84,99 +86,99 @@ -- |Wraps @GEOSArea_r@ foreign import ccall "GEOSArea_r" - c_GEOSArea_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> Ptr CDouble -> IO CInt + c_GEOSArea_r :: GEOSContextHandle -> GEOSGeometryPtr -> Ptr CDouble -> IO CInt -- |Wraps @GEOSCoordSeq_destroy_r@ foreign import ccall "GEOSCoordSeq_destroy_r" - c_GEOSCoordSeq_destroy_r :: GEOSContextHandle_t -> GEOSCoordSequencePtr -> IO () + c_GEOSCoordSeq_destroy_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> IO () -- |Wraps @GEOSCoordSeq_getSize_r@ foreign import ccall "GEOSCoordSeq_getSize_r" - c_GEOSCoordSeq_getSize_r :: GEOSContextHandle_t -> GEOSCoordSequencePtr -> Ptr CUInt -> IO CInt + c_GEOSCoordSeq_getSize_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> Ptr CUInt -> IO CInt -- |Wraps @GEOSCoordSeq_getX_r@ foreign import ccall "GEOSCoordSeq_getX_r" - c_GEOSCoordSeq_getX_r :: GEOSContextHandle_t -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt + c_GEOSCoordSeq_getX_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt -- |Wraps @GEOSCoordSeq_getY_r@ foreign import ccall "GEOSCoordSeq_getY_r" - c_GEOSCoordSeq_getY_r :: GEOSContextHandle_t -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt + c_GEOSCoordSeq_getY_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt -- |Wraps @GEOSCoordSeq_getZ_r@ foreign import ccall "GEOSCoordSeq_getZ_r" - c_GEOSCoordSeq_getZ_r :: GEOSContextHandle_t -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt + c_GEOSCoordSeq_getZ_r :: GEOSContextHandle -> GEOSCoordSequencePtr -> CUInt -> Ptr CDouble -> IO CInt -- |Wraps @GEOSEnvelope_r@ foreign import ccall "GEOSEnvelope_r" - c_GEOSEnvelope_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO GEOSGeometryPtr + c_GEOSEnvelope_r :: GEOSContextHandle -> GEOSGeometryPtr -> IO GEOSGeometryPtr -- |Wraps @GEOSFree_r@ specialized to @const char*@ foreign import ccall "GEOSFree_r" - c_GEOSFree_r_CString :: GEOSContextHandle_t -> CString -> IO () + c_GEOSFree_r_CString :: GEOSContextHandle -> CString -> IO () -- |Wraps @GEOSGeomTypeId_r@ foreign import ccall "GEOSGeomTypeId_r" - c_GEOSGeomTypeId_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO CInt + c_GEOSGeomTypeId_r :: GEOSContextHandle -> GEOSGeometryPtr -> IO CInt -- |Wraps @GEOSGeom_destroy_r@ foreign import ccall "GEOSGeom_destroy_r" - c_GEOSGeom_destroy_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO () + c_GEOSGeom_destroy_r :: GEOSContextHandle -> GEOSGeometryPtr -> IO () -- |Wraps @GEOSGeom_getCoordSeq_r@ foreign import ccall "GEOSGeom_getCoordSeq_r" - c_GEOSGeom_getCoordSeq_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO GEOSCoordSequencePtr + c_GEOSGeom_getCoordSeq_r :: GEOSContextHandle -> GEOSGeometryPtr -> IO GEOSCoordSequencePtr -- |Wraps @GEOSGetExteriorRing_r@ foreign import ccall "GEOSGetExteriorRing_r" - c_GEOSGetExteriorRing_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO GEOSGeometryPtr + c_GEOSGetExteriorRing_r :: GEOSContextHandle -> GEOSGeometryPtr -> IO GEOSGeometryPtr -- |Wraps @GEOSGetGeometryN_r@ foreign import ccall "GEOSGetGeometryN_r" - c_GEOSGetGeometryN_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> CInt -> IO GEOSGeometryPtr + c_GEOSGetGeometryN_r :: GEOSContextHandle -> GEOSGeometryPtr -> CInt -> IO GEOSGeometryPtr -- |Wraps @GEOSGetNumGeometries_r@ foreign import ccall "GEOSGetNumGeometries_r" - c_GEOSGetNumGeometries_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO CInt + c_GEOSGetNumGeometries_r :: GEOSContextHandle -> GEOSGeometryPtr -> IO CInt -- |Wraps @GEOSIntersection_r@ foreign import ccall "GEOSIntersection_r" - c_GEOSIntersection_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> GEOSGeometryPtr -> IO GEOSGeometryPtr + c_GEOSIntersection_r :: GEOSContextHandle -> GEOSGeometryPtr -> GEOSGeometryPtr -> IO GEOSGeometryPtr -- |Wraps @GEOSWKTReader_create_r@ foreign import ccall "GEOSWKTReader_create_r" - c_GEOSWKTReader_create_r :: GEOSContextHandle_t -> IO GEOSWKTReaderPtr + c_GEOSWKTReader_create_r :: GEOSContextHandle -> IO GEOSWKTReaderPtr -- |Wraps @GEOSWKTReader_destroy_r@ foreign import ccall "GEOSWKTReader_destroy_r" - c_GEOSWKTReader_destroy_r :: GEOSContextHandle_t -> GEOSWKTReaderPtr -> IO () + c_GEOSWKTReader_destroy_r :: GEOSContextHandle -> GEOSWKTReaderPtr -> IO () -- |Wraps @GEOSWKTReader_read_r@ foreign import ccall "GEOSWKTReader_read_r" - c_GEOSWKTReader_read_r :: GEOSContextHandle_t -> GEOSWKTReaderPtr -> CString -> IO GEOSGeometryPtr + c_GEOSWKTReader_read_r :: GEOSContextHandle -> GEOSWKTReaderPtr -> CString -> IO GEOSGeometryPtr -- |Wraps @GEOSWKTWriter_create_r@ foreign import ccall "GEOSWKTWriter_create_r" - c_GEOSWKTWriter_create_r :: GEOSContextHandle_t -> IO GEOSWKTWriterPtr + c_GEOSWKTWriter_create_r :: GEOSContextHandle -> IO GEOSWKTWriterPtr -- |Wraps @GEOSWKTWriter_destroy_r@ foreign import ccall "GEOSWKTWriter_destroy_r" - c_GEOSWKTWriter_destroy_r :: GEOSContextHandle_t -> GEOSWKTWriterPtr -> IO () + c_GEOSWKTWriter_destroy_r :: GEOSContextHandle -> GEOSWKTWriterPtr -> IO () -- |Wraps @GEOSWKTWriter_write_r@ foreign import ccall "GEOSWKTWriter_write_r" - c_GEOSWKTWriter_write_r :: GEOSContextHandle_t -> GEOSWKTWriterPtr -> GEOSGeometryPtr -> IO CString + c_GEOSWKTWriter_write_r :: GEOSContextHandle -> GEOSWKTWriterPtr -> GEOSGeometryPtr -> IO CString -- |Wraps @GEOSisEmpty_r@ foreign import ccall "GEOSisEmpty_r" - c_GEOSisEmpty_r :: GEOSContextHandle_t -> GEOSGeometryPtr -> IO CChar + c_GEOSisEmpty_r :: GEOSContextHandle -> GEOSGeometryPtr -> IO CChar -- |Wraps @GEOSversion@ foreign import ccall "GEOSversion" c_GEOSversion :: IO CString --- |Wraps @finishGEOS_r@ helper function +-- |Wraps @finishGEOS_r@ foreign import ccall "finishGEOS_r" - c_finishGEOS_r :: GEOSContextHandle_t -> IO () + c_finishGEOS_r :: GEOSContextHandle -> IO () -- |Wraps @getErrorMessage@ helper function foreign import ccall "helpers.h getErrorMessage" @@ -188,4 +190,4 @@ -- |Wraps @initializeGEOSWithHandlers@ helper function foreign import ccall "helpers.h initializeGEOSWithHandlers" - c_initializeGEOSWithHandlers :: IO GEOSContextHandle_t + c_initializeGEOSWithHandlers :: IO GEOSContextHandle diff --git a/src/lib/Data/Geolocation/GEOS/Trans.hs b/src/lib/Data/Geolocation/GEOS/Trans.hs new file mode 100644 --- /dev/null +++ b/src/lib/Data/Geolocation/GEOS/Trans.hs @@ -0,0 +1,130 @@ +{-| +Module : Data.Geolocation.GEOS.Trans +Description : @MaybeT@ wrappers for high-level GEOS API +Copyright : (C) Richard Cook, 2016 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : experimental +Portability : POSIX + +These are @MaybeT@ monad transformer wrapper functions for the high-level API +to simplify error handling in client code. + +For the low-level FFI bindings, see "Data.Geolocation.GEOS.Imports". + +For the high-level API, see "Data.Geolocation.GEOS". + + +-} + +module Data.Geolocation.GEOS.Trans + ( areaM + , envelopeM + , geomTypeIdM + , getCoordSeqM + , getExteriorRingM + , getGeometryM + , getNumGeometriesM + , getSizeM + , getXM + , getYM + , getZM + , intersectionM + , isEmptyM + , mkReaderM + , mkWriterM + , readGeometryM + , runGEOS + , writeGeometryM + ) where + +import Control.Monad.Trans.Maybe +import Data.Geolocation.GEOS + +unaryGEOSFunc :: (a -> IO (Maybe b)) -> a -> MaybeT IO b +unaryGEOSFunc = (MaybeT .) + +binaryGEOSFunc :: (a -> b -> IO (Maybe c)) -> a -> b -> MaybeT IO c +binaryGEOSFunc f a b = MaybeT (f a b) + +-- | @MaybeT@-wrapped version of 'area' +areaM :: Geometry -> MaybeT IO Double +areaM = unaryGEOSFunc area + +-- | @MaybeT@-wrapped version of 'envelope' +envelopeM :: Geometry -> MaybeT IO Geometry +envelopeM = unaryGEOSFunc envelope + +-- | @MaybeT@-wrapped version of 'geomTypeId' +geomTypeIdM :: Geometry -> MaybeT IO GeometryType +geomTypeIdM = unaryGEOSFunc geomTypeId + +-- | @MaybeT@-wrapped version of 'getCoordSeq' +getCoordSeqM :: Geometry -> MaybeT IO CoordinateSequence +getCoordSeqM = unaryGEOSFunc getCoordSeq + +-- | @MaybeT@-wrapped version of 'getExteriorRing' +getExteriorRingM :: Geometry -> MaybeT IO Geometry +getExteriorRingM = unaryGEOSFunc getExteriorRing + +-- | @MaybeT@-wrapped version of 'getGeometry' +getGeometryM :: Geometry -> Int -> MaybeT IO Geometry +getGeometryM = binaryGEOSFunc getGeometry + +-- | @MaybeT@-wrapped version of 'getNumGeometries' +getNumGeometriesM :: Geometry -> MaybeT IO Int +getNumGeometriesM = unaryGEOSFunc getNumGeometries + +-- | @MaybeT@-wrapped version of 'getSize' +getSizeM :: CoordinateSequence -> MaybeT IO Word +getSizeM = unaryGEOSFunc getSize + +-- | @MaybeT@-wrapped version of 'getX' +getXM :: CoordinateSequence -> Word -> MaybeT IO Double +getXM = binaryGEOSFunc getX + +-- | @MaybeT@-wrapped version of 'getY' +getYM :: CoordinateSequence -> Word -> MaybeT IO Double +getYM = binaryGEOSFunc getY + +-- | @MaybeT@-wrapped version of 'getZ' +getZM :: CoordinateSequence -> Word -> MaybeT IO Double +getZM = binaryGEOSFunc getZ + +-- | @MaybeT@-wrapped version of 'intersection' +intersectionM :: Geometry -> Geometry -> MaybeT IO Geometry +intersectionM = binaryGEOSFunc intersection + +-- | @MaybeT@-wrapped version of 'isEmpty' +isEmptyM :: Geometry -> MaybeT IO Bool +isEmptyM = unaryGEOSFunc isEmpty + +-- | @MaybeT@-wrapped version of 'mkReader' +mkReaderM :: Context -> MaybeT IO Reader +mkReaderM = unaryGEOSFunc mkReader + +-- | @MaybeT@-wrapped version of 'mkWriter' +mkWriterM :: Context -> MaybeT IO Writer +mkWriterM = unaryGEOSFunc mkWriter + +-- | @MaybeT@-wrapped version of 'readGeometry' +readGeometryM :: Reader -> String -> MaybeT IO Geometry +readGeometryM = binaryGEOSFunc readGeometry + +-- |Creates a context, passes it to a block +-- and releases the context and all associated objects such as readers, writers +-- and geometries at the end inside a @MaybeT IO@ monad: +-- +-- @ +-- runGEOS $ \ctx -> do +-- +-- -- Use context +-- +-- return () +-- @ +runGEOS :: (Context -> MaybeT IO a) -> IO (Maybe a) +runGEOS = withGEOS . (runMaybeT .) + +-- | @MaybeT@-wrapped version of 'area' +writeGeometryM :: Writer -> Geometry -> MaybeT IO String +writeGeometryM = binaryGEOSFunc writeGeometry diff --git a/src/test/GEOSTest/HighLevelAPI.hs b/src/test/GEOSTest/HighLevelAPI.hs --- a/src/test/GEOSTest/HighLevelAPI.hs +++ b/src/test/GEOSTest/HighLevelAPI.hs @@ -1,18 +1,21 @@ module GEOSTest.HighLevelAPI (demo) where +import Control.Monad.Trans +import Control.Monad.Trans.Maybe import Data.Geolocation.GEOS +import Data.Maybe -- Demonstrates use of high-level API -- Lifetimes of GEOS objects are automatically managed by the context objects -- which guarantees that they are released when the context goes out of scope demo :: IO () demo = do - withGEOS $ \ctx -> do - (Just reader) <- mkReader ctx - (Just g0) <- readGeometry reader "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" - (Just g1) <- readGeometry reader "POLYGON (( 11 11, 11 12, 12 12, 12 11, 11 11 ))" - (Just g2) <- intersection g0 g1 - (Just writer) <- mkWriter ctx - (Just str) <- writeGeometry writer g2 - putStrLn str - putStrLn "HighLevelAPI.demo done" + result <- withGEOS $ \ctx -> runMaybeT $ do + reader <- MaybeT $ mkReader ctx + g0 <- MaybeT $ readGeometry reader "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" + g1 <- MaybeT $ readGeometry reader "POLYGON (( 11 11, 11 12, 12 12, 12 11, 11 11 ))" + g2 <- MaybeT $ intersection g0 g1 + writer <- MaybeT $ mkWriter ctx + str <- MaybeT $ writeGeometry writer g2 + lift $ putStrLn str + putStrLn $ "HighLevelAPI.demo: " ++ (if isJust result then "succeeded" else "failed") diff --git a/src/test/GEOSTest/LowLevelAPI.hs b/src/test/GEOSTest/LowLevelAPI.hs --- a/src/test/GEOSTest/LowLevelAPI.hs +++ b/src/test/GEOSTest/LowLevelAPI.hs @@ -26,13 +26,13 @@ putStrLn str putStrLn "LowLevelAPI.demo done" where - withGEOS :: (GEOSContextHandle_t -> IO a) -> IO a + withGEOS :: (GEOSContextHandle -> IO a) -> IO a withGEOS = bracket c_initializeGEOSWithHandlers c_finishGEOS_r - withWKTReader :: GEOSContextHandle_t -> (GEOSWKTReaderPtr -> IO a) -> IO a + withWKTReader :: GEOSContextHandle -> (GEOSWKTReaderPtr -> IO a) -> IO a withWKTReader ctx = bracket (c_GEOSWKTReader_create_r ctx) (c_GEOSWKTReader_destroy_r ctx) - withWKTWriter :: GEOSContextHandle_t -> (GEOSWKTWriterPtr -> IO a) -> IO a + withWKTWriter :: GEOSContextHandle -> (GEOSWKTWriterPtr -> IO a) -> IO a withWKTWriter ctx = bracket (c_GEOSWKTWriter_create_r ctx) (c_GEOSWKTWriter_destroy_r ctx) - withGeometry :: GEOSContextHandle_t -> GEOSWKTReaderPtr -> CString -> (GEOSGeometryPtr -> IO a) -> IO a + withGeometry :: GEOSContextHandle -> GEOSWKTReaderPtr -> CString -> (GEOSGeometryPtr -> IO a) -> IO a withGeometry ctx reader wkt = bracket (c_GEOSWKTReader_read_r ctx reader wkt) diff --git a/src/test/GEOSTest/Sample.hs b/src/test/GEOSTest/Sample.hs --- a/src/test/GEOSTest/Sample.hs +++ b/src/test/GEOSTest/Sample.hs @@ -3,8 +3,11 @@ module GEOSTest.Sample (demo) where import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Maybe import Data.Geolocation.GEOS import Data.List +import Data.Maybe import Data.String.Utils import GEOSTest.Arith import Paths_hgeos @@ -15,26 +18,6 @@ type Longitude = Double type Resolution = Double -printGeometry :: Writer -> Geometry -> IO () -printGeometry r g = do - maybeStr <- writeGeometry r g - case maybeStr of - Nothing -> putStrLn "(invalid)" - (Just str) -> putStrLn str - -getXYZs :: CoordinateSequence -> IO (Maybe [Coordinate]) -getXYZs coordSeq = do - maybeSize <- getSize coordSeq - case maybeSize of - Nothing -> return Nothing - Just size -> do - xyzs <- forM [0..(size - 1)] $ \i -> do - (Just x) <- getX coordSeq i - (Just y) <- getY coordSeq i - (Just z) <- getZ coordSeq i - return (x, y, z) - return $ Just xyzs - data Extent = Extent { minX :: Double , maxX :: Double @@ -44,6 +27,15 @@ , maxZ :: Double } deriving Show +getXYZs :: CoordinateSequence -> MaybeT IO [Coordinate] +getXYZs coordSeq = do + size <- MaybeT $ getSize coordSeq + forM [0..(size - 1)] $ \i -> do + x <- MaybeT $ getX coordSeq i + y <- MaybeT $ getY coordSeq i + z <- MaybeT $ getZ coordSeq i + return (x, y, z) + extent :: [Coordinate] -> Extent extent ((x, y, z) : cs) = let (minX, maxX, minY, maxY, minZ, maxZ) = @@ -56,8 +48,9 @@ if z' > maxX then z' else maxZ)) (x, x, y, y, z, z) cs in Extent minX maxX minY maxY minZ maxZ -mkSquare :: Reader -> Longitude -> Latitude -> Resolution -> IO Geometry -mkSquare reader longitude latitude resolution = do +-- TODO: Build polygon using API instead of string parsing +mkSquare :: Reader -> Longitude -> Latitude -> Resolution -> MaybeT IO Geometry +mkSquare reader longitude latitude resolution = let points = [ (longitude, latitude), (longitude + resolution, latitude), @@ -66,41 +59,32 @@ (longitude, latitude) ] wkt = printf "POLYGON ((%s))" (intercalate "," (map (\(a, b) -> printf "%f %f" a b) points)) - (Just g) <- readGeometry reader wkt - return g - -getGeometries :: Geometry -> IO [Geometry] -getGeometries geometry = do - (Just count) <- getNumGeometries geometry - forM [0..(count - 1)] $ \i -> do - (Just g) <- getGeometry geometry i - return g + in MaybeT $ readGeometry reader wkt -findBiggestPolygon :: Geometry -> IO Geometry -findBiggestPolygon geometry = do - geometries@(g : gs) <- getGeometries geometry - a : as <- sequence $ map area geometries - let (g', _) = foldr (\p@(_, a') biggest@(_, aBiggest) -> if a' > aBiggest then p else biggest) (g, a) (zip gs as) - return g' +getGeometries :: Geometry -> IO (Maybe [Geometry]) +getGeometries geometry = runMaybeT $ do + count <- MaybeT $ getNumGeometries geometry + mapM (MaybeT . getGeometry geometry) [0..(count - 1)] -resolution :: Double -resolution = 1.0 +findBiggestPolygon :: Geometry -> IO (Maybe Geometry) +findBiggestPolygon geometry = runMaybeT $ do + gs@(gHead : gTail) <- MaybeT (getGeometries geometry) + as@(aHead : aTail) <- mapM (MaybeT . area) gs + return $ fst $ foldr + (\p'@(_, a') p@(_, a) -> if a' > a then p' else p) + (gHead, aHead) + (zip gTail aTail) -processPolygon :: String -> Resolution -> Longitude -> Latitude -> Geometry -> IO () +processPolygon :: String -> Resolution -> Longitude -> Latitude -> Geometry -> MaybeT IO () processPolygon tableName resolution longitude latitude p = do + shell <- MaybeT $ getExteriorRing p + coordSeq <- MaybeT $ getCoordSeq shell + xyzs <- getXYZs coordSeq let pId = polygonId resolution longitude latitude - (Just shell) <- getExteriorRing p - (Just coordSeq) <- getCoordSeq shell - (Just xyzs) <- getXYZs coordSeq - forM_ (zip [0..] xyzs) $ \(pointId, (x, y, _)) -> do - let s = printf - "INSERT INTO %s (polygon_id, point_id, longitude, latitude) VALUES ('%s', %d, %f, %f);\n" - tableName - pId - (pointId :: Int) - x - y - putStr s + format :: Int -> Double -> Double -> String + format = printf "INSERT INTO %s (polygon_id, point_id, longitude, latitude) VALUES ('%s', %d, %f, %f);\n" tableName pId + strs = map (\(pointId, (x, y, _)) -> format pointId x y) (zip [0..] xyzs) + lift $ forM_ strs putStr polygonId :: Resolution -> Longitude -> Latitude -> String polygonId resolution longitude latitude = "id_" ++ formatValue longitude ++ "_" ++ formatValue latitude @@ -108,42 +92,49 @@ formatValue :: Double -> String formatValue = replace "-" "m" . replace "." "_" . (printf "%.2f") . mfloor resolution --- A more involved example of use of API +generatePolygonMeshSQL :: Context -> String -> Resolution -> MaybeT IO () +generatePolygonMeshSQL ctx wkt resolution = do + reader <- MaybeT $ mkReader ctx + writer <- MaybeT $ mkWriter ctx + country <- MaybeT $ readGeometry reader wkt + env <- MaybeT $ envelope country + shell <- MaybeT $ getExteriorRing env + coordSeq <- MaybeT $ getCoordSeq shell + xyzs <- getXYZs coordSeq + + lift $ do + putStrLn "Shell:" + mapM_ print xyzs + + let Extent{..} = extent xyzs + mfloorRes = mfloor resolution + longitudeBegin = mfloorRes minX + longitudeEnd = mfloorRes maxX + resolution + latitudeBegin = mfloorRes minY + latitudeEnd = mfloorRes maxY + resolution + + lift $ do + putStrLn "Longitude and latitude ranges:" + putStrLn $ printf " longitude %f to %f" longitudeBegin longitudeEnd + putStrLn $ printf " latitude %f to %f" latitudeBegin latitudeEnd + + let longitudes = frange longitudeBegin longitudeEnd 1.0 + latitudes = frange latitudeBegin latitudeEnd 1.0 + forM_ [(i, j) | i <- longitudes, j <- latitudes] $ \(longitude, latitude) -> do + square <- mkSquare reader longitude latitude resolution + overlap <- MaybeT $ intersection square country + isOverlapEmpty <- MaybeT $ isEmpty overlap + unless isOverlapEmpty $ do + typeId <- MaybeT $ geomTypeId overlap + polygon <- case typeId of + MultiPolygon -> MaybeT $ findBiggestPolygon overlap + Polygon -> return overlap + processPolygon "TABLE_NAME" resolution longitude latitude polygon + return () + demo :: IO () demo = do fileName <- getDataFileName "data/namibia.wkt" wkt <- readFile fileName - withGEOS $ \ctx -> do - (Just reader) <- mkReader ctx - (Just writer) <- mkWriter ctx - let p = printGeometry writer - - (Just country) <- readGeometry reader wkt - (Just env) <- envelope country - (Just shell) <- getExteriorRing env - (Just coordSeq) <- getCoordSeq shell - (Just xyzs) <- getXYZs coordSeq - forM_ xyzs $ \(x, y, z) -> print (x, y, z) - let Extent{..} = extent xyzs - mfloorRes = mfloor resolution - longitudeBegin = mfloorRes minX - longitudeEnd = mfloorRes maxX + resolution - latitudeBegin = mfloorRes minY - latitudeEnd = mfloorRes maxY + resolution - print longitudeBegin - print longitudeEnd - print latitudeBegin - print latitudeEnd - let longitudes = frange longitudeBegin longitudeEnd 1.0 - latitudes = frange latitudeBegin latitudeEnd 1.0 - forM_ [(i, j) | i <- longitudes, j <- latitudes] $ \(longitude, latitude) -> do - square <- mkSquare reader longitude latitude resolution - (Just overlap) <- intersection square country - (Just x) <- isEmpty overlap - unless x $ do - (Just t) <- geomTypeId overlap - polygon <- case t of - MultiPolygon -> findBiggestPolygon overlap - Polygon -> return overlap - processPolygon "foo" resolution longitude latitude polygon - putStrLn "Sample.demo done" + result <- withGEOS $ \ctx -> runMaybeT (generatePolygonMeshSQL ctx wkt 1.0) + putStrLn $ "Sample.demo: " ++ (if isJust result then "succeeded" else "failed") diff --git a/src/test/GEOSTest/TransAPI.hs b/src/test/GEOSTest/TransAPI.hs new file mode 100644 --- /dev/null +++ b/src/test/GEOSTest/TransAPI.hs @@ -0,0 +1,21 @@ +module GEOSTest.TransAPI (demo) where + +import Control.Monad.Trans +import Control.Monad.Trans.Maybe +import Data.Geolocation.GEOS.Trans +import Data.Maybe + +-- Demonstrates use of monad transformer API +-- Lifetimes of GEOS objects are automatically managed by the context objects +-- which guarantees that they are released when the context goes out of scope +demo :: IO () +demo = do + result <- runGEOS $ \ctx -> do + reader <- mkReaderM ctx + g0 <- readGeometryM reader "POLYGON (( 10 10, 10 20, 20 20, 20 10, 10 10 ))" + g1 <- readGeometryM reader "POLYGON (( 11 11, 11 12, 12 12, 12 11, 11 11 ))" + g2 <- intersectionM g0 g1 + writer <- mkWriterM ctx + str <- writeGeometryM writer g2 + lift $ putStrLn str + putStrLn $ "TransAPI.demo: " ++ (if isJust result then "succeeded" else "failed") diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -6,6 +6,7 @@ import qualified GEOSTest.HighLevelAPI as HighLevelAPI import qualified GEOSTest.LowLevelAPI as LowLevelAPI import qualified GEOSTest.Sample as Sample +import qualified GEOSTest.TransAPI as TransAPI main :: IO () main = do @@ -13,4 +14,5 @@ putStrLn v LowLevelAPI.demo HighLevelAPI.demo + TransAPI.demo Sample.demo