module Algebra.Geometric.Contour (
Contour (ContourC, contourList),
Vertex (VertexC, vertexX, vertexY))
where
import Data.List
import Control.Monad
import Foreign
import Foreign.C
import Algebra.Geometric.Area
newtype Contour = ContourC {contourList :: [Vertex]} deriving (Ord, Show)
type CVertex = Ptr (Vertex)
instance Storable Contour where
sizeOf _ = 8
alignment _ = alignment (undefined :: Int)
peek cContour =
ContourC `liftM`
do
numVertices <-
fromIntegral `liftM` (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) cContour
contour <- (\ptr -> do {peekByteOff ptr 4 ::IO (CVertex)}) cContour
peekArray numVertices contour
poke cContour (ContourC contour) =
do
(\ptr val -> do {pokeByteOff ptr 0 (val::CInt)}) cContour $ fromIntegral $
length contour
vertex <- newArray contour
(\ptr val -> do {pokeByteOff ptr 4 (val::(CVertex))}) cContour vertex
instance Eq Contour where
(ContourC list1) == (ContourC list2) =
list1 `elem` rotation list2 ++ rotation (reverse list2)
rotation :: Eq a => [a] -> [[a]]
rotation list = nub $ zipWith (++) (tails list) $ inits list
instance Area Contour where
area (ContourC []) = 0
area (ContourC [_]) = 0
area (ContourC (vertex1 : rest)) =
abs (addVertex (last rest) vertex1 + sumMulti rest) / 2
addVertex :: Vertex -> Vertex -> Double
addVertex (VertexC x1 y1) (VertexC x2 y2) = (x1 + x2) * (y2 y1)
sumMulti :: [Vertex] -> Double
sumMulti [] = error "sumMulti []"
sumMulti [_] = 0
sumMulti (vertex1 : rest@(vertex2 : _)) =
addVertex vertex1 vertex2 + sumMulti rest
data Vertex =
VertexC {
vertexX :: Double,
vertexY :: Double}
deriving (Eq, Ord, Show)
instance Storable Vertex where
sizeOf _ = 16
alignment _ = alignment (undefined :: Int)
peek cVertex =
do
x <- get (\ptr -> do {peekByteOff ptr 0 ::IO CDouble})
y <- get (\ptr -> do {peekByteOff ptr 8 ::IO CDouble})
return $ VertexC x y
where get field = realToFrac `liftM` field cVertex
poke cVertex (VertexC x y) =
do
(\ptr val -> do {pokeByteOff ptr 0 (val::CDouble)}) cVertex (realToFrac x)
(\ptr val -> do {pokeByteOff ptr 8 (val::CDouble)}) cVertex (realToFrac y)