{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Geometry.Geos.Raw.STRTree where
import Prelude hiding (foldr)
import qualified Data.Geometry.Geos.Raw.Internal as I
import qualified Data.Geometry.Geos.Raw.Geometry as RG
import qualified Data.Geometry.Geos.Raw.CoordSeq as RC
import Data.Geometry.Geos.Raw.Base
import Foreign
import qualified Foreign.Concurrent as FC
import Data.IORef
import qualified Data.Vector as V
class STRTreeLike t where
withSTRTree :: t a -> (Ptr I.GEOSSTRTree -> IO b ) -> IO b
instance STRTreeLike STRTree where
withSTRTree (STRTree t) f = withForeignPtr t f
instance STRTreeLike STRTreeBuilder where
withSTRTree (STRTreeBuilder t) f = withForeignPtr t f
newtype STRTree a = STRTree (ForeignPtr I.GEOSSTRTree)
deriving (Show, Eq)
newtype STRTreeBuilder a = STRTreeBuilder (ForeignPtr I.GEOSSTRTree)
deriving (Show, Eq)
type Finalizer a b = Ptr a -> Ptr b -> IO ()
foreign import ccall "wrapper"
wrap2 :: (Ptr a -> Ptr () -> IO ()) -> IO (I.GEOSQueryCallback a)
foreign import ccall "dynamic"
unwrap :: FunPtr (Finalizer a b) -> Finalizer a b
createSTRTreeBuilder :: Int -> Geos (STRTreeBuilder a)
createSTRTreeBuilder nodeCapacity = withGeos $ \h -> do
t <- I.geos_STRTreeCreate h $ fromIntegral nodeCapacity
let cleanup = unwrap I.geos_STRTreeDestroy h t
fp <- FC.newForeignPtr t cleanup
return $ STRTreeBuilder fp
build :: STRTreeBuilder a -> Geos (STRTree a)
build tree@(STRTreeBuilder fp) = do
cs <- RC.createEmptyCoordinateSequence 1 2
p ::RG.Geom <- RG.createPoint cs
withGeos $ \h -> do
callback <- wrap2 $ \_ _ -> return ()
RG.withGeometry p $ \rg ->
withSTRTree tree $ \st -> I.geos_STRTreeQuery h st rg callback nullPtr
return $ STRTree fp
insert :: (Storable b, RG.Geometry a) => STRTreeBuilder b -> a -> b -> Geos ()
insert (STRTreeBuilder tree) geometry item =
withGeos $ \h -> do
ptr <- malloc
poke ptr item
_ <- withForeignPtr tree $ \st -> do
RG.withGeometry geometry $ \gr ->
I.geos_STRTreeInsert h st gr ptr
let cleanup = free ptr
FC.addForeignPtrFinalizer tree cleanup
return ()
foldr :: (STRTreeLike t, Storable a) => (a -> b -> b) -> b -> t a -> Geos b
foldr func acc tree = withGeos $ \h -> do
b <- newIORef acc
callback <- wrap2 $ \a _ -> do
i <- peek a
modifyIORef' b (func i)
_ <- withSTRTree tree $ \st -> I.geos_STRTreeIterate h st callback nullPtr
freeHaskellFunPtr callback
readIORef b
query :: (Storable b, RG.Geometry a)
=> STRTree b
-> a
-> Geos (V.Vector b)
query t g =
withGeos $ \h -> do
r <- newIORef V.empty
callback <- wrap2 $ \a _ -> do
i <- peek a
modifyIORef' r (flip V.snoc i)
_ <- RG.withGeometry g $ \rg ->
withSTRTree t $ \st ->
I.geos_STRTreeQuery h st rg callback nullPtr
freeHaskellFunPtr callback
readIORef r